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 --- evaluator.ml | 373 ----------------------------------------------------------- 1 file changed, 373 deletions(-) delete mode 100755 evaluator.ml (limited to 'evaluator.ml') diff --git a/evaluator.ml b/evaluator.ml deleted file mode 100755 index f718e1f..0000000 --- a/evaluator.ml +++ /dev/null @@ -1,373 +0,0 @@ -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