API refactoring : made the GADT abstract, provide contructor for each case, and deported the

expression with evaluation with module functors

9 files changed, 507 insertions, 0 deletions

diff --git a/src/expressions/collect_sources.ml b/src/expressions/collect_sources.ml
new file mode 100755
index 0000000..d898b86
--- /dev/null
+++ b/src/expressions/collect_sources.ml
@@ -0,0 +1,69 @@
+module T = struct

+

+  type 'a t = unit

+

+  type 'a obs = ('a -> 'a)

+

+  let str s = ()

+

+  let num n = ()

+

+  let date d = ()

+

+  let bool b = ()

+

+  let observe () x = x

+

+end

+

+module R = struct

+

+  type 'a obs = Cell.Set.t -> Cell.Set.t

+

+  type 'a t = 'a obs

+

+  let cell (c:Cell.t) set = Cell.Set.add (Cell.to_pair c) set

+

+  let range c1 c2 set = begin

+

+    let x1, y1 = Cell.to_pair c1

+    and x2, y2 = Cell.to_pair c2 in

+

+    let f_x x acc = begin

+      let f_y y acc = begin

+        Cell.Set.add (x, y) acc

+      end in

+      Tools.fold_for f_y y1 y2 acc

+    end in

+    Tools.fold_for f_x x1 x2 set

+  end

+

+  let observe elem set = elem set

+

+

+end

+

+let observe f value = f value

+

+let value v () = T.observe v

+

+let ref r () = R.observe r

+

+let call0 ident () acc = acc

+

+let call1 ident p1 () acc = observe p1 acc

+

+let call2 ident p1 p2 () acc = observe p2 (observe p1 acc)

+

+let call3 ident p1 p2 p3 () acc = observe p3 (observe p2 (observe p1 acc))

+

+let callN ident params () acc = List.fold_left (fun acc p -> observe p acc) acc params

+

+let expression e () = e

+

+type obs =  Cell.Set.t -> Cell.Set.t

+

+type t = unit

+

+type repr = obs

+

diff --git a/src/expressions/eval_ref.ml b/src/expressions/eval_ref.ml
new file mode 100755
index 0000000..d367d2d
--- /dev/null
+++ b/src/expressions/eval_ref.ml
@@ -0,0 +1,136 @@
+type 'a range =

+  | Single of 'a

+  | Array1 of 'a list

+  | Array2 of 'a list list

+

+type content =

+  | Value:  'a ScTypes.DataFormat.t * 'a -> content

+  | List:   'a ScTypes.DataFormat.t * 'a list -> content

+  | Matrix: 'a ScTypes.DataFormat.t * 'a list list -> content

+

+(** Type for the mapper function.

+

+  This function should be able to read the cell from the spreadsheet from

+  it coordinates, and return the associated value.

+

+*)

+type mapper = (int * int -> ScTypes.Result.t option)

+

+type 'a t = mapper -> ScTypes.Result.t option range

+

+type 'a obs = mapper -> content

+

+let cell t mapper = begin

+  Single (mapper (Cell.to_pair t))

+end

+

+let range fst snd mapper = begin

+  let (x1, y1) = Cell.to_pair fst

+  and (x2, y2) = Cell.to_pair snd in

+  let min_x = min x1 x2

+  and max_x = max x1 x2

+  and min_y = min y1 y2

+  and max_y = max y1 y2 in

+  if (min_x = max_x) || (min_y = max_y) then (

+    (* There is only a one dimension array *)

+    let elms = ref [] in

+    for x = min_x to max_x do

+      for y = min_y to max_y do

+        elms := (mapper (x, y))::!elms

+      done

+    done;

+    Array1 (!elms)

+  ) else (

+    (* This a two-dimension array *)

+    let elmx = ref [] in

+    for x = min_x to max_x do

+      let elmy = ref [] in

+      for y = min_y to max_y do

+        elmy := (mapper (x, y))::!elmy

+      done;

+      elmx := !elmy::!elmx

+    done;

+    Array2 (!elmx)

+  )

+end

+

+module TypeContent = struct

+

+  type 'a t = 'a ScTypes.DataFormat.t * 'a

+

+  type value  = Value: ('a ScTypes.DataFormat.t * 'a) -> value [@@unboxed]

+

+  type 'a obs = value

+

+  let str s = (ScTypes.DataFormat.String, s)

+

+  let bool b = (ScTypes.DataFormat.Bool, b)

+

+  let num n : DataType.Num.t t = (ScTypes.DataFormat.Number, n)

+

+  let date d : DataType.Num.t t = (ScTypes.DataFormat.Date, d)

+

+  let observe (f, t) = Value (f, t)

+

+end

+

+module M = ScTypes.Type.Eval(TypeContent)

+

+(** Add one element in a typed list.

+

+    The function will raise Error.TypeError if the elements does not match

+    with the list type.

+*)

+let add_elem: type a b. a ScTypes.DataFormat.t * a list -> ScTypes.Result.t option -> a ScTypes.DataFormat.t * a list =

+fun (format, elements) result ->

+  begin match result with

+  | None -> format, (ScTypes.DataFormat.default_value_for format)::elements

+  | Some (ScTypes.Result.Error x) -> raise x

+  | Some (ScTypes.Result.Ok r) ->

+

+    let TypeContent.Value (format', element) = M.eval r in

+    let ScTypes.DataFormat.Eq = ScTypes.DataFormat.compare_format format format' in

+    let new_format = if (ScTypes.DataFormat.priority format) > (ScTypes.DataFormat.priority format') then

+        format

+      else

+        format' in

+    new_format, element::elements

+  end

+

+(** extract the content from a range.

+

+      May raise Errors.TypeError if the range cannot be unified.

+  *)

+let get_content = begin function

+  | Single None -> raise Errors.TypeError

+  | Single (Some (ScTypes.Result.Error x)) -> raise x

+  | Single (Some (ScTypes.Result.Ok r)) ->

+    let TypeContent.Value (format, element) = M.eval r in

+    Value (format, element)

+  | Array1 l ->

+    (* Get the first element in the list in order to get the format *)

+    let TypeContent.Value (format, _) =

+      begin match (Tools.List.find_map (fun x -> x) l) with

+      | ScTypes.Result.Error x -> raise x

+      | ScTypes.Result.Ok r -> M.eval r

+      end in

+    (* Then build an unified list (if we can) *)

+    let format, values =  List.fold_left add_elem (format, []) l in

+    List(format, List.rev values)

+  | Array2 l ->

+    (* Get the first element in the list *)

+    let TypeContent.Value (format, _) =

+      begin match (Tools.List.find_map2 (fun x -> x) l) with

+      | ScTypes.Result.Error x -> raise x

+      | ScTypes.Result.Ok r -> M.eval r

+      end in

+    (* Then build an unified list *)

+    let format, values =  List.fold_left (fun (format, result) elems ->

+        let format, elems = List.fold_left add_elem (format, []) elems in

+        (format, List.rev (elems::result))

+      )(format, []) l in

+    Matrix(format, List.rev values)

+  end

+

+

+let observe t mapper = get_content (t mapper)

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

+

diff --git a/src/expressions/show_expr.ml b/src/expressions/show_expr.ml
new file mode 100755
index 0000000..3a54929
--- /dev/null
+++ b/src/expressions/show_expr.ml
@@ -0,0 +1,62 @@
+let u = UTF8.from_utf8string

+

+module Show_Expr

+  (R:Sym_ref.SYM_REF with type 'a obs = (UTF8.Buffer.buffer -> unit))

+  (T:Sym_type.SYM_TYPE with type 'a obs = (UTF8.Buffer.buffer -> unit)) = struct

+

+  module T = T

+  module R = R

+

+  type t = unit

+  type repr = UTF8.Buffer.buffer -> unit

+  type obs = UTF8.Buffer.buffer -> unit

+

+  let observe buffer value = buffer value

+

+  let value v () buffer = T.observe v buffer

+

+  let ref r () buffer = R.observe r buffer

+

+  let call0 ident () buffer =

+    let utf8ident = UTF8.to_utf8string ident in

+    UTF8.Printf.bprintf buffer "%s()" utf8ident

+

+  let call1 ident p1 () buffer =

+    let utf8ident = UTF8.to_utf8string ident in

+    UTF8.Printf.bprintf buffer "%s(%a)"

+      utf8ident

+      (fun x b -> observe b x) p1

+

+  let call2 ident p1 p2 () buffer =

+    let utf8ident = UTF8.to_utf8string ident in

+    begin match utf8ident with

+    | "+" | "*" | "-" | "/" | "^" | "="

+    | "<>" | "<=" | ">=" | "<" | ">" ->

+        UTF8.Printf.bprintf buffer "%a%s%a"

+        (fun x b -> observe b x) p1

+          utf8ident

+        (fun x b -> observe b x) p2

+    | _ ->

+      UTF8.Printf.bprintf buffer "%s(%a;%a)"

+        utf8ident

+        (fun x b -> observe b x) p1

+        (fun x b -> observe b x) p2

+    end

+

+  let call3 ident p1 p2 p3 () buffer =

+    let utf8ident = UTF8.to_utf8string ident in

+    UTF8.Printf.bprintf buffer "%s(%a;%a;%a)"

+      utf8ident

+      (fun x b -> observe b x) p1

+      (fun x b -> observe b x) p2

+      (fun x b -> observe b x) p3

+

+  let callN ident (params: repr list) () buffer =

+    UTF8.Buffer.add_string buffer ident;

+    Tools.List.printb ~sep:(u";") (fun buffer value -> value buffer) buffer params

+

+  let expression e () buffer =

+    UTF8.Printf.bprintf buffer "(%a)"

+    (fun x b -> b x) e

+

+end

diff --git a/src/expressions/show_ref.ml b/src/expressions/show_ref.ml
new file mode 100755
index 0000000..97d8022
--- /dev/null
+++ b/src/expressions/show_ref.ml
@@ -0,0 +1,11 @@
+type 'a t = UTF8.Buffer.buffer -> unit

+

+type 'a obs = UTF8.Buffer.buffer -> unit

+

+let cell t buffer =

+  UTF8.Buffer.add_string buffer @@ Cell.to_string t

+

+let range c1 c2 buffer =

+  Tools.Tuple2.printb ~first:"" ~last:"" ~sep:":" Cell.to_buffer Cell.to_buffer buffer (c1, c2)

+

+let observe elem buffer = elem buffer

diff --git a/src/expressions/show_type.ml b/src/expressions/show_type.ml
new file mode 100755
index 0000000..c459dca
--- /dev/null
+++ b/src/expressions/show_type.ml
@@ -0,0 +1,26 @@
+type 'a t = UTF8.Buffer.buffer -> unit

+type 'a obs = UTF8.Buffer.buffer -> unit

+

+let str s buffer =

+  UTF8.Buffer.add_string buffer s

+

+let num n buffer =

+  if DataType.Num.is_integer n then

+    DataType.Num.to_int n

+      |> string_of_int

+      |> UTF8.from_utf8string

+      |> UTF8.Buffer.add_string buffer

+  else

+    let f = DataType.Num.to_float n

+    and to_b = UTF8.Format.formatter_of_buffer buffer in

+    ignore @@ UTF8.Format.fprintf to_b "%.2f" f;

+    Format.pp_print_flush to_b ()

+

+let date n buffer =

+  let y, m, d = DataType.Date.date_from_julian_day n in

+  UTF8.Printf.bprintf buffer "%d/%d/%d" y m d

+

+let bool b buffer =

+  UTF8.Printf.bprintf buffer "%B" b

+

+let observe elem buffer = elem buffer

diff --git a/src/expressions/sym_expr.ml b/src/expressions/sym_expr.ml
new file mode 100755
index 0000000..5ff828e
--- /dev/null
+++ b/src/expressions/sym_expr.ml
@@ -0,0 +1,31 @@
+module type SYM_EXPR = sig

+

+  module T:Sym_type.SYM_TYPE

+

+  module R:Sym_ref.SYM_REF

+

+  type t

+

+  type repr

+

+  type obs

+

+  val value : 'a T.t -> t -> repr

+

+  val ref : 'a R.t -> t -> repr

+

+  val call0 : UTF8.t -> t -> repr

+

+  val call1 : UTF8.t -> repr -> t -> repr

+

+  val call2 : UTF8.t -> repr -> repr -> t -> repr

+

+  val call3 : UTF8.t -> repr -> repr -> repr -> t -> repr

+

+  val callN: UTF8.t -> repr list -> t -> repr

+

+  val expression : repr -> t -> repr

+

+  val observe : repr -> obs

+

+end

diff --git a/src/expressions/sym_ref.ml b/src/expressions/sym_ref.ml
new file mode 100755
index 0000000..aba8053
--- /dev/null
+++ b/src/expressions/sym_ref.ml
@@ -0,0 +1,12 @@
+module type SYM_REF = sig

+

+  type 'a t

+

+  type 'a obs

+

+  val cell : Cell.t -> 'a t

+

+  val range : Cell.t -> Cell.t -> 'a t

+

+  val observe : 'a t -> 'a obs

+end

diff --git a/src/expressions/sym_type.ml b/src/expressions/sym_type.ml
new file mode 100755
index 0000000..31c9534
--- /dev/null
+++ b/src/expressions/sym_type.ml
@@ -0,0 +1,18 @@
+module type SYM_TYPE = sig

+

+  type 'a t

+

+  type 'a obs

+

+  val str :  DataType.String.t -> DataType.String.t t

+

+  val num :  DataType.Num.t -> DataType.Num.t t

+

+  val date:  DataType.Num.t -> DataType.Num.t t

+

+  val bool : DataType.Bool.t -> DataType.Bool.t t

+

+  val observe : 'a t -> 'a obs

+

+end

+