From a6b5a6bdd138a5ccc6827bcc73580df1e9218820 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Fri, 24 Nov 2017 09:22:24 +0100 Subject: Moved all the code to src directory --- src/evaluator.ml | 373 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 373 insertions(+) create mode 100755 src/evaluator.ml (limited to 'src/evaluator.ml') 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 + -- cgit v1.2.3