Review the reference evaluation

2 files changed, 56 insertions, 29 deletions

diff --git a/src/expressions/eval_ref.ml b/src/expressions/eval_ref.ml
index 8463f6c..99b35af 100755
--- a/src/expressions/eval_ref.ml
+++ b/src/expressions/eval_ref.ml
@@ -15,11 +15,22 @@ You should have received a copy of the GNU General Public License
 along with licht.  If not, see <http://www.gnu.org/licenses/>.

 *)

 

-type 'a range =

-  | Single of 'a

-  | Array1 of 'a list

-  | Array2 of 'a list list

 

+(** Contain a valid value from the sheet. This value can be empty if it is not

+yet defined *)

+type value =

+  | V : 'a ScTypes.Type.t -> value

+  | Empty : value

+

+(** This is a snapshot from all the cells in the sheet, the values may be

+defined or not, and are not yet unified *)

+type range =

+  | Single : 'a ScTypes.Type.t -> range

+  | Array1 : value list -> range

+  | Array2 : value list list -> range

+

+(** Result from the computation, the list is unified and the type is now

+identified. The empty elements are defined with a default value. *)

 type content =

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

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

@@ -33,12 +44,16 @@ type content =
 *)

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

 

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

+type 'a t = mapper -> range

 

 type 'a obs = mapper -> content

 

 let cell t mapper = begin

-  Single (mapper (Cell.to_pair t))

+  begin match mapper (Cell.to_pair t) with

+  | None -> raise Errors.TypeError

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

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

+  end

 end

 

 let range fst snd mapper = begin

@@ -53,7 +68,11 @@ let range fst snd mapper = begin
     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

+        begin match mapper (x, y) with

+        | None -> elms := Empty::!elms

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

+        | Some (ScTypes.Result.Ok r) -> elms := (V r)::!elms

+        end

       done

     done;

     Array1 (!elms)

@@ -63,7 +82,11 @@ let range fst snd mapper = begin
     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

+        begin match mapper (x, y) with

+        | None -> elmy := Empty::!elmy

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

+        | Some (ScTypes.Result.Ok r) -> elmy := (V r)::!elmy

+        end

       done;

       elmx := !elmy::!elmx

     done;

@@ -98,13 +121,11 @@ module M = ScTypes.Type.Eval(TypeContent)
     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 =

+let add_elem: type a. a ScTypes.DataFormat.t * a list -> value -> 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) ->

-

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

+  | V 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

@@ -114,33 +135,37 @@ fun (format, elements) result ->
     new_format, element::elements

   end

 

+(** Auxiliary type which does not handle Empty constructor *)

+type value' = V' : 'a ScTypes.Type.t -> value'

+

+let option_of_value v = begin match v with

+  | Empty -> None

+  | V x -> Some (V' x)

+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)) ->

+  | Single 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

+    let TypeContent.Value (format, _) = begin

+      let V' r = Tools.List.find_map option_of_value l in

+      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

+    let TypeContent.Value (format, _) = begin

+      let V' r = Tools.List.find_map2 option_of_value l in

+      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

@@ -149,5 +174,7 @@ let get_content = begin function
     Matrix(format, List.rev values)

   end

 

+(** Collect the data from the references.

 

+If one of the values is an error, the error is thrown as an exception *)

 let observe t mapper = get_content (t mapper)

diff --git a/src/tools.ml b/src/tools.ml
index cfd17cd..c9d78a7 100755
--- a/src/tools.ml
+++ b/src/tools.ml
@@ -61,7 +61,7 @@ module String = struct
       let rem = value lsr 8 in
       match rem with
       | 0 -> Buffer.contents buff
-      | x -> convert x
+      | x -> (convert[@tailcall]) x
     end in
     let res = convert v in
     let buff' = Buffer.create @@ String.length res in
@@ -103,7 +103,7 @@ module List = struct
     | hd::tl ->
         f buffer hd;
         UTF8.Buffer.add_string buffer sep;
-        print tl
+        (print[@tailcall]) tl
     end in
 
     UTF8.Buffer.add_string buffer first;
@@ -123,7 +123,7 @@ module List = struct
   | [] -> raise Not_found
   | x::l ->
     begin try find_map p x with
-    Not_found -> find_map2 p l
+      Not_found -> (find_map2[@tailcall]) p l
     end
   end