3b8f36ee4f8711f21eb7907ec860367ce6d8a3cd
[whenjobs.git] / lib / pa_when.ml
1 (* whenjobs
2  * Copyright (C) 2012 Red Hat Inc.
3  *
4  * This program is free software; you can redistribute it and/or modify
5  * it under the terms of the GNU General Public License as published by
6  * the Free Software Foundation; either version 2 of the License, or
7  * (at your option) any later version.
8  *
9  * This program is distributed in the hope that it will be useful,
10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12  * GNU General Public License for more details.
13  *
14  * You should have received a copy of the GNU General Public License along
15  * with this program; if not, write to the Free Software Foundation, Inc.,
16  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17  *)
18
19 (* For general information about camlp4, see:
20  * http://brion.inria.fr/gallium/index.php/Camlp4
21  *
22  * For information about quotations, see:
23  * http://brion.inria.fr/gallium/index.php/Quotation
24  *)
25
26 open Printf
27
28 open Camlp4.PreCast
29 open Syntax
30 open Ast
31
32 let unique = let i = ref 0 in fun () -> incr i; !i
33
34 let unique_job_name () = sprintf "job$%d" (unique ())
35
36 (* Convert a _loc to an AST. *)
37 let expr_of_loc _loc loc =
38   let file_name,
39     start_line, start_bol, start_off,
40     stop_line, stop_bol, stop_off,
41     ghost = Loc.to_tuple loc in
42   <:expr< Camlp4.PreCast.Loc.of_tuple
43     ($str:file_name$,
44      $`int:start_line$, $`int:start_bol$, $`int:start_off$,
45      $`int:stop_line$, $`int:stop_bol$, $`int:stop_off$,
46      $`bool:ghost$) >>
47
48 (* "Lift" an expression, turning it from an expression into an OCaml
49  * abstract syntax tree in the output.  This is pretty obscure.
50  * http://caml.inria.fr/pub/ml-archives/caml-list/2008/09/591f7c4a8df9295d675a5adcb6802748.en.html
51  *)
52 module M = Ast.Meta.Make (Ast.Meta.MetaGhostLoc)
53 let lift_expr = M.Expr.meta_expr
54
55 (* Handle a top level statement. *)
56 let rec call_stmt name (_loc, stmt, sh) =
57   let name = if name <> "" then name else unique_job_name () in
58   let name = <:expr< $str:name$ >> in
59   match stmt with
60   | `When e -> when_stmt _loc name e sh
61   | `Every p -> every_stmt _loc name p sh
62
63 (* Handle a top level "when" statement.
64  * e -> when expression
65  * sh -> the shell script to run
66  * Returns a top level statement (str_item) which when executed just
67  * adds the statement to a global list.
68  *)
69 and when_stmt _loc name e sh =
70   let loc = expr_of_loc _loc _loc in
71   let e = lift_expr _loc e in
72   <:str_item<
73     open Camlp4.PreCast
74     Whenfile.add_when_job $loc$ $name$ $e$ $sh$
75   >>
76
77 (* Handle a top level "every" statement. *)
78 and every_stmt _loc name period sh =
79   let loc = expr_of_loc _loc _loc in
80   <:str_item<
81     open Camlp4.PreCast
82     Whenfile.add_every_job $loc$ $name$ $period$ $sh$
83   >>
84
85 let () =
86   (* Quotation expander for shell script. *)
87   let sh_quotation_expander _loc _ sh =
88     let loc = expr_of_loc _loc _loc in
89
90     (* XXX Expand %- or $- expressions in code. *)
91     (* XXX Escape >> in code. *)
92
93     <:expr< { Whenutils.sh_loc = $loc$;
94               sh_script = $str:sh$ } >>
95   in
96   Quotation.add "sh" Quotation.DynAst.expr_tag sh_quotation_expander;
97
98   (* Default quotation expander (<< .. >>) should be shell script ("sh"). *)
99   Quotation.default := "sh"
100
101 (* For period expressions "<NN> (secs|mins|hours|...)" we cannot use
102  * the ordinary camlp4 parser since it only looks ahead by 1 symbol, so
103  * it gets "stuck" on the integer.  Write a custom parser instead.
104  *
105  * Note the EXTEND macro implicitly reserves KEYWORDs.
106  *)
107 let period_parser =
108   Gram.Entry.of_parser "period"
109     (fun stream ->
110       match Stream.peek stream with
111       | Some (INT (_, i), info) ->
112         let i = int_of_string i in
113         let _loc = Gram.token_location info in
114         Stream.junk stream;
115         (match Stream.next stream with
116         | KEYWORD ("sec"|"secs"|"second"|"seconds"), _ ->
117           <:expr< Whenutils.Every_seconds $`int:i$ >>
118         | KEYWORD ("min"|"mins"|"minute"|"minutes"), _ ->
119           let i = 60 * i in
120           <:expr< Whenutils.Every_seconds $`int:i$ >>
121         | KEYWORD ("hour"|"hours"), _ ->
122           let i = 3600 * i in
123           <:expr< Whenutils.Every_seconds $`int:i$ >>
124         | KEYWORD ("day"|"days"), _ ->
125           <:expr< Whenutils.Every_days $`int:i$ >>
126         | KEYWORD ("week"|"weeks"), _ ->
127           let i = 7 * i in
128           <:expr< Whenutils.Every_days $`int:i$ >>
129         | KEYWORD ("month"|"months"), _ ->
130           <:expr< Whenutils.Every_months $`int:i$ >>
131         | KEYWORD ("year"|"years"), _ ->
132           <:expr< Whenutils.Every_years $`int:i$ >>
133         | KEYWORD ("decade"|"decades"), _ ->
134           let i = 10 * i in
135           <:expr< Whenutils.Every_years $`int:i$ >>
136         | KEYWORD ("century"|"centuries"|"centurys"), _ ->
137           let i = 100 * i in
138           <:expr< Whenutils.Every_years $`int:i$ >>
139         | KEYWORD ("millenium"|"millenia"|"milleniums"), _ ->
140           let i = 1000 * i in
141           <:expr< Whenutils.Every_years $`int:i$ >>
142         | (KEYWORD s | LIDENT s), _ ->
143           eprintf "period: failed to parse %d %s\n%!" i s;
144           raise Stream.Failure
145         | _ ->
146           raise Stream.Failure
147         )
148       | _ -> raise Stream.Failure
149     )
150
151 (*
152 (* This hand-written parser looks for "job <name>" before a statement. *)
153 let optjob =
154   Gram.Entry.of_parser "optjob"
155     (fun stream ->
156       let info, name =
157         match Stream.npeek 2 stream with
158         | [ LIDENT "job", info; STRING (_,name), _ ] ->
159           Stream.junk stream;
160           Stream.junk stream;
161           info, name
162         | (_, info) :: _ ->
163           (* Job is unnamed so generate a unique internal name. *)
164           info, unique_job_name ()
165         | _ -> assert false in
166       let _loc = Gram.token_location info in
167       <:expr< $str:name$ >>
168     )
169 *)
170 ;;
171
172 EXTEND Gram
173   GLOBAL: str_item;
174
175   (* A period expression (used in "every"). *)
176   periodexpr: [
177     [ ["sec"|"secs"|"second"|"seconds"] ->
178       <:expr< Whenutils.Every_seconds 1 >> ]
179   | [ ["min"|"mins"|"minute"|"minutes"] ->
180       <:expr< Whenutils.Every_seconds 60 >> ]
181   | [ ["hour"|"hours"] -> <:expr< Whenutils.Every_seconds 3600 >> ]
182   | [ ["day"|"days"] -> <:expr< Whenutils.Every_days 1 >> ]
183   | [ ["week"|"weeks"] -> <:expr< Whenutils.Every_days 7 >> ]
184   | [ ["month"|"months"] -> <:expr< Whenutils.Every_months 1 >> ]
185   | [ ["year"|"years"] -> <:expr< Whenutils.Every_years 1 >> ]
186   | [ ["decade"|"decades"] -> <:expr< Whenutils.Every_years 10 >> ]
187   | [ ["century"|"centuries"|"centurys"] ->
188       <:expr< Whenutils.Every_years 100 >> ]
189   | [ ["millenium"|"millenia"|"milleniums"] ->
190       <:expr< Whenutils.Every_years 1000 >> ]
191   | [ e = period_parser -> e ]
192   ];
193
194   (* Top level statements. *)
195   statement: [
196     [ "when"; e = expr; ":"; sh = expr ->
197       (_loc, `When e, sh) ]
198   | [ "every"; p = periodexpr; ":"; sh = expr ->
199       (_loc, `Every p, sh) ]
200   ];
201
202   (* "str_item" is a top level statement in an OCaml program. *)
203   str_item: LEVEL "top" [
204     [ s = statement -> call_stmt "" s ]
205   | [ "job"; name = STRING; s = statement -> call_stmt name s ]
206   ];
207
208 END