Moved all the code to src directory

1 files changed, 0 insertions, 373 deletions

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

-