diff options
Diffstat (limited to 'src/evaluator.ml')
| -rwxr-xr-x | src/evaluator.ml | 323 |
1 files changed, 49 insertions, 274 deletions
diff --git a/src/evaluator.ml b/src/evaluator.ml index f718e1f..ed384e6 100755 --- a/src/evaluator.ml +++ b/src/evaluator.ml @@ -1,103 +1,42 @@ module D = DataType
-module T = Tools
+module F = Functions
module Data = struct
-(** Data format *)
+ (*** Values definitions *)
-type 'a dataFormat = 'a ScTypes.dataFormat
+ 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
-(*** 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))
+ (** Extract the type and the content from a value *)
+ let get_argument: type a. a value -> a F.typ * a = function
+ | Bool b -> F.t_bool, b
+ | Num (_, n) -> F.t_int, n
+ | String s -> F.t_string, s
+ | List (t, l) -> F.t_list (F.typ_of_format t), l
+ | Matrix (t, l) -> F.t_list (F.t_list (F.typ_of_format t)), l
end
-module C = Catalog.Make(Data)
-
-
-type t = C.t
-
-let catalog = ref C.empty
-
-let get_catalog () = !catalog
+(** Functions are stored as a mutable catalog. A setter is given *)
+let catalog = ref (F.C.compile F.C.empty)
-let repr = C.repr
+let set_catalog t = catalog := t
type existencialResult =
| Result : 'a Data.value -> existencialResult [@@unboxed]
let inject:
-type a. a Data.dataFormat -> a -> existencialResult = fun resultFormat res ->
+type a. a ScTypes.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))
+ | 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
@@ -106,58 +45,50 @@ 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
+ | 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))
-
+(** Call the function with the arguments *)
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 arg1 = (F.t_unit, ()) in
+ let F.C.R(ret, res) = F.C.eval1 !catalog name' arg1 in
let returnType = ScTypes.DataFormat.guess_format_result ret (fun () -> raise Errors.TypeError) in
- inject returnType (f ())
+ inject returnType res
| (Result p1)::[] ->
- let C.Fn1(ret, f) =
- C.find_function !catalog name' (C.T1 (Data.type_of_value p1)) in
+ let arg1 = Data.get_argument p1 in
+ let F.C.R(ret, res) = F.C.eval1 !catalog name' arg1 in
let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in
- inject returnType (f (Data.get_value_content p1))
+ inject returnType res
| (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 arg1 = Data.get_argument p1
+ and arg2 = Data.get_argument p2 in
+ let F.C.R(ret, res) = F.C.eval2 !catalog name' arg1 arg2 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))
+ inject returnType res
| (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 arg1 = Data.get_argument p1
+ and arg2 = Data.get_argument p2
+ and arg3 = Data.get_argument p3 in
+ let F.C.R(ret, res) = F.C.eval3 !catalog name' arg1 arg2 arg3 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))
+ inject returnType res
| _ -> 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);
+ Functions.repr formatter (fst @@ Data.get_argument x);
Format.flush_str_formatter ()) args in
raise (Errors.Undefined (name, signature))
@@ -201,173 +132,17 @@ let eval mapper value = begin | ScTypes.Call (name, args) ->
let args' = List.map extract args in
call name args'
- end
- in
+ 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
+ | 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
-
|