X-Git-Url: http://git.annexia.org/?p=whenjobs.git;a=blobdiff_plain;f=lib%2Fwhenutils.ml;h=2db41038b43969bf1cd4000d395d1ab0d4db5928;hp=ed1b065557296c872f6ca6bab2662f3431200e83;hb=dc7fb3ba41fb942f9d29fd00bb2ff4415ff1252d;hpb=0b56c62c7f767b49bc2e71923f7211c9c2f61172 diff --git a/lib/whenutils.ml b/lib/whenutils.ml index ed1b065..2db4103 100644 --- a/lib/whenutils.ml +++ b/lib/whenutils.ml @@ -41,6 +41,9 @@ 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 -> @@ -49,6 +52,7 @@ let rec filter_map f = function | None -> filter_map f xs type whenexpr = + | Expr_unit | Expr_bool of bool | Expr_str of string | Expr_int of Big_int.big_int @@ -56,14 +60,28 @@ type whenexpr = | 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 @@ -89,18 +107,21 @@ type shell_script = { } 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) @@ -112,18 +133,19 @@ 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; + 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 @@ -136,10 +158,23 @@ type job = { 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 @@ -175,6 +210,7 @@ and uncurry_app_tree _loc = function 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 @@ -182,49 +218,86 @@ and expr_of_iexpr _loc = function | 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) @@ -234,10 +307,32 @@ let rec string_of_whenexpr = function 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" @@ -250,77 +345,179 @@ let string_of_periodexpr = function | 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) -> + | 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_eq (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 @@ -341,32 +538,104 @@ and compare_values value1 value2 = 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 -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