Update expression evaluation

6 files changed, 156 insertions, 74 deletions

diff --git a/src/expressions/collect_sources.ml b/src/expressions/collect_sources.ml
index 32b40be..9698057 100755..100644
--- a/src/expressions/collect_sources.ml
+++ b/src/expressions/collect_sources.ml
@@ -29,7 +29,7 @@ module T = struct
 

   let bool b = ()

 

-  let observe () x = x

+  let observe : unit -> 'a -> 'a = fun () x -> x

 

 end

 

@@ -39,7 +39,8 @@ module R = struct
 

   type 'a t = 'a obs

 

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

+  let cell : Cell.t -> Cell.Set.t -> Cell.Set.t =

+    fun c set -> Cell.Set.add (Cell.to_pair c) set

 

   let range c1 c2 set = begin

 

@@ -60,27 +61,25 @@ module R = struct
 

 end

 

-let observe f value = f value

-

-let value v () = T.observe v

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

 

-let ref r () = R.observe r

+type t = obs

 

-let call0 ident () acc = acc

+let observe (f:obs) (value :Cell.Set.t) = f value

 

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

+let value v acc = T.observe v acc

 

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

+let ref r acc = R.observe r acc

 

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

+let call0 ident acc = acc

 

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

+let call1 ident p1 acc = observe p1 acc

 

-let expression e () = e

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

 

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

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

 

-type t = unit

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

 

-type repr = obs

+let expression e acc = e acc

 

diff --git a/src/expressions/evaluate.ml b/src/expressions/evaluate.ml
index ff44097..fbf2a18 100755..100644
--- a/src/expressions/evaluate.ml
+++ b/src/expressions/evaluate.ml
@@ -26,12 +26,6 @@ type 'a 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

@@ -50,6 +44,12 @@ module T:Sym_type.SYM_TYPE with type 'a obs = existencialResult = struct
 

 end

 

+type dic = (Functions.C.t * (int * int -> ScTypes.Result.t option))

+

+type t = dic -> existencialResult

+

+type obs = dic -> ScTypes.Result.t

+

 module R = Eval_ref

 

 (** Extract the type and the content from a value *)

@@ -97,63 +97,67 @@ let ref r (_, mapper) = begin
   | R.Matrix (t, l) -> Result (Matrix(t, l))

 end

 

+let observe repr catalog = begin

+  let Result r = repr catalog 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

+

+let expression e = e

+

 let call0 ident (catalog, _) =

   let name' = UTF8.to_utf8string ident in

-  let arg1 = (Functions.t_unit, ()) in

+  let (arg1:(unit Functions.C.argument * unit)) = (Functions.t_unit, ()) in

   wrap_call

     (Functions.C.eval1 catalog name' arg1)

     (fun () -> raise Errors.TypeError)

 

-let call1 ident p1 (catalog, _) =

+let call1 ident p1 ((catalog, _) as c) =

   let name' = UTF8.to_utf8string ident in

-  let (Result r1) = p1 in

+  (* Evaluate here p1 expression *)

+  let (Result r1) = p1 c in

   let arg1 = get_argument r1 in

   wrap_call

     (Functions.C.eval1 catalog name' arg1)

-    (fun () -> build_format_list [p1])

+    (fun () -> build_format_list [Result r1])

 

-let call2 ident p1 p2 (catalog, _) =

+let call2 ident p1 p2 ((catalog, _) as c) =

   let name' = UTF8.to_utf8string ident in

-  let (Result r1) = p1 in

-  let (Result r2) = p2 in

+  let (Result r1) = p1 c in

+  let (Result r2) = p2 c 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])

+    (fun () -> build_format_list [Result r1; Result r2])

 

-let call3 ident p1 p2 p3 (catalog, _) =

+let call3 ident p1 p2 p3 ((catalog, _) as c) =

   let name' = UTF8.to_utf8string ident in

-  let (Result r1) = p1 in

-  let (Result r2) = p2 in

-  let (Result r3) = p3 in

+  let (Result r1) = p1 c in

+  let (Result r2) = p2 c in

+  let (Result r3) = p3 c 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])

+    (fun () -> build_format_list [Result r1; Result r2; Result r3])

 

-let callN ident params (catalog, _) =

-  let signature = List.map (fun (Result r) ->

+let callN ident params ((catalog, _) as c) =

+

+  let map_params expression = begin

+    let (Result r) = expression c in

     let formatter = Format.str_formatter in

     Functions.repr formatter (fst @@ get_argument r);

-    Format.flush_str_formatter ()) params in

+    Format.flush_str_formatter ()

+  end in

+  let signature = List.map map_params 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/id_type.ml b/src/expressions/id_type.ml
new file mode 100644
index 0000000..d84ddfa
--- /dev/null
+++ b/src/expressions/id_type.ml
@@ -0,0 +1,15 @@
+type 'a t = 'a ScTypes.Type.t

+

+type 'a obs = 'a ScTypes.Type.t

+

+let str s = ScTypes.Type.string s

+

+let num n = ScTypes.Type.number n

+

+let date d = ScTypes.Type.date d

+

+let bool b = ScTypes.Type.boolean b

+

+let observe x = x

+

+

diff --git a/src/expressions/shift_expr.ml b/src/expressions/shift_expr.ml
new file mode 100644
index 0000000..17cce95
--- /dev/null
+++ b/src/expressions/shift_expr.ml
@@ -0,0 +1,67 @@
+(*

+This file is part of licht.

+

+licht is free software: you can redistribute it and/or modify

+it under the terms of the GNU General Public License as published by

+the Free Software Foundation, either version 3 of the License, or

+(at your option) any later version.

+

+licht is distributed in the hope that it will be useful,

+but WITHOUT ANY WARRANTY; without even the implied warranty of

+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

+GNU General Public License for more details.

+

+You should have received a copy of the GNU General Public License

+along with licht.  If not, see <http://www.gnu.org/licenses/>.

+*)

+

+module Shift_Ref = struct

+

+  type 'a t = (int * int) -> ScTypes.Refs.t

+  type 'a obs = (int * int) -> ScTypes.Refs.t

+

+  let _shift (vector_x, vector_y) ((x, y), (fixed_x, fixed_y)) =

+    let x' = if fixed_x then x else x + vector_x

+    and y' = if fixed_y then y else y + vector_y in

+      (x', y'), (fixed_x, fixed_y)

+

+  let cell t shift =

+    ScTypes.Refs.cell (_shift shift t)

+

+

+  let range c1 c2 shift =

+    ScTypes.Refs.range (_shift shift c1) (_shift shift c2)

+

+  let observe elem shift = elem shift

+

+end

+

+module Shift_Expr = struct

+

+  type t = (int * int) -> ScTypes.Expr.t

+  type obs =  (int * int) -> ScTypes.Expr.t

+

+  module R = Shift_Ref

+  module T = Id_type

+

+  let observe f x = f x

+

+  let value t vector = ScTypes.Expr.value (T.observe t)

+

+  let ref r vector = ScTypes.Expr.ref (R.observe r vector)

+

+  let call0 ident vector = ScTypes.Expr.call0 ident

+

+  let call1 ident p1 vector = ScTypes.Expr.call1 ident (observe p1 vector)

+

+  let call2 ident p1 p2 vector = ScTypes.Expr.call2  ident (observe p1 vector) (observe p2 vector)

+

+  let call3 ident p1 p2 p3 vector = ScTypes.Expr.call3 ident (observe p1 vector) (observe p2 vector) (observe p3 vector)

+

+  let expression e vector = ScTypes.Expr.expression (observe e vector)

+

+  let callN ident (params: t list) vector = ScTypes.Expr.callN ident (List.map (fun x -> observe x vector) params)

+

+end

+

+include Shift_Expr

diff --git a/src/expressions/show_expr.ml b/src/expressions/show_expr.ml
index c283162..a191d2d 100755..100644
--- a/src/expressions/show_expr.ml
+++ b/src/expressions/show_expr.ml
@@ -24,27 +24,26 @@ module Show_Expr
   module T = T

   module R = R

 

-  type t = unit

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

+  type t = 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 value v buffer = T.observe v buffer

 

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

+  let ref r buffer = R.observe r buffer

 

-  let call0 ident () buffer =

+  let call0 ident buffer =

     let utf8ident = UTF8.to_utf8string ident in

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

 

-  let call1 ident p1 () buffer =

+  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 call2 ident p1 p2 buffer =

     let utf8ident = UTF8.to_utf8string ident in

     begin match utf8ident with

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

@@ -60,7 +59,7 @@ module Show_Expr
         (fun x b -> observe b x) p2

     end

 

-  let call3 ident p1 p2 p3 () buffer =

+  let call3 ident p1 p2 p3 buffer =

     let utf8ident = UTF8.to_utf8string ident in

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

       utf8ident

@@ -68,11 +67,11 @@ module Show_Expr
       (fun x b -> observe b x) p2

       (fun x b -> observe b x) p3

 

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

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

     UTF8.Buffer.add_string buffer ident;

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

 

-  let expression e () buffer =

+  let expression e buffer =

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

     (fun x b -> b x) e

 

diff --git a/src/expressions/sym_expr.ml b/src/expressions/sym_expr.ml
index 4f5d6a6..843b8a4 100755..100644
--- a/src/expressions/sym_expr.ml
+++ b/src/expressions/sym_expr.ml
@@ -23,26 +23,24 @@ module type SYM_EXPR = sig
 

   type t

 

-  type repr

-

   type obs

 

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

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

 

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

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

 

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

+  val call0 : UTF8.t -> t

 

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

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

 

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

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

 

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

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

 

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

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

 

-  val expression : repr -> t -> repr

+  val expression : t -> t

 

-  val observe : repr -> obs

+  val observe : t -> obs

 

 end