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 open Whenutils
  33
  34 let unique = let i = ref 0 in fun () -> incr i; !i
  35
  36 let unique_job_name () = sprintf "job$%d" (unique ())
  37
  38 (* Convert a _loc to an AST. *)
  39 let expr_of_loc _loc loc =
  40   let file_name,
  41     start_line, start_bol, start_off,
  42     stop_line, stop_bol, stop_off,
  43     ghost = Loc.to_tuple loc in
  44   <:expr< Camlp4.PreCast.Loc.of_tuple
  45     ($str:file_name$,
  46      $`int:start_line$, $`int:start_bol$, $`int:start_off$,
  47      $`int:stop_line$, $`int:stop_bol$, $`int:stop_off$,
  48      $`bool:ghost$) >>
  49
  50 (* "Lift" an expression, turning it from an expression into an OCaml
  51  * abstract syntax tree in the output.  This is pretty obscure.
  52  * http://caml.inria.fr/pub/ml-archives/caml-list/2008/09/591f7c4a8df9295d675a5adcb6802748.en.html
  53  *)
  54 module M = Ast.Meta.Make (Ast.Meta.MetaGhostLoc)
  55 let lift_expr = M.Expr.meta_expr
  56
  57 (* Handle a top level statement. *)
  58 let rec call_stmt name (_loc, stmt, sh) =
  59   let name = if name <> "" then name else unique_job_name () in
  60   let name = <:expr< $str:name$ >> in
  61   match stmt with
  62   | `When e -> when_stmt _loc name e sh
  63   | `Every p -> every_stmt _loc name p sh
  64
  65 (* Handle a top level "when" statement.
  66  * e -> when expression
  67  * sh -> the shell script to run
  68  * Returns a top level statement (str_item) which when executed just
  69  * adds the statement to a global list.
  70  *)
  71 and when_stmt _loc name e sh =
  72   let loc = expr_of_loc _loc _loc in
  73   let e = lift_expr _loc e in
  74   <:str_item<
  75     open Camlp4.PreCast
  76     Whenfile.add_when_job $loc$ $name$ $e$ $sh$
  77   >>
  78
  79 (* Handle a top level "every" statement. *)
  80 and every_stmt _loc name period sh =
  81   let loc = expr_of_loc _loc _loc in
  82   <:str_item<
  83     open Camlp4.PreCast
  84     Whenfile.add_every_job $loc$ $name$ $period$ $sh$
  85   >>
  86
  87 let () =
  88   (* Quotation expander for shell script. *)
  89   let sh_quotation_expander _loc _ sh =
  90     let loc = expr_of_loc _loc _loc in
  91
  92     (* XXX Expand %- or $- expressions in code. *)
  93     (* XXX Escape >> in code. *)
  94
  95     <:expr< { Whenutils.sh_loc = $loc$;
  96               sh_script = $str:sh$ } >>
  97   in
  98   Quotation.add "sh" Quotation.DynAst.expr_tag sh_quotation_expander;
  99
 100   (* Default quotation expander (<< .. >>) should be shell script ("sh"). *)
 101   Quotation.default := "sh"
 102
 103 (* For period expressions "<NN> (secs|mins|hours|...)" we cannot use
 104  * the ordinary camlp4 parser since it only looks ahead by 1 symbol, so
 105  * it gets "stuck" on the integer.  Write a custom parser instead.
 106  *
 107  * Note the EXTEND macro implicitly reserves KEYWORDs.
 108  *)
 109 let period_parser =
 110   Gram.Entry.of_parser "period"
 111     (fun stream ->
 112       match Stream.peek stream with
 113       | Some (INT (_, i), info) ->
 114         let i = int_of_string i in
 115         let _loc = Gram.token_location info in
 116         Stream.junk stream;
 117         (match Stream.next stream with
 118         | KEYWORD ("sec"|"secs"|"second"|"seconds"), _ ->
 119           <:expr< Whenutils.Every_seconds $`int:i$ >>
 120         | KEYWORD ("min"|"mins"|"minute"|"minutes"), _ ->
 121           let i = 60 * i in
 122           <:expr< Whenutils.Every_seconds $`int:i$ >>
 123         | KEYWORD ("hour"|"hours"), _ ->
 124           let i = 3600 * i in
 125           <:expr< Whenutils.Every_seconds $`int:i$ >>
 126         | KEYWORD ("day"|"days"), _ ->
 127           <:expr< Whenutils.Every_days $`int:i$ >>
 128         | KEYWORD ("week"|"weeks"), _ ->
 129           let i = 7 * i in
 130           <:expr< Whenutils.Every_days $`int:i$ >>
 131         | KEYWORD ("month"|"months"), _ ->
 132           <:expr< Whenutils.Every_months $`int:i$ >>
 133         | KEYWORD ("year"|"years"), _ ->
 134           <:expr< Whenutils.Every_years $`int:i$ >>
 135         | KEYWORD ("decade"|"decades"), _ ->
 136           let i = 10 * i in
 137           <:expr< Whenutils.Every_years $`int:i$ >>
 138         | KEYWORD ("century"|"centuries"|"centurys"), _ ->
 139           let i = 100 * i in
 140           <:expr< Whenutils.Every_years $`int:i$ >>
 141         | KEYWORD ("millenium"|"millenia"|"milleniums"), _ ->
 142           let i = 1000 * i in
 143           <:expr< Whenutils.Every_years $`int:i$ >>
 144         | (KEYWORD s | LIDENT s), _ ->
 145           eprintf "period: failed to parse %d %s\n%!" i s;
 146           raise Stream.Failure
 147         | _ ->
 148           raise Stream.Failure
 149         )
 150       | _ -> raise Stream.Failure
 151     )
 152
 153 (*
 154 (* This hand-written parser looks for "job <name>" before a statement. *)
 155 let optjob =
 156   Gram.Entry.of_parser "optjob"
 157     (fun stream ->
 158       let info, name =
 159         match Stream.npeek 2 stream with
 160         | [ LIDENT "job", info; STRING (_,name), _ ] ->
 161           Stream.junk stream;
 162           Stream.junk stream;
 163           info, name
 164         | (_, info) :: _ ->
 165           (* Job is unnamed so generate a unique internal name. *)
 166           info, unique_job_name ()
 167         | _ -> assert false in
 168       let _loc = Gram.token_location info in
 169       <:expr< $str:name$ >>
 170     )
 171 *)
 172 ;;
 173
 174 EXTEND Gram
 175   GLOBAL: str_item;
 176
 177   (* A period expression (used in "every"). *)
 178   periodexpr: [
 179     [ ["sec"|"secs"|"second"|"seconds"] ->
 180       <:expr< Whenutils.Every_seconds 1 >> ]
 181   | [ ["min"|"mins"|"minute"|"minutes"] ->
 182       <:expr< Whenutils.Every_seconds 60 >> ]
 183   | [ ["hour"|"hours"] -> <:expr< Whenutils.Every_seconds 3600 >> ]
 184   | [ ["day"|"days"] -> <:expr< Whenutils.Every_days 1 >> ]
 185   | [ ["week"|"weeks"] -> <:expr< Whenutils.Every_days 7 >> ]
 186   | [ ["month"|"months"] -> <:expr< Whenutils.Every_months 1 >> ]
 187   | [ ["year"|"years"] -> <:expr< Whenutils.Every_years 1 >> ]
 188   | [ ["decade"|"decades"] -> <:expr< Whenutils.Every_years 10 >> ]
 189   | [ ["century"|"centuries"|"centurys"] ->
 190       <:expr< Whenutils.Every_years 100 >> ]
 191   | [ ["millenium"|"millenia"|"milleniums"] ->
 192       <:expr< Whenutils.Every_years 1000 >> ]
 193   | [ e = period_parser -> e ]
 194   ];
 195
 196   (* Top level statements. *)
 197   statement: [
 198     [ "when"; e = expr; ":"; sh = expr ->
 199       (_loc, `When e, sh) ]
 200   | [ "every"; p = periodexpr; ":"; sh = expr ->
 201       (_loc, `Every p, sh) ]
 202   ];
 203
 204   (* "str_item" is a top level statement in an OCaml program. *)
 205   str_item: LEVEL "top" [
 206     [ s = statement -> call_stmt "" s ]
 207   | [ "job"; name = STRING; s = statement -> call_stmt name s ]
 208   ];
 209
 210 END