X-Git-Url: http://git.annexia.org/?p=whenjobs.git;a=blobdiff_plain;f=lib%2Fwhenutils.ml;fp=lib%2Fwhenutils.ml;h=7d20f759155ef69cb0450383318f51c92db19e35;hp=aa59f1851fd92eed894304c2e001a90db5242a67;hb=76e68068f22a67c788f14a7c9404db7f7514da49;hpb=350d1284cb1152d0102bb20140b7edc893d78bef

diff --git a/lib/whenutils.ml b/lib/whenutils.ml
index aa59f18..7d20f75 100644
--- a/lib/whenutils.ml
+++ b/lib/whenutils.ml
@@ -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'