Split large 'Whenutils' module into two (creating new module 'Whenexpr').
authorRichard W.M. Jones <rjones@redhat.com>
Thu, 23 Feb 2012 11:24:14 +0000 (11:24 +0000)
committerRichard W.M. Jones <rjones@redhat.com>
Thu, 23 Feb 2012 13:27:14 +0000 (13:27 +0000)
daemon/daemon.ml
lib/Makefile.am
lib/pa_when.ml
lib/whenexpr.ml [new file with mode: 0644]
lib/whenexpr.mli [new file with mode: 0644]
lib/whenfile.ml
lib/whenfile.mli
lib/whenutils.ml
lib/whenutils.mli

index b38481c..af2668f 100644 (file)
@@ -17,6 +17,7 @@
  *)
 
 open Whenutils
+open Whenexpr
 
 open Big_int
 open Unix
index 1421da3..967cfd0 100644 (file)
@@ -29,6 +29,8 @@ OCAMLOPTFLAGS = $(OCAMLCFLAGS)
 SOURCES = \
        config.ml \
        config.mli \
+       whenexpr.ml \
+       whenexpr.mli \
        whenfile.ml \
        whenfile.mli \
        whenlock.ml \
@@ -38,8 +40,10 @@ SOURCES = \
        whenutils.mli \
        whenutils.ml
 
+# In alphabetical order.
 CMI_FILES = \
        config.cmi \
+       whenexpr.cmi
        whenfile.cmi \
        whenlock.cmi \
        whenproto_aux.cmi \
@@ -50,6 +54,7 @@ OBJECTS = \
        config.cmo \
        whenproto_aux.cmo \
        whenutils.cmo \
+       whenexpr.cmo \
        whenfile.cmo \
        whenlock.cmo
 
index 0d16469..da51e20 100644 (file)
@@ -120,7 +120,7 @@ let () =
     (* Convert ">\>" to ">>" in code. *)
     let sh = replace_str sh ">\\>" ">>" in
 
-    <:expr< { Whenutils.sh_loc = $loc$;
+    <:expr< { Whenexpr.sh_loc = $loc$;
               sh_script = $str:sh$ } >>
   in
   Quotation.add "sh" Quotation.DynAst.expr_tag sh_quotation_expander;
@@ -144,31 +144,31 @@ let period_parser =
         Stream.junk stream;
         (match Stream.next stream with
         | KEYWORD ("sec"|"secs"|"second"|"seconds"), _ ->
-          <:expr< Whenutils.Every_seconds $`int:i$ >>
+          <:expr< Whenexpr.Every_seconds $`int:i$ >>
         | KEYWORD ("min"|"mins"|"minute"|"minutes"), _ ->
           let i = 60 * i in
-          <:expr< Whenutils.Every_seconds $`int:i$ >>
+          <:expr< Whenexpr.Every_seconds $`int:i$ >>
         | KEYWORD ("hour"|"hours"), _ ->
           let i = 3600 * i in
-          <:expr< Whenutils.Every_seconds $`int:i$ >>
+          <:expr< Whenexpr.Every_seconds $`int:i$ >>
         | KEYWORD ("day"|"days"), _ ->
-          <:expr< Whenutils.Every_days $`int:i$ >>
+          <:expr< Whenexpr.Every_days $`int:i$ >>
         | KEYWORD ("week"|"weeks"), _ ->
           let i = 7 * i in
-          <:expr< Whenutils.Every_days $`int:i$ >>
+          <:expr< Whenexpr.Every_days $`int:i$ >>
         | KEYWORD ("month"|"months"), _ ->
-          <:expr< Whenutils.Every_months $`int:i$ >>
+          <:expr< Whenexpr.Every_months $`int:i$ >>
         | KEYWORD ("year"|"years"), _ ->
-          <:expr< Whenutils.Every_years $`int:i$ >>
+          <:expr< Whenexpr.Every_years $`int:i$ >>
         | KEYWORD ("decade"|"decades"), _ ->
           let i = 10 * i in
-          <:expr< Whenutils.Every_years $`int:i$ >>
+          <:expr< Whenexpr.Every_years $`int:i$ >>
         | KEYWORD ("century"|"centuries"|"centurys"), _ ->
           let i = 100 * i in
-          <:expr< Whenutils.Every_years $`int:i$ >>
+          <:expr< Whenexpr.Every_years $`int:i$ >>
         | KEYWORD ("millenium"|"millenia"|"milleniums"), _ ->
           let i = 1000 * i in
-          <:expr< Whenutils.Every_years $`int:i$ >>
+          <:expr< Whenexpr.Every_years $`int:i$ >>
         | (KEYWORD s | LIDENT s), _ ->
           eprintf "period: failed to parse %d %s\n%!" i s;
           raise Stream.Failure
@@ -205,19 +205,19 @@ EXTEND Gram
   (* A period expression (used in "every"). *)
   periodexpr: [
     [ ["sec"|"secs"|"second"|"seconds"] ->
-      <:expr< Whenutils.Every_seconds 1 >> ]
+      <:expr< Whenexpr.Every_seconds 1 >> ]
   | [ ["min"|"mins"|"minute"|"minutes"] ->
-      <:expr< Whenutils.Every_seconds 60 >> ]
-  | [ ["hour"|"hours"] -> <:expr< Whenutils.Every_seconds 3600 >> ]
-  | [ ["day"|"days"] -> <:expr< Whenutils.Every_days 1 >> ]
-  | [ ["week"|"weeks"] -> <:expr< Whenutils.Every_days 7 >> ]
-  | [ ["month"|"months"] -> <:expr< Whenutils.Every_months 1 >> ]
-  | [ ["year"|"years"] -> <:expr< Whenutils.Every_years 1 >> ]
-  | [ ["decade"|"decades"] -> <:expr< Whenutils.Every_years 10 >> ]
+      <:expr< Whenexpr.Every_seconds 60 >> ]
+  | [ ["hour"|"hours"] -> <:expr< Whenexpr.Every_seconds 3600 >> ]
+  | [ ["day"|"days"] -> <:expr< Whenexpr.Every_days 1 >> ]
+  | [ ["week"|"weeks"] -> <:expr< Whenexpr.Every_days 7 >> ]
+  | [ ["month"|"months"] -> <:expr< Whenexpr.Every_months 1 >> ]
+  | [ ["year"|"years"] -> <:expr< Whenexpr.Every_years 1 >> ]
+  | [ ["decade"|"decades"] -> <:expr< Whenexpr.Every_years 10 >> ]
   | [ ["century"|"centuries"|"centurys"] ->
-      <:expr< Whenutils.Every_years 100 >> ]
+      <:expr< Whenexpr.Every_years 100 >> ]
   | [ ["millenium"|"millenia"|"milleniums"] ->
-      <:expr< Whenutils.Every_years 1000 >> ]
+      <:expr< Whenexpr.Every_years 1000 >> ]
   | [ e = period_parser -> e ]
   ];
 
diff --git a/lib/whenexpr.ml b/lib/whenexpr.ml
new file mode 100644 (file)
index 0000000..5b4bbdd
--- /dev/null
@@ -0,0 +1,662 @@
+(* whenjobs
+ * Copyright (C) 2012 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Camlp4.PreCast
+open Ast
+
+open CalendarLib
+
+open Whenutils
+
+open Big_int
+open Unix
+open Printf
+
+type whenexpr =
+  | Expr_unit
+  | Expr_bool of bool
+  | Expr_str of string
+  | Expr_int of Big_int.big_int
+  | Expr_float of float
+  | Expr_var of string
+  | Expr_and of whenexpr * whenexpr
+  | Expr_or of whenexpr * whenexpr
+  | Expr_lt of whenexpr * whenexpr
+  | Expr_le of whenexpr * whenexpr
+  | Expr_eq of whenexpr * whenexpr
+  | Expr_ge of whenexpr * whenexpr
+  | Expr_gt of whenexpr * whenexpr
+  | Expr_not of whenexpr
+  | Expr_add of whenexpr * whenexpr
+  | Expr_sub of whenexpr * whenexpr
+  | Expr_mul of whenexpr * whenexpr
+  | Expr_div of whenexpr * whenexpr
+  | Expr_mod of whenexpr * whenexpr
+  | Expr_changes of string
+  | Expr_increases of string
+  | Expr_decreases of string
+  | Expr_prev of string
+  | Expr_reloaded
+
+(* This internal type is used during conversion of the OCaml AST
+ * to the whenexpr type.
+ *)
+type whenexpr_int =
+  | IExpr_unit
+  | IExpr_bool of bool
+  | IExpr_str of string
+  | IExpr_int of Big_int.big_int
+  | IExpr_float of float
+  | IExpr_var of string
+  | IExpr_app of string * whenexpr_int list
+
+(* Note that days are not necessarily expressible in seconds (because
+ * of leap seconds), months are not expressible in days (because months
+ * have different lengths), and years are not expressible in days
+ * (because of leap days) although we could save a case here by
+ * expressing years in months.
+ *)
+type periodexpr =
+  | Every_seconds of int
+  | Every_days of int
+  | Every_months of int
+  | Every_years of int
+
+type shell_script = {
+  sh_loc : Loc.t;
+  sh_script : string;
+}
+
+type variable =
+  | T_unit
+  | T_bool of bool
+  | T_string of string
+  | T_int of big_int
+  | T_float of float
+
+let variable_of_rpc = function
+  | `unit_t -> T_unit
+  | `bool_t b -> T_bool b
+  | `string_t s -> T_string s
+  | `int_t i -> T_int (big_int_of_string i)
+  | `float_t f -> T_float f
+
+let rpc_of_variable = function
+  | T_unit -> `unit_t
+  | T_bool b -> `bool_t b
+  | T_string s -> `string_t s
+  | T_int i -> `int_t (string_of_big_int i)
+  | T_float f -> `float_t f
+
+type variables = variable StringMap.t
+
+type job_private = {
+  (* The result of the previous evaluation.  This is used for
+   * implementing edge-triggering, since we only trigger the job to run
+   * when the state changes from false -> true.
+   *
+   * [None] means there has been no previous evaluation.
+   *)
+  job_prev_eval_state : bool option;
+
+  (* When the job {i ran} last time, we take a copy of the variables.
+   * This allows us to implement the 'changes' operator.
+   *
+   * [None] means there has been no previous run.
+   *)
+  job_prev_variables : variables option;
+}
+
+type job_cond =
+  | When_job of whenexpr
+  | Every_job of periodexpr
+
+type job = {
+  job_loc : Loc.t;
+  job_name : string;
+  job_cond : job_cond;
+  job_script : shell_script;
+  job_private : job_private;
+}
+
+let make_when_job _loc name e sh =
+  { job_loc = _loc; job_name = name;
+    job_cond = When_job e; job_script = sh;
+    job_private = { job_prev_eval_state = None;
+                    job_prev_variables = None } }
+
+let make_every_job _loc name e sh =
+  { job_loc = _loc; job_name = name;
+    job_cond = Every_job e; job_script = sh;
+    job_private = { job_prev_eval_state = None;
+                    job_prev_variables = None } }
+
+let rec expr_of_ast _loc ast =
+  expr_of_iexpr _loc (iexpr_of_ast _loc ast)
+
+and iexpr_of_ast _loc = function
+  | ExId (_, IdUid (_, "()")) -> IExpr_unit
+  | ExId (_, IdUid (_, "True")) -> IExpr_bool true
+  | ExId (_, IdUid (_, "False")) -> IExpr_bool false
+  | ExStr (_, str) -> IExpr_str str
+  | ExInt (_, i) -> IExpr_int (big_int_of_string i) (* XXX too large? *)
+  | ExFlo (_, f) -> IExpr_float (float_of_string f)
+  | ExId (_, IdLid (_, id)) -> IExpr_var id
+
+  (* In the OCaml AST, functions are curried right to left, so we
+   * must uncurry to get the list of arguments.
+   *)
+  | ExApp (_, left_tree, right_arg) ->
+    let f, left_args = uncurry_app_tree _loc left_tree in
+    IExpr_app (f, List.rev_map (iexpr_of_ast _loc) (right_arg :: left_args))
+
+  | e ->
+    (* https://groups.google.com/group/fa.caml/browse_thread/thread/f35452d085654bd6 *)
+    eprintf "expr_of_ast: invalid expression: %!";
+    let e = Ast.StExp (_loc, e) in
+    Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
+
+    invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
+
+and uncurry_app_tree _loc = function
+  | ExId (_, IdLid (_, f)) -> f, []
+  | ExApp (_, left_tree, right_arg) ->
+    let f, left_args = uncurry_app_tree _loc left_tree in
+    f, (right_arg :: left_args)
+  | e ->
+    eprintf "uncurry_app_tree: invalid expression: %!";
+    let e = Ast.StExp (_loc, e) in
+    Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
+
+    invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
+
+and expr_of_iexpr _loc = function
+  | IExpr_unit -> Expr_unit
+  | IExpr_bool b -> Expr_bool b
+  | IExpr_str s -> Expr_str s
+  | IExpr_int i -> Expr_int i
+  | IExpr_float f -> Expr_float f
+  | IExpr_var v -> Expr_var v
+
+  | IExpr_app ("&&", exprs) ->
+    two_params _loc "&&" exprs (fun e1 e2 -> Expr_and (e1, e2))
+
+  | IExpr_app ("||", exprs) ->
+    two_params _loc "||" exprs (fun e1 e2 -> Expr_or (e1, e2))
+
+  | IExpr_app ("<", exprs) ->
+    two_params _loc "<" exprs (fun e1 e2 -> Expr_lt (e1, e2))
+
+  | IExpr_app ("<=", exprs) ->
+    two_params _loc "<=" exprs (fun e1 e2 -> Expr_le (e1, e2))
+
+  | IExpr_app (("="|"=="), exprs) ->
+    two_params _loc "=" exprs (fun e1 e2 -> Expr_eq (e1, e2))
+
+  | IExpr_app (">=", exprs) ->
+    two_params _loc ">=" exprs (fun e1 e2 -> Expr_ge (e1, e2))
+
+  | IExpr_app (">", exprs) ->
+    two_params _loc ">" exprs (fun e1 e2 -> Expr_gt (e1, e2))
+
+  | IExpr_app ("!", exprs) ->
+    one_param _loc "!" exprs (fun e1 -> Expr_not e1)
+
+  | IExpr_app ("+", exprs) ->
+    two_params _loc "+" exprs (fun e1 e2 -> Expr_add (e1, e2))
+
+  | IExpr_app ("-", exprs) ->
+    two_params _loc "+" exprs (fun e1 e2 -> Expr_sub (e1, e2))
+
+  | IExpr_app ("*", exprs) ->
+    two_params _loc "+" exprs (fun e1 e2 -> Expr_mul (e1, e2))
+
+  | IExpr_app ("/", exprs) ->
+    two_params _loc "+" exprs (fun e1 e2 -> Expr_div (e1, e2))
+
+  | IExpr_app ("mod", exprs) ->
+    two_params _loc "+" exprs (fun e1 e2 -> Expr_mod (e1, e2))
+
+  | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
+    Expr_changes v
+
+  | IExpr_app (("inc"|"increase"|"increases"|"increased"), [IExpr_var v]) ->
+    Expr_increases v
+
+  | IExpr_app (("dec"|"decrease"|"decreases"|"decreased"), [IExpr_var v]) ->
+    Expr_decreases v
+
+  | IExpr_app (("prev"|"previous"), [IExpr_var v]) ->
+    Expr_prev v
+
+  | IExpr_app (("change"|"changes"|"changed"|"inc"|"increase"|"increases"|"increased"|"dec"|"decrease"|"decreases"|"decreased"|"prev"|"previous") as op, _) ->
+    invalid_arg (sprintf "%s: '%s' operator must be followed by a variable name"
+                   (Loc.to_string _loc) op)
+
+  | IExpr_app ("reloaded", [IExpr_unit]) ->
+    Expr_reloaded
+
+  | IExpr_app ("reloaded", _) ->
+    invalid_arg (sprintf "%s: you must use 'reloaded ()'" (Loc.to_string _loc))
+
+  | IExpr_app (op, _) ->
+    invalid_arg (sprintf "%s: unknown operator in expression: %s"
+                   (Loc.to_string _loc) op)
+
+and two_params _loc op exprs f =
+  match exprs with
+  | [e1; e2] -> f (expr_of_iexpr _loc e1) (expr_of_iexpr _loc e2)
+  | _ ->
+    invalid_arg (sprintf "%s: %s operator must be applied to two parameters"
+                   op (Loc.to_string _loc))
+
+and one_param _loc op exprs f =
+  match exprs with
+  | [e1] -> f (expr_of_iexpr _loc e1)
+  | _ ->
+    invalid_arg (sprintf "%s: %s operator must be applied to one parameter"
+                   op (Loc.to_string _loc))
+
+let rec string_of_whenexpr = function
+  | Expr_unit -> "()"
+  | Expr_bool b -> sprintf "%b" b
+  | Expr_str s -> sprintf "%S" s
+  | Expr_int i -> sprintf "%s" (string_of_big_int i)
+  | Expr_float f -> sprintf "%f" f
+  | Expr_var v -> sprintf "%s" v
+  | Expr_and (e1, e2) ->
+    sprintf "%s && %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_or (e1, e2) ->
+    sprintf "%s || %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_lt (e1, e2) ->
+    sprintf "%s < %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_le (e1, e2) ->
+    sprintf "%s <= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_eq (e1, e2) ->
+    sprintf "%s == %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_ge (e1, e2) ->
+    sprintf "%s >= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_gt (e1, e2) ->
+    sprintf "%s > %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
+  | Expr_add (e1, e2) ->
+    sprintf "%s + %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_sub (e1, e2) ->
+    sprintf "%s - %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_mul (e1, e2) ->
+    sprintf "%s * %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_div (e1, e2) ->
+    sprintf "%s / %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_mod (e1, e2) ->
+    sprintf "%s mod %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
+  | Expr_changes v -> sprintf "changes %s" v
+  | Expr_increases v -> sprintf "increases %s" v
+  | Expr_decreases v -> sprintf "decreases %s" v
+  | Expr_prev v -> sprintf "prev %s" v
+  | Expr_reloaded -> "reloaded ()"
+
+let string_of_periodexpr = function
+  | Every_seconds 1 -> "1 second"
+  | Every_seconds i -> sprintf "%d seconds" i
+  | Every_days 1 -> "1 day"
+  | Every_days i -> sprintf "%d days" i
+  | Every_months 1 -> "1 month"
+  | Every_months i -> sprintf "%d months" i
+  | Every_years 1 -> "1 year"
+  | Every_years i -> sprintf "%d years" i
+
+let rec dependencies_of_whenexpr = function
+  | Expr_unit -> []
+  | Expr_bool _ -> []
+  | Expr_str _ -> []
+  | Expr_int _ -> []
+  | Expr_float _ -> []
+  | Expr_var v -> [v]
+  | Expr_and (e1, e2)
+  | Expr_or (e1, e2)
+  | Expr_lt (e1, e2)
+  | Expr_le (e1, e2)
+  | Expr_eq (e1, e2)
+  | Expr_ge (e1, e2)
+  | Expr_gt (e1, e2)
+  | Expr_add (e1, e2)
+  | Expr_sub (e1, e2)
+  | Expr_mul (e1, e2)
+  | Expr_div (e1, e2)
+  | Expr_mod (e1, e2) ->
+    dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
+  | Expr_not e ->
+    dependencies_of_whenexpr e
+  | Expr_changes v
+  | Expr_increases v
+  | Expr_decreases v
+  | Expr_prev v -> [v]
+  | Expr_reloaded -> []
+
+let dependencies_of_job = function
+  | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
+  | { job_cond = Every_job _ } -> []
+
+let rec eval_whenexpr job variables onload = function
+  | Expr_unit -> T_unit
+  | Expr_bool b -> T_bool b
+  | Expr_str s -> T_string s
+  | Expr_int i -> T_int i
+  | Expr_float f -> T_float f
+
+  | Expr_var v ->
+    get_variable variables v
+
+  | Expr_and (e1, e2) ->
+    if eval_whenexpr_as_bool job variables onload e1 &&
+       eval_whenexpr_as_bool job variables onload e2 then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_or (e1, e2) ->
+    if eval_whenexpr_as_bool job variables onload e1 ||
+       eval_whenexpr_as_bool job variables onload e2 then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_lt (e1, e2) ->
+    let e1 = eval_whenexpr job variables onload e1
+    and e2 = eval_whenexpr job variables onload e2 in
+    if compare_values e1 e2 < 0 then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_le (e1, e2) ->
+    let e1 = eval_whenexpr job variables onload e1
+    and e2 = eval_whenexpr job variables onload e2 in
+    if compare_values e1 e2 <= 0 then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_eq (e1, e2) ->
+    let e1 = eval_whenexpr job variables onload e1
+    and e2 = eval_whenexpr job variables onload e2 in
+    if compare_values e1 e2 = 0 then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_ge (e1, e2) ->
+    let e1 = eval_whenexpr job variables onload e1
+    and e2 = eval_whenexpr job variables onload e2 in
+    if compare_values e1 e2 >= 0 then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_gt (e1, e2) ->
+    let e1 = eval_whenexpr job variables onload e1
+    and e2 = eval_whenexpr job variables onload e2 in
+    if compare_values e1 e2 > 0 then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_not e ->
+    if not (eval_whenexpr_as_bool job variables onload e) then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_add (e1, e2) ->
+    let e1 = eval_whenexpr job variables onload e1
+    and e2 = eval_whenexpr job variables onload e2 in
+    add_values e1 e2
+
+  | Expr_sub (e1, e2) ->
+    let e1 = eval_whenexpr job variables onload e1
+    and e2 = eval_whenexpr job variables onload e2 in
+    sub_values e1 e2
+
+  | Expr_mul (e1, e2) ->
+    let e1 = eval_whenexpr job variables onload e1
+    and e2 = eval_whenexpr job variables onload e2 in
+    mul_values e1 e2
+
+  | Expr_div (e1, e2) ->
+    let e1 = eval_whenexpr job variables onload e1
+    and e2 = eval_whenexpr job variables onload e2 in
+    div_values e1 e2
+
+  | Expr_mod (e1, e2) ->
+    let e1 = eval_whenexpr job variables onload e1
+    and e2 = eval_whenexpr job variables onload e2 in
+    mod_values e1 e2
+
+  | Expr_changes v ->
+    let prev_value, curr_value = get_prev_curr_value job variables v in
+    if compare_values prev_value curr_value <> 0 then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_increases v ->
+    let prev_value, curr_value = get_prev_curr_value job variables v in
+    if compare_values prev_value curr_value < 0 then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_decreases v ->
+    let prev_value, curr_value = get_prev_curr_value job variables v in
+    if compare_values prev_value curr_value > 0 then
+      T_bool true
+    else
+      T_bool false
+
+  | Expr_prev v ->
+    get_prev_variable job v
+
+  | Expr_reloaded ->
+    T_bool onload
+
+and get_prev_curr_value job variables v =
+  let prev_value = get_prev_variable job v in
+  let curr_value = get_variable variables v in
+  prev_value, curr_value
+
+and get_variable variables v =
+  try StringMap.find v variables with Not_found -> T_string ""
+
+and get_prev_variable job v =
+  match job.job_private.job_prev_variables with
+  | None ->
+    (* Job has never run.  XXX Should do better here. *)
+    T_string ""
+  | Some prev_variables ->
+    get_variable prev_variables v
+
+(* Call {!eval_whenexpr} and cast the result to a boolean. *)
+and eval_whenexpr_as_bool job variables onload expr =
+  match eval_whenexpr job variables onload expr with
+  | T_unit -> false
+  | T_bool r -> r
+  | T_string s -> s <> ""
+  | T_int i -> sign_big_int i <> 0
+  | T_float f -> f <> 0.
+
+(* Do a comparison on two typed values and return -1/0/+1.  If the
+ * types are different then we compare the values as strings.  The user
+ * can avoid this by specifying types.
+ *)
+and compare_values value1 value2 =
+  match value1, value2 with
+  | T_bool b1, T_bool b2 -> compare b1 b2
+  | T_string s1, T_string s2 -> compare s1 s2
+  | T_int i1, T_int i2 -> compare_big_int i1 i2
+  | T_float f1, T_float f2 -> compare f1 f2
+    (* XXX BUG: int should be promoted to float in mixed numeric comparison *)
+  | _ ->
+    let value1 = string_of_variable value1
+    and value2 = string_of_variable value2 in
+    compare value1 value2
+
+(* + operator is addition or string concatenation. *)
+and add_values value1 value2 =
+  match value1, value2 with
+  | T_int i1, T_int i2 -> T_int (add_big_int i1 i2)
+  | T_float i1, T_float i2 -> T_float (i1 +. i2)
+  | T_int i1, T_float i2 -> T_float (float_of_big_int i1 +. i2)
+  | T_float i1, T_int i2 -> T_float (i1 +. float_of_big_int i2)
+  | T_string i1, T_string i2 -> T_string (i1 ^ i2)
+  | _ ->
+    invalid_arg
+      (sprintf "incompatible types in addition: %s + %s"
+         (printable_string_of_variable value1)
+         (printable_string_of_variable value2))
+
+and sub_values value1 value2 =
+  match value1, value2 with
+  | T_int i1, T_int i2 -> T_int (sub_big_int i1 i2)
+  | T_float i1, T_float i2 -> T_float (i1 -. i2)
+  | T_int i1, T_float i2 -> T_float (float_of_big_int i1 -. i2)
+  | T_float i1, T_int i2 -> T_float (i1 -. float_of_big_int i2)
+  | _ ->
+    invalid_arg
+      (sprintf "incompatible types in subtraction: %s - %s"
+         (printable_string_of_variable value1)
+         (printable_string_of_variable value2))
+
+and mul_values value1 value2 =
+  match value1, value2 with
+  | T_int i1, T_int i2 -> T_int (mult_big_int i1 i2)
+  | T_float i1, T_float i2 -> T_float (i1 *. i2)
+  | T_int i1, T_float i2 -> T_float (float_of_big_int i1 *. i2)
+  | T_float i1, T_int i2 -> T_float (i1 *. float_of_big_int i2)
+  | _ ->
+    invalid_arg
+      (sprintf "incompatible types in multiplication: %s * %s"
+         (printable_string_of_variable value1)
+         (printable_string_of_variable value2))
+
+and div_values value1 value2 =
+  match value1, value2 with
+  | T_int i1, T_int i2 -> T_int (div_big_int i1 i2)
+  | T_float i1, T_float i2 -> T_float (i1 /. i2)
+  | T_int i1, T_float i2 -> T_float (float_of_big_int i1 /. i2)
+  | T_float i1, T_int i2 -> T_float (i1 /. float_of_big_int i2)
+  | _ ->
+    invalid_arg
+      (sprintf "incompatible types in division: %s / %s"
+         (printable_string_of_variable value1)
+         (printable_string_of_variable value2))
+
+and mod_values value1 value2 =
+  match value1, value2 with
+  | T_int i1, T_int i2 -> T_int (mod_big_int i1 i2)
+  | T_float i1, T_float i2 -> T_float (mod_float i1 i2)
+  | T_int i1, T_float i2 -> T_float (mod_float (float_of_big_int i1) i2)
+  | T_float i1, T_int i2 -> T_float (mod_float i1 (float_of_big_int i2))
+  | _ ->
+    invalid_arg
+      (sprintf "incompatible types in modulo: %s mod %s"
+         (printable_string_of_variable value1)
+         (printable_string_of_variable value2))
+
+and string_of_variable = function
+  | T_unit -> "" (* for string_of_variable, we don't want () here *)
+  | T_bool b -> string_of_bool b
+  | T_string s -> s
+  | T_int i -> string_of_big_int i
+  | T_float f -> string_of_float f
+
+and printable_string_of_variable = function
+  | T_unit -> "()"
+  | T_bool b -> string_of_bool b
+  | T_string s -> sprintf "%S" s
+  | T_int i -> string_of_big_int i
+  | T_float f -> string_of_float f
+
+let job_evaluate job variables onload =
+  match job with
+  | { job_cond = Every_job _ } -> false, job
+  | { job_cond = When_job whenexpr } ->
+    let state = eval_whenexpr_as_bool job variables onload whenexpr in
+
+    (* Because jobs are edge-triggered, we're only interested in the
+     * case where the evaluation state changes from false -> true.
+     *)
+    match job.job_private.job_prev_eval_state, state with
+    | None, false
+    | Some false, false
+    | Some true, true
+    | Some true, false ->
+      let jobp = { job.job_private with job_prev_eval_state = Some state } in
+      let job = { job with job_private = jobp } in
+      false, job
+
+    | None, true
+    | Some false, true ->
+      let jobp = { job_prev_eval_state = Some true;
+                   job_prev_variables = Some variables } in
+      let job = { job with job_private = jobp } in
+      true, job
+
+let next_periodexpr =
+  (* Round up 'a' to the next multiple of 'i'. *)
+  let round_up_float a i =
+    let r = mod_float a i in
+    if r = 0. then a +. i else a +. (i -. r)
+  and round_up a i =
+    let r = a mod i in
+    if r = 0 then a + i else a + (i - r)
+  in
+
+  fun t -> function
+  | Every_seconds i ->
+    let i = float_of_int i in
+    round_up_float t i
+
+  | Every_years i ->
+    let tm = gmtime t in
+
+    (* Round 'tm' up to the first day of the next year. *)
+    let year = round_up tm.tm_year i in
+    let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
+                       tm_mday = 1; tm_mon = 0; tm_year = year } in
+    fst (mktime tm)
+
+  | Every_days i ->
+    let t = Date.from_unixfloat t in
+    let t0 = Date.make 1970 1 1 in
+
+    (* Number of whole days since Unix Epoch. *)
+    let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
+
+    let nb_days = round_up nb_days i in
+    let t' = Date.add t0 (Date.Period.day nb_days) in
+    Date.to_unixfloat t'
+
+  | Every_months i ->
+    (* Calculate number of whole months since Unix Epoch. *)
+    let tm = gmtime t in
+    let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
+
+    let months = round_up months i in
+    let t0 = Date.make 1970 1 1 in
+    let t' = Date.add t0 (Date.Period.month months) in
+    Date.to_unixfloat t'
diff --git a/lib/whenexpr.mli b/lib/whenexpr.mli
new file mode 100644 (file)
index 0000000..3c05826
--- /dev/null
@@ -0,0 +1,162 @@
+(* whenjobs
+ * Copyright (C) 2012 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(** When- and every-expression definition and evaluation, variables
+    and jobs. *)
+
+type whenexpr =
+  | Expr_unit                           (** Unit constant. *)
+  | Expr_bool of bool                   (** A boolean constant. *)
+  | Expr_str of string                  (** A string constant. *)
+  | Expr_int of Big_int.big_int         (** An integer constant. *)
+  | Expr_float of float                 (** A float constant. *)
+  | Expr_var of string                  (** A variable name. *)
+  | Expr_and of whenexpr * whenexpr     (** && *)
+  | Expr_or of whenexpr * whenexpr      (** || *)
+  | Expr_lt of whenexpr * whenexpr      (** < *)
+  | Expr_le of whenexpr * whenexpr      (** <= *)
+  | Expr_eq of whenexpr * whenexpr      (** == *)
+  | Expr_ge of whenexpr * whenexpr      (** >= *)
+  | Expr_gt of whenexpr * whenexpr      (** > *)
+  | Expr_not of whenexpr                (** boolean not *)
+  | Expr_add of whenexpr * whenexpr     (** arithmetic addition or string cat *)
+  | Expr_sub of whenexpr * whenexpr     (** arithmetic subtraction *)
+  | Expr_mul of whenexpr * whenexpr     (** arithmetic multiplication *)
+  | Expr_div of whenexpr * whenexpr     (** arithmetic division *)
+  | Expr_mod of whenexpr * whenexpr     (** arithmetic modulo *)
+  | Expr_changes of string              (** changes var *)
+  | Expr_increases of string            (** increases var *)
+  | Expr_decreases of string            (** decreases var *)
+  | Expr_prev of string                 (** prev var *)
+  | Expr_reloaded                       (** reloaded () *)
+(** Internal type used to represent 'when' expressions. *)
+
+type periodexpr =
+  | Every_seconds of int
+  | Every_days of int
+  | Every_months of int
+  | Every_years of int
+(** Internal type used to represent 'every' expressions. *)
+
+type shell_script = {
+  sh_loc : Camlp4.PreCast.Loc.t;
+  sh_script : string;
+}
+(** A shell script. *)
+
+type variable =
+  | T_unit
+  | T_bool of bool
+  | T_string of string
+  | T_int of Big_int.big_int
+  | T_float of float
+(** Typed variable (see also [whenproto.x]) *)
+
+val string_of_variable : variable -> string
+
+val variable_of_rpc : Whenproto_aux.variable -> variable
+val rpc_of_variable : variable -> Whenproto_aux.variable
+
+type variables = variable Whenutils.StringMap.t
+(** A set of variables. *)
+
+type job_private
+(** Private state associated with a job, used for evaluation. *)
+
+type job_cond =
+  | When_job of whenexpr                (** when ... : << >> *)
+  | Every_job of periodexpr             (** every ... : << >> *)
+
+type job = {
+  job_loc : Camlp4.PreCast.Loc.t;
+  job_name : string;
+  job_cond : job_cond;
+  job_script : shell_script;
+  job_private : job_private;
+}
+(** A job.  Note that because of the [job_private] field, these cannot
+    be constructed directly.  Use {!make_when_job} or {!make_every_job}
+    to construct one. *)
+
+val make_when_job : Camlp4.PreCast.Loc.t -> string -> whenexpr -> shell_script -> job
+(** Make a when-statement job. *)
+
+val make_every_job : Camlp4.PreCast.Loc.t -> string -> periodexpr -> shell_script -> job
+(** Make an every-statement job. *)
+
+val expr_of_ast : Camlp4.PreCast.Ast.Loc.t -> Camlp4.PreCast.Ast.expr -> whenexpr
+(** Convert OCaml AST to an expression.  Since OCaml ASTs are much
+    more general than the expressions we can use, this can raise
+    [Invalid_argument] in many different situations. *)
+
+val string_of_whenexpr : whenexpr -> string
+(** Pretty-print an expression to a string. *)
+
+val string_of_periodexpr : periodexpr -> string
+(** Pretty-print a period expression to a string. *)
+
+val dependencies_of_whenexpr : whenexpr -> string list
+(** Return list of variables that an expression depends on.  This is
+    used to work out when an expression needs to be reevaluated. *)
+
+val dependencies_of_job : job -> string list
+(** Which variables does this job depend on? *)
+
+val job_evaluate : job -> variables -> bool -> bool * job
+(** [job_evaluate job variables onload] evaluates [job]'s condition in
+    the context of the [variables], and return [true] iff it should be
+    run now.
+
+    Note that this returns a possibly-updated [job] structure.
+
+    This is a no-op for 'every' jobs. *)
+
+val next_periodexpr : float -> periodexpr -> float
+(** [next_periodexpr t period] returns the earliest event of [period]
+    strictly after time [t].
+
+    Visualising periods as repeated events on a timeline, this
+    returns [t']:
+
+    {v
+    events:  ---+---------+---------+---------+---------+---------+-----
+    times:          t     t'
+    }
+
+    Note that [periodexpr] events are not necessarily regular.
+    eg. The start of a month is not a fixed number of seconds
+    after the start of the previous month.  'Epoch' refers
+    to the Unix Epoch (ie. 1970-01-01 00:00:00 UTC).
+
+    If [period = Every_seconds i] then events are when
+    [t' mod i == 0] when t' is the number of seconds since
+    the Epoch.  This returns the next t' > t.
+
+    If [period = Every_days i] then events happen at
+    midnight UTC every [i] days since the Epoch.
+    This returns the next midnight > t.
+
+    If [period = Every_months i] then events happen at
+    midnight UTC on the 1st day of the month every [i] months
+    since the Epoch.  This returns midnight on the
+    1st day of the next month > t.
+
+    If [period = Every_years i] then events happen at
+    midnight UTC on the 1st day of the year when
+    [(y - 1970) mod i == 0].  This returns midnight on the
+    1st day of the next year > t. *)
index 89a09b0..5f205fb 100644 (file)
@@ -16,7 +16,7 @@
  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  *)
 
-open Whenutils
+open Whenexpr
 
 open Printf
 
index 345c758..b754cbc 100644 (file)
@@ -22,10 +22,10 @@ val init : unit -> unit
 (** "Initialize" the module.  Clear the list of jobs and other
     internal variables so we are ready to parse a new file. *)
 
-val get_jobs : unit -> Whenutils.job list
+val get_jobs : unit -> Whenexpr.job list
 (** Get the jobs added since {!init} was called. *)
 
-val add_when_job : Camlp4.PreCast.Loc.t -> string -> Camlp4.PreCast.Ast.expr -> Whenutils.shell_script -> unit
+val add_when_job : Camlp4.PreCast.Loc.t -> string -> Camlp4.PreCast.Ast.expr -> Whenexpr.shell_script -> unit
 (** When a 'when' macro appears as a toplevel statement in an
     input file, it causes this function to be called.
 
@@ -37,7 +37,7 @@ val add_when_job : Camlp4.PreCast.Loc.t -> string -> Camlp4.PreCast.Ast.expr ->
 
     [sh] is the shell script fragment (basically location + a big string). *)
 
-val add_every_job : Camlp4.PreCast.Loc.t -> string -> Whenutils.periodexpr -> Whenutils.shell_script -> unit
+val add_every_job : Camlp4.PreCast.Loc.t -> string -> Whenexpr.periodexpr -> Whenexpr.shell_script -> unit
 (** When an 'every' macro appears as a toplevel statement in an
     input file, it causes this function to be called.
 
index aa59f18..7d20f75 100644 (file)
@@ -50,637 +50,3 @@ let rec filter_map f = function
     match f x with
     | Some y -> y :: filter_map f xs
     | None -> filter_map f xs
-
-type whenexpr =
-  | Expr_unit
-  | Expr_bool of bool
-  | Expr_str of string
-  | Expr_int of Big_int.big_int
-  | Expr_float of float
-  | Expr_var of string
-  | Expr_and of whenexpr * whenexpr
-  | Expr_or of whenexpr * whenexpr
-  | Expr_lt of whenexpr * whenexpr
-  | Expr_le of whenexpr * whenexpr
-  | Expr_eq of whenexpr * whenexpr
-  | Expr_ge of whenexpr * whenexpr
-  | Expr_gt of whenexpr * whenexpr
-  | Expr_not of whenexpr
-  | Expr_add of whenexpr * whenexpr
-  | Expr_sub of whenexpr * whenexpr
-  | Expr_mul of whenexpr * whenexpr
-  | Expr_div of whenexpr * whenexpr
-  | Expr_mod of whenexpr * whenexpr
-  | Expr_changes of string
-  | Expr_increases of string
-  | Expr_decreases of string
-  | Expr_prev of string
-  | Expr_reloaded
-
-(* This internal type is used during conversion of the OCaml AST
- * to the whenexpr type.
- *)
-type whenexpr_int =
-  | IExpr_unit
-  | IExpr_bool of bool
-  | IExpr_str of string
-  | IExpr_int of Big_int.big_int
-  | IExpr_float of float
-  | IExpr_var of string
-  | IExpr_app of string * whenexpr_int list
-
-(* Note that days are not necessarily expressible in seconds (because
- * of leap seconds), months are not expressible in days (because months
- * have different lengths), and years are not expressible in days
- * (because of leap days) although we could save a case here by
- * expressing years in months.
- *)
-type periodexpr =
-  | Every_seconds of int
-  | Every_days of int
-  | Every_months of int
-  | Every_years of int
-
-type shell_script = {
-  sh_loc : Loc.t;
-  sh_script : string;
-}
-
-type variable =
-  | T_unit
-  | T_bool of bool
-  | T_string of string
-  | T_int of big_int
-  | T_float of float
-
-let variable_of_rpc = function
-  | `unit_t -> T_unit
-  | `bool_t b -> T_bool b
-  | `string_t s -> T_string s
-  | `int_t i -> T_int (big_int_of_string i)
-  | `float_t f -> T_float f
-
-let rpc_of_variable = function
-  | T_unit -> `unit_t
-  | T_bool b -> `bool_t b
-  | T_string s -> `string_t s
-  | T_int i -> `int_t (string_of_big_int i)
-  | T_float f -> `float_t f
-
-type variables = variable StringMap.t
-
-type job_private = {
-  (* The result of the previous evaluation.  This is used for
-   * implementing edge-triggering, since we only trigger the job to run
-   * when the state changes from false -> true.
-   *
-   * [None] means there has been no previous evaluation.
-   *)
-  job_prev_eval_state : bool option;
-
-  (* When the job {i ran} last time, we take a copy of the variables.
-   * This allows us to implement the 'changes' operator.
-   *
-   * [None] means there has been no previous run.
-   *)
-  job_prev_variables : variables option;
-}
-
-type job_cond =
-  | When_job of whenexpr
-  | Every_job of periodexpr
-
-type job = {
-  job_loc : Loc.t;
-  job_name : string;
-  job_cond : job_cond;
-  job_script : shell_script;
-  job_private : job_private;
-}
-
-let make_when_job _loc name e sh =
-  { job_loc = _loc; job_name = name;
-    job_cond = When_job e; job_script = sh;
-    job_private = { job_prev_eval_state = None;
-                    job_prev_variables = None } }
-
-let make_every_job _loc name e sh =
-  { job_loc = _loc; job_name = name;
-    job_cond = Every_job e; job_script = sh;
-    job_private = { job_prev_eval_state = None;
-                    job_prev_variables = None } }
-
-let rec expr_of_ast _loc ast =
-  expr_of_iexpr _loc (iexpr_of_ast _loc ast)
-
-and iexpr_of_ast _loc = function
-  | ExId (_, IdUid (_, "()")) -> IExpr_unit
-  | ExId (_, IdUid (_, "True")) -> IExpr_bool true
-  | ExId (_, IdUid (_, "False")) -> IExpr_bool false
-  | ExStr (_, str) -> IExpr_str str
-  | ExInt (_, i) -> IExpr_int (big_int_of_string i) (* XXX too large? *)
-  | ExFlo (_, f) -> IExpr_float (float_of_string f)
-  | ExId (_, IdLid (_, id)) -> IExpr_var id
-
-  (* In the OCaml AST, functions are curried right to left, so we
-   * must uncurry to get the list of arguments.
-   *)
-  | ExApp (_, left_tree, right_arg) ->
-    let f, left_args = uncurry_app_tree _loc left_tree in
-    IExpr_app (f, List.rev_map (iexpr_of_ast _loc) (right_arg :: left_args))
-
-  | e ->
-    (* https://groups.google.com/group/fa.caml/browse_thread/thread/f35452d085654bd6 *)
-    eprintf "expr_of_ast: invalid expression: %!";
-    let e = Ast.StExp (_loc, e) in
-    Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
-
-    invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
-
-and uncurry_app_tree _loc = function
-  | ExId (_, IdLid (_, f)) -> f, []
-  | ExApp (_, left_tree, right_arg) ->
-    let f, left_args = uncurry_app_tree _loc left_tree in
-    f, (right_arg :: left_args)
-  | e ->
-    eprintf "uncurry_app_tree: invalid expression: %!";
-    let e = Ast.StExp (_loc, e) in
-    Printers.OCaml.print_implem ~output_file:"/dev/stderr" e;
-
-    invalid_arg (sprintf "%s: invalid expression" (Loc.to_string _loc))
-
-and expr_of_iexpr _loc = function
-  | IExpr_unit -> Expr_unit
-  | IExpr_bool b -> Expr_bool b
-  | IExpr_str s -> Expr_str s
-  | IExpr_int i -> Expr_int i
-  | IExpr_float f -> Expr_float f
-  | IExpr_var v -> Expr_var v
-
-  | IExpr_app ("&&", exprs) ->
-    two_params _loc "&&" exprs (fun e1 e2 -> Expr_and (e1, e2))
-
-  | IExpr_app ("||", exprs) ->
-    two_params _loc "||" exprs (fun e1 e2 -> Expr_or (e1, e2))
-
-  | IExpr_app ("<", exprs) ->
-    two_params _loc "<" exprs (fun e1 e2 -> Expr_lt (e1, e2))
-
-  | IExpr_app ("<=", exprs) ->
-    two_params _loc "<=" exprs (fun e1 e2 -> Expr_le (e1, e2))
-
-  | IExpr_app (("="|"=="), exprs) ->
-    two_params _loc "=" exprs (fun e1 e2 -> Expr_eq (e1, e2))
-
-  | IExpr_app (">=", exprs) ->
-    two_params _loc ">=" exprs (fun e1 e2 -> Expr_ge (e1, e2))
-
-  | IExpr_app (">", exprs) ->
-    two_params _loc ">" exprs (fun e1 e2 -> Expr_gt (e1, e2))
-
-  | IExpr_app ("!", exprs) ->
-    one_param _loc "!" exprs (fun e1 -> Expr_not e1)
-
-  | IExpr_app ("+", exprs) ->
-    two_params _loc "+" exprs (fun e1 e2 -> Expr_add (e1, e2))
-
-  | IExpr_app ("-", exprs) ->
-    two_params _loc "+" exprs (fun e1 e2 -> Expr_sub (e1, e2))
-
-  | IExpr_app ("*", exprs) ->
-    two_params _loc "+" exprs (fun e1 e2 -> Expr_mul (e1, e2))
-
-  | IExpr_app ("/", exprs) ->
-    two_params _loc "+" exprs (fun e1 e2 -> Expr_div (e1, e2))
-
-  | IExpr_app ("mod", exprs) ->
-    two_params _loc "+" exprs (fun e1 e2 -> Expr_mod (e1, e2))
-
-  | IExpr_app (("change"|"changes"|"changed"), [IExpr_var v]) ->
-    Expr_changes v
-
-  | IExpr_app (("inc"|"increase"|"increases"|"increased"), [IExpr_var v]) ->
-    Expr_increases v
-
-  | IExpr_app (("dec"|"decrease"|"decreases"|"decreased"), [IExpr_var v]) ->
-    Expr_decreases v
-
-  | IExpr_app (("prev"|"previous"), [IExpr_var v]) ->
-    Expr_prev v
-
-  | IExpr_app (("change"|"changes"|"changed"|"inc"|"increase"|"increases"|"increased"|"dec"|"decrease"|"decreases"|"decreased"|"prev"|"previous") as op, _) ->
-    invalid_arg (sprintf "%s: '%s' operator must be followed by a variable name"
-                   (Loc.to_string _loc) op)
-
-  | IExpr_app ("reloaded", [IExpr_unit]) ->
-    Expr_reloaded
-
-  | IExpr_app ("reloaded", _) ->
-    invalid_arg (sprintf "%s: you must use 'reloaded ()'" (Loc.to_string _loc))
-
-  | IExpr_app (op, _) ->
-    invalid_arg (sprintf "%s: unknown operator in expression: %s"
-                   (Loc.to_string _loc) op)
-
-and two_params _loc op exprs f =
-  match exprs with
-  | [e1; e2] -> f (expr_of_iexpr _loc e1) (expr_of_iexpr _loc e2)
-  | _ ->
-    invalid_arg (sprintf "%s: %s operator must be applied to two parameters"
-                   op (Loc.to_string _loc))
-
-and one_param _loc op exprs f =
-  match exprs with
-  | [e1] -> f (expr_of_iexpr _loc e1)
-  | _ ->
-    invalid_arg (sprintf "%s: %s operator must be applied to one parameter"
-                   op (Loc.to_string _loc))
-
-let rec string_of_whenexpr = function
-  | Expr_unit -> "()"
-  | Expr_bool b -> sprintf "%b" b
-  | Expr_str s -> sprintf "%S" s
-  | Expr_int i -> sprintf "%s" (string_of_big_int i)
-  | Expr_float f -> sprintf "%f" f
-  | Expr_var v -> sprintf "%s" v
-  | Expr_and (e1, e2) ->
-    sprintf "%s && %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_or (e1, e2) ->
-    sprintf "%s || %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_lt (e1, e2) ->
-    sprintf "%s < %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_le (e1, e2) ->
-    sprintf "%s <= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_eq (e1, e2) ->
-    sprintf "%s == %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_ge (e1, e2) ->
-    sprintf "%s >= %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_gt (e1, e2) ->
-    sprintf "%s > %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_not e -> sprintf "! %s" (string_of_whenexpr e)
-  | Expr_add (e1, e2) ->
-    sprintf "%s + %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_sub (e1, e2) ->
-    sprintf "%s - %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_mul (e1, e2) ->
-    sprintf "%s * %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_div (e1, e2) ->
-    sprintf "%s / %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_mod (e1, e2) ->
-    sprintf "%s mod %s" (string_of_whenexpr e1) (string_of_whenexpr e2)
-  | Expr_changes v -> sprintf "changes %s" v
-  | Expr_increases v -> sprintf "increases %s" v
-  | Expr_decreases v -> sprintf "decreases %s" v
-  | Expr_prev v -> sprintf "prev %s" v
-  | Expr_reloaded -> "reloaded ()"
-
-let string_of_periodexpr = function
-  | Every_seconds 1 -> "1 second"
-  | Every_seconds i -> sprintf "%d seconds" i
-  | Every_days 1 -> "1 day"
-  | Every_days i -> sprintf "%d days" i
-  | Every_months 1 -> "1 month"
-  | Every_months i -> sprintf "%d months" i
-  | Every_years 1 -> "1 year"
-  | Every_years i -> sprintf "%d years" i
-
-let rec dependencies_of_whenexpr = function
-  | Expr_unit -> []
-  | Expr_bool _ -> []
-  | Expr_str _ -> []
-  | Expr_int _ -> []
-  | Expr_float _ -> []
-  | Expr_var v -> [v]
-  | Expr_and (e1, e2)
-  | Expr_or (e1, e2)
-  | Expr_lt (e1, e2)
-  | Expr_le (e1, e2)
-  | Expr_eq (e1, e2)
-  | Expr_ge (e1, e2)
-  | Expr_gt (e1, e2)
-  | Expr_add (e1, e2)
-  | Expr_sub (e1, e2)
-  | Expr_mul (e1, e2)
-  | Expr_div (e1, e2)
-  | Expr_mod (e1, e2) ->
-    dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
-  | Expr_not e ->
-    dependencies_of_whenexpr e
-  | Expr_changes v
-  | Expr_increases v
-  | Expr_decreases v
-  | Expr_prev v -> [v]
-  | Expr_reloaded -> []
-
-let dependencies_of_job = function
-  | { job_cond = When_job whenexpr } -> dependencies_of_whenexpr whenexpr
-  | { job_cond = Every_job _ } -> []
-
-let rec eval_whenexpr job variables onload = function
-  | Expr_unit -> T_unit
-  | Expr_bool b -> T_bool b
-  | Expr_str s -> T_string s
-  | Expr_int i -> T_int i
-  | Expr_float f -> T_float f
-
-  | Expr_var v ->
-    get_variable variables v
-
-  | Expr_and (e1, e2) ->
-    if eval_whenexpr_as_bool job variables onload e1 &&
-       eval_whenexpr_as_bool job variables onload e2 then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_or (e1, e2) ->
-    if eval_whenexpr_as_bool job variables onload e1 ||
-       eval_whenexpr_as_bool job variables onload e2 then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_lt (e1, e2) ->
-    let e1 = eval_whenexpr job variables onload e1
-    and e2 = eval_whenexpr job variables onload e2 in
-    if compare_values e1 e2 < 0 then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_le (e1, e2) ->
-    let e1 = eval_whenexpr job variables onload e1
-    and e2 = eval_whenexpr job variables onload e2 in
-    if compare_values e1 e2 <= 0 then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_eq (e1, e2) ->
-    let e1 = eval_whenexpr job variables onload e1
-    and e2 = eval_whenexpr job variables onload e2 in
-    if compare_values e1 e2 = 0 then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_ge (e1, e2) ->
-    let e1 = eval_whenexpr job variables onload e1
-    and e2 = eval_whenexpr job variables onload e2 in
-    if compare_values e1 e2 >= 0 then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_gt (e1, e2) ->
-    let e1 = eval_whenexpr job variables onload e1
-    and e2 = eval_whenexpr job variables onload e2 in
-    if compare_values e1 e2 > 0 then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_not e ->
-    if not (eval_whenexpr_as_bool job variables onload e) then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_add (e1, e2) ->
-    let e1 = eval_whenexpr job variables onload e1
-    and e2 = eval_whenexpr job variables onload e2 in
-    add_values e1 e2
-
-  | Expr_sub (e1, e2) ->
-    let e1 = eval_whenexpr job variables onload e1
-    and e2 = eval_whenexpr job variables onload e2 in
-    sub_values e1 e2
-
-  | Expr_mul (e1, e2) ->
-    let e1 = eval_whenexpr job variables onload e1
-    and e2 = eval_whenexpr job variables onload e2 in
-    mul_values e1 e2
-
-  | Expr_div (e1, e2) ->
-    let e1 = eval_whenexpr job variables onload e1
-    and e2 = eval_whenexpr job variables onload e2 in
-    div_values e1 e2
-
-  | Expr_mod (e1, e2) ->
-    let e1 = eval_whenexpr job variables onload e1
-    and e2 = eval_whenexpr job variables onload e2 in
-    mod_values e1 e2
-
-  | Expr_changes v ->
-    let prev_value, curr_value = get_prev_curr_value job variables v in
-    if compare_values prev_value curr_value <> 0 then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_increases v ->
-    let prev_value, curr_value = get_prev_curr_value job variables v in
-    if compare_values prev_value curr_value < 0 then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_decreases v ->
-    let prev_value, curr_value = get_prev_curr_value job variables v in
-    if compare_values prev_value curr_value > 0 then
-      T_bool true
-    else
-      T_bool false
-
-  | Expr_prev v ->
-    get_prev_variable job v
-
-  | Expr_reloaded ->
-    T_bool onload
-
-and get_prev_curr_value job variables v =
-  let prev_value = get_prev_variable job v in
-  let curr_value = get_variable variables v in
-  prev_value, curr_value
-
-and get_variable variables v =
-  try StringMap.find v variables with Not_found -> T_string ""
-
-and get_prev_variable job v =
-  match job.job_private.job_prev_variables with
-  | None ->
-    (* Job has never run.  XXX Should do better here. *)
-    T_string ""
-  | Some prev_variables ->
-    get_variable prev_variables v
-
-(* Call {!eval_whenexpr} and cast the result to a boolean. *)
-and eval_whenexpr_as_bool job variables onload expr =
-  match eval_whenexpr job variables onload expr with
-  | T_unit -> false
-  | T_bool r -> r
-  | T_string s -> s <> ""
-  | T_int i -> sign_big_int i <> 0
-  | T_float f -> f <> 0.
-
-(* Do a comparison on two typed values and return -1/0/+1.  If the
- * types are different then we compare the values as strings.  The user
- * can avoid this by specifying types.
- *)
-and compare_values value1 value2 =
-  match value1, value2 with
-  | T_bool b1, T_bool b2 -> compare b1 b2
-  | T_string s1, T_string s2 -> compare s1 s2
-  | T_int i1, T_int i2 -> compare_big_int i1 i2
-  | T_float f1, T_float f2 -> compare f1 f2
-    (* XXX BUG: int should be promoted to float in mixed numeric comparison *)
-  | _ ->
-    let value1 = string_of_variable value1
-    and value2 = string_of_variable value2 in
-    compare value1 value2
-
-(* + operator is addition or string concatenation. *)
-and add_values value1 value2 =
-  match value1, value2 with
-  | T_int i1, T_int i2 -> T_int (add_big_int i1 i2)
-  | T_float i1, T_float i2 -> T_float (i1 +. i2)
-  | T_int i1, T_float i2 -> T_float (float_of_big_int i1 +. i2)
-  | T_float i1, T_int i2 -> T_float (i1 +. float_of_big_int i2)
-  | T_string i1, T_string i2 -> T_string (i1 ^ i2)
-  | _ ->
-    invalid_arg
-      (sprintf "incompatible types in addition: %s + %s"
-         (printable_string_of_variable value1)
-         (printable_string_of_variable value2))
-
-and sub_values value1 value2 =
-  match value1, value2 with
-  | T_int i1, T_int i2 -> T_int (sub_big_int i1 i2)
-  | T_float i1, T_float i2 -> T_float (i1 -. i2)
-  | T_int i1, T_float i2 -> T_float (float_of_big_int i1 -. i2)
-  | T_float i1, T_int i2 -> T_float (i1 -. float_of_big_int i2)
-  | _ ->
-    invalid_arg
-      (sprintf "incompatible types in subtraction: %s - %s"
-         (printable_string_of_variable value1)
-         (printable_string_of_variable value2))
-
-and mul_values value1 value2 =
-  match value1, value2 with
-  | T_int i1, T_int i2 -> T_int (mult_big_int i1 i2)
-  | T_float i1, T_float i2 -> T_float (i1 *. i2)
-  | T_int i1, T_float i2 -> T_float (float_of_big_int i1 *. i2)
-  | T_float i1, T_int i2 -> T_float (i1 *. float_of_big_int i2)
-  | _ ->
-    invalid_arg
-      (sprintf "incompatible types in multiplication: %s * %s"
-         (printable_string_of_variable value1)
-         (printable_string_of_variable value2))
-
-and div_values value1 value2 =
-  match value1, value2 with
-  | T_int i1, T_int i2 -> T_int (div_big_int i1 i2)
-  | T_float i1, T_float i2 -> T_float (i1 /. i2)
-  | T_int i1, T_float i2 -> T_float (float_of_big_int i1 /. i2)
-  | T_float i1, T_int i2 -> T_float (i1 /. float_of_big_int i2)
-  | _ ->
-    invalid_arg
-      (sprintf "incompatible types in division: %s / %s"
-         (printable_string_of_variable value1)
-         (printable_string_of_variable value2))
-
-and mod_values value1 value2 =
-  match value1, value2 with
-  | T_int i1, T_int i2 -> T_int (mod_big_int i1 i2)
-  | T_float i1, T_float i2 -> T_float (mod_float i1 i2)
-  | T_int i1, T_float i2 -> T_float (mod_float (float_of_big_int i1) i2)
-  | T_float i1, T_int i2 -> T_float (mod_float i1 (float_of_big_int i2))
-  | _ ->
-    invalid_arg
-      (sprintf "incompatible types in modulo: %s mod %s"
-         (printable_string_of_variable value1)
-         (printable_string_of_variable value2))
-
-and string_of_variable = function
-  | T_unit -> "" (* for string_of_variable, we don't want () here *)
-  | T_bool b -> string_of_bool b
-  | T_string s -> s
-  | T_int i -> string_of_big_int i
-  | T_float f -> string_of_float f
-
-and printable_string_of_variable = function
-  | T_unit -> "()"
-  | T_bool b -> string_of_bool b
-  | T_string s -> sprintf "%S" s
-  | T_int i -> string_of_big_int i
-  | T_float f -> string_of_float f
-
-let job_evaluate job variables onload =
-  match job with
-  | { job_cond = Every_job _ } -> false, job
-  | { job_cond = When_job whenexpr } ->
-    let state = eval_whenexpr_as_bool job variables onload whenexpr in
-
-    (* Because jobs are edge-triggered, we're only interested in the
-     * case where the evaluation state changes from false -> true.
-     *)
-    match job.job_private.job_prev_eval_state, state with
-    | None, false
-    | Some false, false
-    | Some true, true
-    | Some true, false ->
-      let jobp = { job.job_private with job_prev_eval_state = Some state } in
-      let job = { job with job_private = jobp } in
-      false, job
-
-    | None, true
-    | Some false, true ->
-      let jobp = { job_prev_eval_state = Some true;
-                   job_prev_variables = Some variables } in
-      let job = { job with job_private = jobp } in
-      true, job
-
-let next_periodexpr =
-  (* Round up 'a' to the next multiple of 'i'. *)
-  let round_up_float a i =
-    let r = mod_float a i in
-    if r = 0. then a +. i else a +. (i -. r)
-  and round_up a i =
-    let r = a mod i in
-    if r = 0 then a + i else a + (i - r)
-  in
-
-  fun t -> function
-  | Every_seconds i ->
-    let i = float_of_int i in
-    round_up_float t i
-
-  | Every_years i ->
-    let tm = gmtime t in
-
-    (* Round 'tm' up to the first day of the next year. *)
-    let year = round_up tm.tm_year i in
-    let tm = { tm with tm_sec = 0; tm_min = 0; tm_hour = 0;
-                       tm_mday = 1; tm_mon = 0; tm_year = year } in
-    fst (mktime tm)
-
-  | Every_days i ->
-    let t = Date.from_unixfloat t in
-    let t0 = Date.make 1970 1 1 in
-
-    (* Number of whole days since Unix Epoch. *)
-    let nb_days = Date.Period.safe_nb_days (Date.sub t t0) in
-
-    let nb_days = round_up nb_days i in
-    let t' = Date.add t0 (Date.Period.day nb_days) in
-    Date.to_unixfloat t'
-
-  | Every_months i ->
-    (* Calculate number of whole months since Unix Epoch. *)
-    let tm = gmtime t in
-    let months = 12 * (tm.tm_year - 70) + tm.tm_mon in
-
-    let months = round_up months i in
-    let t0 = Date.make 1970 1 1 in
-    let t' = Date.add t0 (Date.Period.month months) in
-    Date.to_unixfloat t'
index 4d5ccc7..7a69d44 100644 (file)
@@ -123,145 +123,3 @@ val isalnum : char -> bool
 
 val filter_map : ('a -> 'b option) -> 'a list -> 'b list
 (** Filter + map. *)
-
-type whenexpr =
-  | Expr_unit                           (** Unit constant. *)
-  | Expr_bool of bool                   (** A boolean constant. *)
-  | Expr_str of string                  (** A string constant. *)
-  | Expr_int of Big_int.big_int         (** An integer constant. *)
-  | Expr_float of float                 (** A float constant. *)
-  | Expr_var of string                  (** A variable name. *)
-  | Expr_and of whenexpr * whenexpr     (** && *)
-  | Expr_or of whenexpr * whenexpr      (** || *)
-  | Expr_lt of whenexpr * whenexpr      (** < *)
-  | Expr_le of whenexpr * whenexpr      (** <= *)
-  | Expr_eq of whenexpr * whenexpr      (** == *)
-  | Expr_ge of whenexpr * whenexpr      (** >= *)
-  | Expr_gt of whenexpr * whenexpr      (** > *)
-  | Expr_not of whenexpr                (** boolean not *)
-  | Expr_add of whenexpr * whenexpr     (** arithmetic addition or string cat *)
-  | Expr_sub of whenexpr * whenexpr     (** arithmetic subtraction *)
-  | Expr_mul of whenexpr * whenexpr     (** arithmetic multiplication *)
-  | Expr_div of whenexpr * whenexpr     (** arithmetic division *)
-  | Expr_mod of whenexpr * whenexpr     (** arithmetic modulo *)
-  | Expr_changes of string              (** changes var *)
-  | Expr_increases of string            (** increases var *)
-  | Expr_decreases of string            (** decreases var *)
-  | Expr_prev of string                 (** prev var *)
-  | Expr_reloaded                       (** reloaded () *)
-(** Internal type used to represent 'when' expressions. *)
-
-type periodexpr =
-  | Every_seconds of int
-  | Every_days of int
-  | Every_months of int
-  | Every_years of int
-(** Internal type used to represent 'every' expressions. *)
-
-type shell_script = {
-  sh_loc : Camlp4.PreCast.Loc.t;
-  sh_script : string;
-}
-(** A shell script. *)
-
-type variable =
-  | T_unit
-  | T_bool of bool
-  | T_string of string
-  | T_int of Big_int.big_int
-  | T_float of float
-(** Typed variable (see also [whenproto.x]) *)
-
-val string_of_variable : variable -> string
-
-val variable_of_rpc : Whenproto_aux.variable -> variable
-val rpc_of_variable : variable -> Whenproto_aux.variable
-
-type variables = variable StringMap.t
-(** A set of variables. *)
-
-type job_private
-(** Private state associated with a job, used for evaluation. *)
-
-type job_cond =
-  | When_job of whenexpr                (** when ... : << >> *)
-  | Every_job of periodexpr             (** every ... : << >> *)
-
-type job = {
-  job_loc : Camlp4.PreCast.Loc.t;
-  job_name : string;
-  job_cond : job_cond;
-  job_script : shell_script;
-  job_private : job_private;
-}
-(** A job.  Note that because of the [job_private] field, these cannot
-    be constructed directly.  Use {!make_when_job} or {!make_every_job}
-    to construct one. *)
-
-val make_when_job : Camlp4.PreCast.Loc.t -> string -> whenexpr -> shell_script -> job
-(** Make a when-statement job. *)
-
-val make_every_job : Camlp4.PreCast.Loc.t -> string -> periodexpr -> shell_script -> job
-(** Make an every-statement job. *)
-
-val expr_of_ast : Camlp4.PreCast.Ast.Loc.t -> Camlp4.PreCast.Ast.expr -> whenexpr
-(** Convert OCaml AST to an expression.  Since OCaml ASTs are much
-    more general than the expressions we can use, this can raise
-    [Invalid_argument] in many different situations. *)
-
-val string_of_whenexpr : whenexpr -> string
-(** Pretty-print an expression to a string. *)
-
-val string_of_periodexpr : periodexpr -> string
-(** Pretty-print a period expression to a string. *)
-
-val dependencies_of_whenexpr : whenexpr -> string list
-(** Return list of variables that an expression depends on.  This is
-    used to work out when an expression needs to be reevaluated. *)
-
-val dependencies_of_job : job -> string list
-(** Which variables does this job depend on? *)
-
-val job_evaluate : job -> variables -> bool -> bool * job
-(** [job_evaluate job variables onload] evaluates [job]'s condition in
-    the context of the [variables], and return [true] iff it should be
-    run now.
-
-    Note that this returns a possibly-updated [job] structure.
-
-    This is a no-op for 'every' jobs. *)
-
-val next_periodexpr : float -> periodexpr -> float
-(** [next_periodexpr t period] returns the earliest event of [period]
-    strictly after time [t].
-
-    Visualising periods as repeated events on a timeline, this
-    returns [t']:
-
-    {v
-    events:  ---+---------+---------+---------+---------+---------+-----
-    times:          t     t'
-    }
-
-    Note that [periodexpr] events are not necessarily regular.
-    eg. The start of a month is not a fixed number of seconds
-    after the start of the previous month.  'Epoch' refers
-    to the Unix Epoch (ie. 1970-01-01 00:00:00 UTC).
-
-    If [period = Every_seconds i] then events are when
-    [t' mod i == 0] when t' is the number of seconds since
-    the Epoch.  This returns the next t' > t.
-
-    If [period = Every_days i] then events happen at
-    midnight UTC every [i] days since the Epoch.
-    This returns the next midnight > t.
-
-    If [period = Every_months i] then events happen at
-    midnight UTC on the 1st day of the month every [i] months
-    since the Epoch.  This returns midnight on the
-    1st day of the next month > t.
-
-    If [period = Every_years i] then events happen at
-    midnight UTC on the 1st day of the year when
-    [(y - 1970) mod i == 0].  This returns midnight on the
-    1st day of the next year > t. *)