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:C.t ref) = 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 -> Date.get_julian_day (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num year) (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num month) (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num day) |> D.Num.of_num ); let module CompareNum = Make_Compare(D.Num) in Data.( CompareNum.register t_int; register0 "rand" f_number D.Num.rnd; 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; 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_; register2 "or" (t_bool, t_bool) f_bool D.Bool.or_; register2 "xor" (t_bool, t_bool) f_bool D.Bool.neq; 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.of_num (Num.num_of_int 0)); fold "product" t_int f_number D.Num.mult (D.Num.of_num (Num.num_of_int 1)); register1 "+" t_int f_num (fun x -> x); register1 "-" t_int f_num D.Num.neg; (* Unary negation *) register2 "^" (t_int, t_int) f_number D.Num.pow; 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