From 83a783f652dff960a0c6e15f94f1fc496813d998 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Tue, 13 Feb 2018 13:39:55 +0100 Subject: Review the reference evaluation --- src/expressions/eval_ref.ml | 79 ++++++++++++++++++++++++++++++--------------- src/tools.ml | 6 ++-- 2 files changed, 56 insertions(+), 29 deletions(-) (limited to 'src') 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 . *) -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 -- cgit v1.2.3