From 76e68068f22a67c788f14a7c9404db7f7514da49 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Thu, 23 Feb 2012 11:24:14 +0000 Subject: [PATCH] Split large 'Whenutils' module into two (creating new module 'Whenexpr'). --- daemon/daemon.ml | 1 + lib/Makefile.am | 5 + lib/pa_when.ml | 42 ++-- lib/whenexpr.ml | 662 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/whenexpr.mli | 162 +++++++++++++ lib/whenfile.ml | 2 +- lib/whenfile.mli | 6 +- lib/whenutils.ml | 634 --------------------------------------------------- lib/whenutils.mli | 142 ------------ 9 files changed, 855 insertions(+), 801 deletions(-) create mode 100644 lib/whenexpr.ml create mode 100644 lib/whenexpr.mli diff --git a/daemon/daemon.ml b/daemon/daemon.ml index b38481c..af2668f 100644 --- a/daemon/daemon.ml +++ b/daemon/daemon.ml @@ -17,6 +17,7 @@ *) open Whenutils +open Whenexpr open Big_int open Unix diff --git a/lib/Makefile.am b/lib/Makefile.am index 1421da3..967cfd0 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -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 diff --git a/lib/pa_when.ml b/lib/pa_when.ml index 0d16469..da51e20 100644 --- a/lib/pa_when.ml +++ b/lib/pa_when.ml @@ -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 index 0000000..5b4bbdd --- /dev/null +++ b/lib/whenexpr.ml @@ -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 index 0000000..3c05826 --- /dev/null +++ b/lib/whenexpr.mli @@ -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. *) diff --git a/lib/whenfile.ml b/lib/whenfile.ml index 89a09b0..5f205fb 100644 --- a/lib/whenfile.ml +++ b/lib/whenfile.ml @@ -16,7 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Whenutils +open Whenexpr open Printf diff --git a/lib/whenfile.mli b/lib/whenfile.mli index 345c758..b754cbc 100644 --- a/lib/whenfile.mli +++ b/lib/whenfile.mli @@ -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. 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' diff --git a/lib/whenutils.mli b/lib/whenutils.mli index 4d5ccc7..7a69d44 100644 --- a/lib/whenutils.mli +++ b/lib/whenutils.mli @@ -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. *) -- 1.8.3.1