path: root/evaluator.ml

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.empty

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;


  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