From 824f2987d47e87d58ee2a4a96d7be417aad6aeab Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@chimrod.com>
Date: Wed, 31 Jan 2018 13:20:20 +0100
Subject: API refactoring : made the GADT abstract, provide contructor for each
 case, and deported the expression with evaluation with module functors

---
 src/expressions/evaluate.ml | 142 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 142 insertions(+)
 create mode 100755 src/expressions/evaluate.ml

(limited to 'src/expressions/evaluate.ml')

diff --git a/src/expressions/evaluate.ml b/src/expressions/evaluate.ml
new file mode 100755
index 0000000..e910c19
--- /dev/null
+++ b/src/expressions/evaluate.ml
@@ -0,0 +1,142 @@
+(** Internal representation for each type *)
+type 'a value =
+    | Bool:   DataType.Bool.t                       -> DataType.Bool.t value
+    | Num:    DataType.Num.t ScTypes.DataFormat.t * DataType.Num.t  -> DataType.Num.t value
+    | String: DataType.String.t                     -> DataType.String.t value
+    | List:   'a ScTypes.DataFormat.t * 'a list       -> 'a list value
+    | Matrix: 'a ScTypes.DataFormat.t * 'a list list  -> 'a list list value
+
+type existencialResult =
+  | Result : 'a value -> existencialResult [@@unboxed]
+
+type t = (Functions.C.t * (int * int -> ScTypes.Result.t option))
+
+type repr = existencialResult
+
+type obs = ScTypes.Result.t
+
+module T:Sym_type.SYM_TYPE with type 'a obs = existencialResult = struct
+
+  type 'a t = 'a value
+
+  type 'a obs = existencialResult
+
+  let str s = String s
+
+  let num n = Num (ScTypes.DataFormat.Number, n)
+
+  let date d = Num (ScTypes.DataFormat.Date, d)
+
+  let bool b = Bool b
+
+  let observe x = Result x
+
+end
+
+module R = Eval_ref
+
+(** Extract the type and the content from a value *)
+let get_argument: type a. a value -> a Functions.typ * a = function
+  | Bool b        -> Functions.t_bool, b
+  | Num (_, n)    -> Functions.t_int, n
+  | String s      -> Functions.t_string, s
+  | List (t, l)   -> Functions.t_list (Functions.typ_of_format t), l
+  | Matrix (t, l) -> Functions.t_list (Functions.t_list (Functions.typ_of_format t)), l
+
+let wrap_call (Functions.C.R(ret, res)) type_builder = begin
+  let returnType = ScTypes.ReturnType.guess_format_result ret type_builder in
+  begin match returnType with
+  | ScTypes.DataFormat.Bool    -> T.observe (T.bool res)
+  | ScTypes.DataFormat.String  -> T.observe (T.str res)
+  | ScTypes.DataFormat.Number  -> T.observe (T.num res)
+  | ScTypes.DataFormat.Date    -> T.observe (T.date res)
+  end
+end
+
+(** Extract the format from a list of results *)
+let build_format_list ll =
+
+  List.map (fun (Result x) ->
+    begin match x with
+      | Bool _         -> ScTypes.DataFormat.F (ScTypes.DataFormat.Bool)
+      | Num (x, _)     -> ScTypes.DataFormat.F x
+      | String _       -> ScTypes.DataFormat.F (ScTypes.DataFormat.String)
+      | List (f, _)    -> ScTypes.DataFormat.F f
+      | Matrix (f, _)  -> ScTypes.DataFormat.F f
+    end
+  ) ll
+
+let value v _ = T.observe v
+
+let ref r (_, mapper) = begin
+  match R.observe r mapper with
+  | R.Value (f, res) -> begin match f with
+    | ScTypes.DataFormat.Bool    -> T.observe (T.bool res)
+    | ScTypes.DataFormat.String  -> T.observe (T.str res)
+    | ScTypes.DataFormat.Number  -> T.observe (T.num res)
+    | ScTypes.DataFormat.Date    -> T.observe (T.date res)
+  end
+  | R.List (t, l) -> Result (List(t, l))
+  | R.Matrix (t, l) -> Result (Matrix(t, l))
+end
+
+let call0 ident (catalog, _) =
+  let name' = UTF8.to_utf8string ident in
+  let arg1 = (Functions.t_unit, ()) in
+  wrap_call
+    (Functions.C.eval1 catalog name' arg1)
+    (fun () -> raise Errors.TypeError)
+
+let call1 ident p1 (catalog, _) =
+  let name' = UTF8.to_utf8string ident in
+  let (Result r1) = p1 in
+  let arg1 = get_argument r1 in
+  wrap_call
+    (Functions.C.eval1 catalog name' arg1)
+    (fun () -> build_format_list [p1])
+
+let call2 ident p1 p2 (catalog, _) =
+  let name' = UTF8.to_utf8string ident in
+  let (Result r1) = p1 in
+  let (Result r2) = p2 in
+  let arg1 = get_argument r1
+  and arg2 = get_argument r2 in
+  wrap_call
+    (Functions.C.eval2 catalog name' arg1 arg2)
+    (fun () -> build_format_list [p1; p2])
+
+let call3 ident p1 p2 p3 (catalog, _) =
+  let name' = UTF8.to_utf8string ident in
+  let (Result r1) = p1 in
+  let (Result r2) = p2 in
+  let (Result r3) = p3 in
+  let arg1 = get_argument r1
+  and arg2 = get_argument r2
+  and arg3 = get_argument r3 in
+  wrap_call
+    (Functions.C.eval3 catalog name' arg1 arg2 arg3)
+    (fun () -> build_format_list [p1; p2 ; p3])
+
+let callN ident params (catalog, _) =
+  let signature = List.map (fun (Result r) ->
+    let formatter = Format.str_formatter in
+    Functions.repr formatter (fst @@ get_argument r);
+    Format.flush_str_formatter ()) params in
+  raise (Errors.Undefined (ident, signature))
+
+let expression e _ = e
+
+let observe repr = begin
+  let Result r = repr in match r with
+  | Bool b ->  ScTypes.Result.Ok (ScTypes.Type.boolean b)
+  | String s -> ScTypes.Result.Ok (ScTypes.Type.string s)
+  | Num (format, n)  ->
+    begin match format with
+      (* We can only match numeric formats here *)
+      | ScTypes.DataFormat.Date -> ScTypes.Result.Ok (ScTypes.Type.date n)
+      | ScTypes.DataFormat.Number -> ScTypes.Result.Ok (ScTypes.Type.number n)
+    end
+  | _ -> raise Errors.TypeError
+
+end
+
-- 
cgit v1.2.3