aboutsummaryrefslogtreecommitdiff
path: root/src/expressions
diff options
context:
space:
mode:
authorSébastien Dailly <sebastien@chimrod.com>2018-01-31 13:20:20 +0100
committerSébastien Dailly <sebastien@chimrod.com>2018-02-07 13:42:36 +0100
commit824f2987d47e87d58ee2a4a96d7be417aad6aeab (patch)
treebfbaca8d1c13a2eb1e5568f363cdcd6c94f1786f /src/expressions
parent112ab4b1c396fc2117191297227d8e411f9b9bb3 (diff)
API refactoring : made the GADT abstract, provide contructor for each case, and deported the
expression with evaluation with module functors
Diffstat (limited to 'src/expressions')
-rwxr-xr-xsrc/expressions/collect_sources.ml69
-rwxr-xr-xsrc/expressions/eval_ref.ml136
-rwxr-xr-xsrc/expressions/evaluate.ml142
-rwxr-xr-xsrc/expressions/show_expr.ml62
-rwxr-xr-xsrc/expressions/show_ref.ml11
-rwxr-xr-xsrc/expressions/show_type.ml26
-rwxr-xr-xsrc/expressions/sym_expr.ml31
-rwxr-xr-xsrc/expressions/sym_ref.ml12
-rwxr-xr-xsrc/expressions/sym_type.ml18
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
+