diff options
Diffstat (limited to 'src/evaluator.ml')
| -rwxr-xr-x | src/evaluator.ml | 373 |
1 files changed, 373 insertions, 0 deletions
diff --git a/src/evaluator.ml b/src/evaluator.ml new file mode 100755 index 0000000..f718e1f --- /dev/null +++ b/src/evaluator.ml @@ -0,0 +1,373 @@ +module D = DataType
+module T = Tools
+
+module Data = struct
+
+(** Data format *)
+
+type 'a dataFormat = 'a ScTypes.dataFormat
+
+(*** Type definitions *)
+
+type _ typ =
+ | Unit: unit typ
+ | Bool: D.Bool.t typ
+ | Num: D.Num.t typ
+ | String: UTF8.t typ
+ | List: 'a typ -> 'a list typ
+
+let typ_of_format: type a. a ScTypes.dataFormat -> a typ = function
+ | ScTypes.Date -> Num
+ | ScTypes.Number -> Num
+ | ScTypes.String -> String
+ | ScTypes.Bool -> Bool
+
+let rec compare_typ: type a b. a typ -> b typ -> (a, b) T.cmp =
+begin fun a b ->
+ match a, b with
+ | Unit, Unit -> T.Eq
+ | Bool, Bool -> T.Eq
+ | Num, Num -> T.Eq
+ | String, String -> T.Eq
+ | List l1, List l2 ->
+ begin match compare_typ l1 l2 with
+ | T.Lt -> T.Lt
+ | T.Eq -> T.Eq
+ | T.Gt -> T.Gt
+ end
+ | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt
+end
+
+let rec repr:
+type a. Format.formatter -> a typ -> unit =
+fun printer typ -> match typ with
+ | Unit -> Format.fprintf printer "Unit"
+ | Bool -> Format.fprintf printer "Bool"
+ | Num -> Format.fprintf printer "Num"
+ | String -> Format.fprintf printer "String"
+ | List t -> Format.fprintf printer "List[%a]"
+ repr t
+
+type 'a returnType = 'a ScTypes.returnType
+
+(*** Values definitions *)
+
+type 'a value =
+ | Bool: D.Bool.t -> D.Bool.t value
+ | Num: D.Num.t ScTypes.dataFormat * D.Num.t -> D.Num.t value
+ | String: UTF8.t -> UTF8.t value
+ | List: 'a ScTypes.dataFormat * 'a list -> 'a list value
+ | Matrix: 'a ScTypes.dataFormat * 'a list list -> 'a list list value
+
+(** Get the value out of the box *)
+let get_value_content: type a. a value -> a = function
+ | Bool b -> b
+ | Num (_, n) -> n
+ | String s -> s
+ | List (t, l) -> l
+ | Matrix (t, l) -> l
+
+(* Extract the type from a boxed value *)
+let type_of_value: type a. a value -> a typ = function
+ | Bool b -> Bool
+ | Num (n, _) -> Num
+ | String s -> String
+ | List (t, l) -> List (typ_of_format t)
+ | Matrix (t, l) -> List (List (typ_of_format t))
+
+end
+
+module C = Catalog.Make(Data)
+
+
+type t = C.t
+
+let catalog = ref C.empty
+
+let get_catalog () = !catalog
+
+let repr = C.repr
+
+type existencialResult =
+ | Result : 'a Data.value -> existencialResult [@@unboxed]
+
+let inject:
+type a. a Data.dataFormat -> a -> existencialResult = fun resultFormat res ->
+ begin match resultFormat with
+ | ScTypes.Bool -> Result (Data.Bool res)
+ | ScTypes.String -> Result (Data.String res)
+ | ScTypes.Number -> Result (Data.Num (resultFormat, res))
+ | ScTypes.Date -> Result (Data.Num (resultFormat, res))
+ end
+
+
+(** Extract the format from a list of results *)
+let build_format_list ll () =
+
+ List.map (fun (Result x) ->
+ begin match x with
+ | Data.Bool _ -> ScTypes.DataFormat.F (ScTypes.Bool)
+ | Data.Num (x, _) -> ScTypes.DataFormat.F x
+ | Data.String _ -> ScTypes.DataFormat.F (ScTypes.String)
+ | Data.List (f, _) -> ScTypes.DataFormat.F f
+ | Data.Matrix (f, _) -> ScTypes.DataFormat.F f
+ end
+ ) ll
+
+
+let register0 name returnType f =
+ catalog := C.register !catalog name (C.T1(Data.Unit)) (C.Fn1 (returnType, f))
+
+let register1 name typ1 returnType f =
+ catalog := C.register !catalog name (C.T1(typ1)) (C.Fn1 (returnType, f))
+
+let register2 name (typ1, typ2) result f =
+ catalog := C.register !catalog name (C.T2(typ1, typ2)) (C.Fn2 (result, f))
+
+let register3 name (typ1, typ2, typ3) result f =
+ catalog := C.register !catalog name (C.T3(typ1, typ2, typ3)) (C.Fn3 (result, f))
+
+let call name args = begin
+ let name' = UTF8.to_utf8string name in
+ begin try match args with
+ | [] ->
+ let C.Fn1(ret, f) = C.find_function !catalog name' (C.T1 Data.Unit) in
+ let returnType = ScTypes.DataFormat.guess_format_result ret (fun () -> raise Errors.TypeError) in
+ inject returnType (f ())
+
+ | (Result p1)::[] ->
+ let C.Fn1(ret, f) =
+ C.find_function !catalog name' (C.T1 (Data.type_of_value p1)) in
+ let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in
+ inject returnType (f (Data.get_value_content p1))
+
+ | (Result p1)::(Result p2)::[] ->
+ let C.Fn2(ret, f) =
+ C.find_function !catalog name' (C.T2 (Data.type_of_value p1, Data.type_of_value p2)) in
+ let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in
+ inject returnType (f (Data.get_value_content p1) (Data.get_value_content p2))
+
+ | (Result p1)::(Result p2)::(Result p3)::[] ->
+ let C.Fn3(ret, f) =
+ C.find_function !catalog name' (C.T3 (Data.type_of_value p1, Data.type_of_value p2, Data.type_of_value p3)) in
+ let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in
+ inject returnType (f (Data.get_value_content p1) (Data.get_value_content p2) (Data.get_value_content p3))
+
+ | _ -> raise Not_found
+ with Not_found ->
+ let signature = List.map (fun (Result x) ->
+ let formatter = Format.str_formatter in
+ Data.repr formatter (Data.type_of_value x);
+ Format.flush_str_formatter ()) args in
+
+ raise (Errors.Undefined (name, signature))
+ end
+end
+
+let eval mapper value = begin
+
+ (** Extract the value from a raw type.
+ If the value is Undefined, raise an exception.
+ *)
+ let extract_value : ScTypes.result -> existencialResult = begin function
+ | ScTypes.Result (ScTypes.Num (f, n)) -> Result (Data.Num (f, n))
+ | ScTypes.Result (ScTypes.Bool b) -> Result (Data.Bool b)
+ | ScTypes.Result (ScTypes.Str s) -> Result (Data.String s)
+ | ScTypes.Error x -> raise x
+ end in
+
+ (** Extract the value from an expression.
+ [extract typ expr] will evaluate the expression and return it. If the
+ result cannot be evaluated (because of references pointing to missing
+ values) a default value of type [typ] will be returned.
+ *)
+ let rec extract = begin function
+ (* For a reference to an external we first extract the value pointed *)
+ | ScTypes.Ref r -> ScTypes.Refs.(
+ begin match ScTypes.Refs.get_content @@ mapper r with
+ | C (Value (format, f)) -> begin match format with
+ | ScTypes.Date -> Result (Data.Num (format, f))
+ | ScTypes.Number -> Result (Data.Num (format, f))
+ | ScTypes.String -> Result (Data.String f)
+ | ScTypes.Bool -> Result (Data.Bool f)
+ end
+ | C (List (format, l)) -> Result (Data.List (format, l))
+ | C (Matrix (format, l)) -> Result (Data.Matrix (format, l))
+ end)
+
+ (* Evaluate the expression *)
+ | ScTypes.Expression e -> extract e
+ | ScTypes.Value v -> extract_value (ScTypes.Result v)
+ | ScTypes.Call (name, args) ->
+ let args' = List.map extract args in
+ call name args'
+ end
+ in
+ let Result r = ((extract[@tailrec]) value) in
+ begin match r with
+ | Data.Bool b -> ScTypes.Result (ScTypes.boolean b)
+ | Data.String s -> ScTypes.Result (ScTypes.string s)
+ | Data.Num (format, n) -> begin match ScTypes.get_numeric_type format with
+ | ScTypes.Date -> ScTypes.Result (ScTypes.date n)
+ | ScTypes.Number -> ScTypes.Result (ScTypes.number n)
+ end
+ | _ -> raise Errors.TypeError
+ end
+end
+
+let wrap f =
+ let old_catalog = !catalog in
+ Tools.try_finally
+ (fun () -> catalog := C.empty; f ())
+ (fun () -> catalog := old_catalog)
+
+
+(* Register the standard functions *)
+type 'a returnType = 'a ScTypes.returnType
+
+let f_num = ScTypes.f_num
+let f_date = ScTypes.f_date
+let f_number = ScTypes.f_number
+let f_string = ScTypes.f_string
+let f_bool = ScTypes.f_bool
+
+module Make_Compare(C: D.COMPARABLE) = struct
+
+ let register t = begin
+ register2 "=" (t, t) f_bool C.eq;
+ register2 "<>" (t, t) f_bool C.neq;
+ register2 ">" (t, t) f_bool C.gt;
+ register2 ">=" (t, t) f_bool C.ge;
+ register2 "<" (t, t) f_bool C.lt;
+ register2 "<=" (t, t) f_bool C.le;
+ end
+
+end
+
+type 'a typ = 'a Data.typ
+let t_bool: DataType.Bool.t typ = Data.Bool
+let t_int: DataType.Num.t typ = Data.Num
+let t_string: UTF8.t typ = Data.String
+let t_list (t: 'a typ): 'a list typ = Data.List t
+
+(* Helper for list functions : reduce over a list of elements *)
+let reduce name typ res f = begin
+ register1 name (t_list typ) res (fun x ->
+ List.fold_left f (List.hd x) x);
+ register1 name (t_list (t_list typ)) res (fun x ->
+ List.fold_left (List.fold_left f) (List.hd (List.hd x)) x);
+end
+
+(* Helper for list functions : fold over a list of elements *)
+let fold name t_in t_out f init = begin
+ register1 name (t_list t_in) t_out (fun x ->
+ List.fold_left f init x);
+ register1 name (t_list (t_list t_in)) t_out (fun x ->
+ List.fold_left (List.fold_left f) init x);
+end
+
+let if_: type a. bool -> a -> a -> a = fun a b c -> if a then b else c
+
+
+let () = begin
+
+ (* Build a date *)
+ register3 "date" (t_int, t_int, t_int) f_date (
+ fun year month day ->
+ D.Date.get_julian_day
+ (D.Num.to_int year)
+ (D.Num.to_int month)
+ (D.Num.to_int day)
+ );
+
+ let module CompareNum = Make_Compare(D.Num) in
+ Data.(
+ CompareNum.register t_int;
+ register0 "rand" f_number D.Num.rnd;
+
+ register0 "pi" f_number (fun () -> D.Num.of_float (4. *. atan 1.));
+ register1 "sin" t_int f_number (fun x -> D.Num.of_float (sin @@ D.Num.to_float x));
+ register1 "cos" t_int f_number (fun x -> D.Num.of_float (cos @@ D.Num.to_float x));
+ register1 "tan" t_int f_number (fun x -> D.Num.of_float (tan @@ D.Num.to_float x));
+ register1 "atan" t_int f_number (fun x -> D.Num.of_float (atan @@ D.Num.to_float x));
+ register1 "asin" t_int f_number (fun x -> D.Num.of_float (asin @@ D.Num.to_float x));
+ register1 "acos" t_int f_number (fun x -> D.Num.of_float (acos @@ D.Num.to_float x));
+ register1 "sinh" t_int f_number (fun x -> D.Num.of_float (sinh @@ D.Num.to_float x));
+ register1 "cosh" t_int f_number (fun x -> D.Num.of_float (cosh @@ D.Num.to_float x));
+ register1 "tanh" t_int f_number (fun x -> D.Num.of_float (tanh @@ D.Num.to_float x));
+ register2 "atan2" (t_int, t_int)f_number (fun x y ->
+ D.Num.of_float (atan2 (D.Num.to_float x) (D.Num.to_float y))
+ );
+
+ register1 "sqrt" t_int f_number (fun x -> D.Num.of_float (sqrt @@ D.Num.to_float x));
+ register1 "exp" t_int f_number (fun x -> D.Num.of_float (exp @@ D.Num.to_float x));
+ register1 "ln" t_int f_number (fun x -> D.Num.of_float (log @@ D.Num.to_float x));
+
+ register3 "if" (t_bool, t_int, t_int) f_number if_;
+ register3 "if" (t_bool, t_bool, t_bool) f_bool if_;
+ register3 "if" (t_bool, t_string, t_string) f_string if_;
+
+ register1 "abs" t_int f_number D.Num.abs;
+ register1 "int" t_int f_number D.Num.floor;
+ register1 "rounddown" t_int f_number D.Num.round_down;
+ register1 "round" t_int f_number D.Num.round;
+
+ register1 "trim" t_string f_string UTF8.trim;
+ register1 "right" t_string f_string (fun x -> UTF8.get x (-1));
+ register2 "right" (t_string, t_int) f_string (
+ fun t n ->
+ let n' = D.Num.to_int n in
+ UTF8.sub t (-(n')) n'
+ );
+ register1 "left" t_string f_string (fun x -> UTF8.get x 0);
+ register2 "left" (t_string, t_int) f_string (
+ fun t n ->
+ let n' = D.Num.to_int n in
+ UTF8.sub t 0 n'
+ );
+ register1 "len" t_string f_number (fun x -> D.Num.of_int @@ UTF8.length x);
+ register1 "lenb" t_string f_number (fun x -> D.Num.of_int @@ String.length @@ UTF8.to_utf8string x);
+ register1 "lower" t_string f_string UTF8.lower;
+ register1 "unicode" t_string f_number (fun x -> D.Num.of_int @@ UTF8.code x);
+ register1 "unichar" t_int f_string (fun x -> UTF8.char @@ D.Num.to_int x);
+ register1 "upper" t_string f_string UTF8.upper;
+ register3 "substitute" (t_string, t_string, t_string) f_string UTF8.replace;
+ register2 "rept" (t_string, t_int) f_string (fun t n -> UTF8.repeat (D.Num.to_int n) t);
+
+ let module CompareBool = Make_Compare(D.Bool) in
+ CompareBool.register t_bool;
+ register0 "true" f_bool (fun () -> D.Bool.true_);
+ register0 "false" f_bool (fun () -> D.Bool.false_);
+ register1 "not" t_bool f_bool D.Bool.not;
+ register2 "and" (t_bool, t_bool) f_bool D.Bool.and_;
+(* fold "and" t_bool f_bool D.Bool.and_ (D.Bool.true_); *)
+ register2 "or" (t_bool, t_bool) f_bool D.Bool.or_;
+(* fold "or" t_bool f_bool D.Bool.or_ (D.Bool.false_); *)
+ register2 "xor" (t_bool, t_bool) f_bool D.Bool.neq;
+(* fold "xor" t_bool f_bool D.Bool.neq (D.Bool.false_); *)
+
+ let module CompareString = Make_Compare(D.String) in
+ CompareString.register t_string;
+
+ reduce "min" t_int f_num D.Num.min; (* Minimum value from a list *)
+ reduce "max" t_int f_num D.Num.max; (* Maximum value from a list *)
+
+ fold "sum" t_int f_number D.Num.add (D.Num.zero);
+ fold "product" t_int f_number D.Num.mult (D.Num.one);
+
+ register2 "^" (t_int, t_int) f_number D.Num.pow;
+ register2 "power" (t_int, t_int) f_number D.Num.pow;
+
+ register2 "gcd"(t_int, t_int) f_number D.Num.gcd;
+ register2 "lcm"(t_int, t_int) f_number D.Num.lcm;
+ register1 "+" t_int f_num (fun x -> x);
+ register1 "-" t_int f_num D.Num.neg; (* Unary negation *)
+ register2 "+" (t_int, t_int) f_num D.Num.add;
+ register2 "-" (t_int, t_int) f_num D.Num.sub;
+ register2 "*" (t_int, t_int) f_number D.Num.mult;
+ register2 "/" (t_int, t_int) f_number D.Num.div;
+
+ )
+
+end
+
|