let values m = fold (fun _ v vs -> v :: vs) m []
end
+module IntMap = struct
+ include Map.Make (struct type t = int let compare = compare end)
+ let keys m = fold (fun k _ ks -> k :: ks) m []
+ let values m = fold (fun _ v vs -> v :: vs) m []
+end
+
module StringSet = Set.Make (String)
+let (//) = Filename.concat
+
+let isalpha = function 'a'..'z' | 'A'..'Z' -> true | _ -> false
+let isalnum = function 'a'..'z' | 'A'..'Z' | '0'..'9' -> true | _ -> false
+
let rec filter_map f = function
| [] -> []
| x :: 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_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
}
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)
(* 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;
+ 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;
+ job_prev_variables : variables option;
}
-let no_job_private =
- { job_prev_eval_state = false; job_prev_variables = StringMap.empty }
-
type job_cond =
| When_job of whenexpr
| Every_job of periodexpr
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
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_var v -> Expr_var v
| IExpr_app ("&&", exprs) ->
- (match exprs with
- | [e1; e2] -> Expr_and (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
- | _ ->
- invalid_arg (sprintf "%s: && operator must be applied to two parameters"
- (Loc.to_string _loc))
- )
+ two_params _loc "&&" exprs (fun e1 e2 -> Expr_and (e1, e2))
| IExpr_app ("||", exprs) ->
- (match exprs with
- | [e1; e2] -> Expr_or (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
- | _ ->
- invalid_arg (sprintf "%s: || operator must be applied to two parameters"
- (Loc.to_string _loc))
- )
+ 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) ->
- (match exprs with
- | [e1; e2] -> Expr_eq (expr_of_iexpr _loc e1, expr_of_iexpr _loc e2)
- | _ ->
- invalid_arg (sprintf "%s: = operator must be applied to two parameters"
- (Loc.to_string _loc))
- )
+ 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) ->
- (match exprs with
- | [e1] -> Expr_not (expr_of_iexpr _loc e1)
- | _ ->
- invalid_arg (sprintf "%s: ! operator must be applied to one parameter"
- (Loc.to_string _loc))
- )
+ 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 (("change"|"changes"|"changed"), _) ->
- invalid_arg (sprintf "%s: 'changes' operator must be followed by a variable name"
- (Loc.to_string _loc))
+ | 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)
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_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) ->
- dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
- | Expr_or (e1, e2) ->
- dependencies_of_whenexpr e1 @ dependencies_of_whenexpr e2
- | Expr_eq (e1, e2) ->
+ | 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 -> [v]
+ | 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 = function
+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 ->
- (try StringMap.find v variables with Not_found -> T_string "")
+ get_variable variables v
| Expr_and (e1, e2) ->
- if eval_whenexpr_as_bool job variables e1 &&
- eval_whenexpr_as_bool job variables e2 then
+ 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 e1 ||
- eval_whenexpr_as_bool job variables e2 then
+ 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 e1
- and e2 = eval_whenexpr job variables e2 in
- if 0 = compare_values e1 e2 then
+ 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 e) then
+ 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 =
- try StringMap.find v job.job_private.job_prev_variables
- with Not_found -> T_string "" in
- let curr_value =
- try StringMap.find v variables
- with Not_found -> T_string "" in
-
- if 0 <> compare_values prev_value curr_value then
+ 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 expr =
- match eval_whenexpr job variables expr with
+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_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 = value_as_string value1
- and value2 = value_as_string value2 in
+ let value1 = string_of_variable value1
+ and value2 = string_of_variable value2 in
compare value1 value2
-and value_as_string = function
+(* + 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
-let job_evaluate job variables =
+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 whenexpr in
+ 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
- | false, false
- | true, true
- | true, false ->
- let jobp = { job.job_private with job_prev_eval_state = state } in
+ | 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
- | false, true ->
- let jobp = { job_prev_eval_state = true;
- job_prev_variables = variables } in
+ | 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
git.annexia.org / whenjobs.git / blobdiff