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