From 01d7f77f65c3a2b83978b1f00c87b54f00647816 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Wed, 25 Oct 2017 14:50:32 +0200 Subject: Update sheet traversal --- evaluator.ml | 235 +++++++++++++++++++++++------------------------------------ 1 file changed, 90 insertions(+), 145 deletions(-) (limited to 'evaluator.ml') diff --git a/evaluator.ml b/evaluator.ml index b390771..c17a397 100755 --- a/evaluator.ml +++ b/evaluator.ml @@ -5,16 +5,12 @@ module Data = struct (** Data format *) -type _ dataFormat = - | Date: D.Num.t dataFormat (* Date *) - | Number: D.Num.t dataFormat (* Number *) - | String: UTF8.t dataFormat (* String result, there is only one representation *) - | Bool: D.Bool.t dataFormat (* Boolean result *) +type 'a dataFormat = 'a ScTypes.dataFormat let most_generic_format: type a. a dataFormat -> a dataFormat -> a dataFormat = begin fun a b -> match a, b with - | Number, x -> x - | x, Number -> x + | ScTypes.Number, x -> x + | x, ScTypes.Number -> x | x, _ -> x end @@ -27,13 +23,11 @@ type _ typ = | String: UTF8.t typ | List: 'a typ -> 'a list typ -let typ_of_format: -type a. a dataFormat -> a typ = -function - | Date -> Num - | Number -> Num - | String -> String - | Bool -> Bool +let typ_of_format: type a. a ScTypes.dataFormat -> a typ = function + | ScTypes.Date -> Num + | ScTypes.Number -> Num + | ScTypes.String -> String + | ScTypes.Bool -> Bool let rec compare_typ: type a b. a typ -> b typ -> (a, b) T.cmp = @@ -62,57 +56,35 @@ fun printer typ -> match typ with | List t -> Format.fprintf printer "List[%a]" print_typ t -let default_format_for_type: type a. a typ -> a dataFormat = function - | Num -> Date - | String -> String - | Bool -> Bool +let default_format_for_type: type a. a typ -> a ScTypes.dataFormat = function + | Num -> ScTypes.Date + | String -> ScTypes.String + | Bool -> ScTypes.Bool | List _ -> raise Errors.TypeError | Unit -> raise Errors.TypeError -(** Results format. - Any value which can be encoded with different representation requires as - many format than there are representations for this value. -*) - -type _ result = - | Numeric: D.Num.t result (* Any numeric format : the representation depends from the inputs *) - | Date: D.Num.t result (* Date *) - | Number: D.Num.t result (* Number *) - | String: UTF8.t result (* String result, there is only one representation *) - | Bool: D.Bool.t result (* Boolean result *) +type 'a returnType = 'a ScTypes.returnType -let specialize_result: type a. a result -> a dataFormat -> a result = +let specialize_result: type a. a ScTypes.returnType -> a ScTypes.dataFormat -> a ScTypes.returnType = begin fun a b -> match a, b with - | Date, _ -> Date - | _, Date -> Date + | ScTypes.Num (Some ScTypes.Date) as _1, _ -> _1 + | _, ScTypes.Date -> ScTypes.Num (Some ScTypes.Date) | x, y -> x end -let typ_of_result: type a. a result -> a typ = function - | Numeric -> Num - | Number -> Num - | Date -> Num - | Bool -> Bool - | String -> String - -let rec compare_result: type a b. a result -> b result -> (a, b) T.cmp = begin fun a b -> - match a, b with - | Bool, Bool -> T.Eq - | Numeric, Numeric-> T.Eq - | String, String -> T.Eq - | Number, Number -> T.Eq - | Date, Date -> T.Eq - | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt +let typ_of_result: type a. a ScTypes.returnType -> a typ = function + | ScTypes.Num _ -> Num + | ScTypes.Bool -> Bool + | ScTypes.Str -> String -end (*** Values definitions *) type 'a value = | Bool: D.Bool.t -> D.Bool.t value - | Num: D.Num.t dataFormat * D.Num.t -> D.Num.t value + | Num: D.Num.t ScTypes.dataFormat * D.Num.t -> D.Num.t value | String: UTF8.t -> UTF8.t value - | List: 'a dataFormat * 'a list -> 'a list value - | List2: 'a dataFormat * 'a list list -> 'a list list value + | List: 'a ScTypes.dataFormat * 'a list -> 'a list value + | Matrix: 'a ScTypes.dataFormat * 'a list list -> 'a list list value (** Get the value out of the box *) let get_value_content: type a. a value -> a = function @@ -120,17 +92,7 @@ let get_value_content: type a. a value -> a = function | Num (_, n) -> n | String s -> s | List (t, l) -> l - | List2 (t, l) -> l - -(** Create a value from a known type and an unboxed value *) -let build_value: type a. a dataFormat -> a -> a value = begin fun format content -> - match (typ_of_format format), content with - | Unit, _ -> raise Errors.TypeError - | Bool, x -> Bool x - | Num, x -> Num (format, x) - | String, s -> String s - | List t, l -> raise Errors.TypeError -end + | Matrix (t, l) -> l (* Extract the type from a boxed value *) let type_of_value: type a. a value -> a typ = function @@ -138,54 +100,53 @@ let type_of_value: type a. a value -> a typ = function | Num (n, _) -> Num | String s -> String | List (t, l) -> List (typ_of_format t) - | List2 (t, l) -> List (List (typ_of_format t)) + | Matrix (t, l) -> List (List (typ_of_format t)) -let format_of_value: type a. a value -> a dataFormat = function - | Bool b -> Bool +let format_of_value: type a. a value -> a ScTypes.dataFormat = function + | Bool b -> ScTypes.Bool | Num (f, _) -> f - | String s -> String + | String s -> ScTypes.String | List (t, l) -> raise Errors.TypeError - | List2 (t, l) -> raise Errors.TypeError + | Matrix (t, l) -> raise Errors.TypeError - let inject': - type a. a result -> (unit -> a dataFormat) -> a -> a value = +let inject': + type a. a ScTypes.returnType -> (unit -> a ScTypes.dataFormat) -> a -> a value = fun resultFormat f res -> begin match resultFormat, res with - | Bool, x -> Bool x - | Numeric, x -> Num (f (), x) - | Date, x -> Num(Date, x) - | Number, x -> Num(Number, x) - | String, s -> String s + | ScTypes.Bool, x -> Bool x + | ScTypes.Str, s -> String s + | ScTypes.Num None, x -> Num (f (), x) + | ScTypes.Num (Some v), x -> Num(v, x) end -let compare_format: type a b. a typ -> a result -> b value -> a result = begin +let compare_format: type a b. a typ -> a ScTypes.returnType -> b value -> a ScTypes.returnType = begin fun init_typ currentResult value -> -(* If the argument as the same type as the result format, just the most specialized *) -match compare_typ init_typ (type_of_value value) with - | T.Eq -> begin match value with - | Bool b -> Bool - | String s -> String - | Num (f, v) -> specialize_result currentResult f - (* There is no possibility to get init_typ as List typ*) - | List (f, v) -> raise Errors.TypeError - | List2 (f, v) -> raise Errors.TypeError - end - (* The types differ, handle the special cases for Lists *) - | _ -> - begin match value with - | List (f, v) -> - begin match compare_typ init_typ (typ_of_format f) with - | T.Eq -> specialize_result currentResult f - | _ -> currentResult + (* If the argument as the same type as the result format, just select the most specialized *) + match compare_typ init_typ (type_of_value value) with + | T.Eq -> begin match value with + | Bool b -> ScTypes.Bool + | String s -> ScTypes.Str + | Num (f, v) -> specialize_result currentResult f + (* There is no possibility to get init_typ as List typ*) + | List (f, v) -> raise Errors.TypeError + | Matrix (f, v) -> raise Errors.TypeError end - | List2 (f, v) -> - begin match compare_typ init_typ (typ_of_format f) with - | T.Eq -> specialize_result currentResult f + (* The types differ, handle the special cases for Lists *) + | _ -> + begin match value with + | List (f, v) -> + begin match compare_typ init_typ (typ_of_format f) with + | T.Eq -> specialize_result currentResult f + | _ -> currentResult + end + | Matrix (f, v) -> + begin match compare_typ init_typ (typ_of_format f) with + | T.Eq -> specialize_result currentResult f + | _ -> currentResult + end | _ -> currentResult end - | _ -> currentResult - end -end + end end @@ -201,28 +162,27 @@ type existencialResult = The most specialized format take over the others. *) let guess_format_result: -type a. a Data.result -> existencialResult list -> unit -> a Data.dataFormat = +type a. a ScTypes.returnType -> existencialResult list -> unit -> a Data.dataFormat = begin fun init_value values () -> let init_typ:a Data.typ = Data.typ_of_result init_value in (* fold over the arguments, and check if they have the same format *) - let compare_format: a Data.result -> existencialResult -> a Data.result = + let compare_format: a ScTypes.returnType -> existencialResult -> a ScTypes.returnType = fun currentResult (Result value) -> Data.compare_format init_typ currentResult value in begin match List.fold_left compare_format init_value values with - | Data.String -> Data.String - | Data.Bool -> Data.Bool - | Data.Number -> Data.Number - | Data.Date -> Data.Date - | Data.Numeric -> Data.Number + | ScTypes.Str -> ScTypes.String + | ScTypes.Bool -> ScTypes.Bool + | ScTypes.Num None-> ScTypes.Number + | ScTypes.Num (Some x)-> x end end let inject: -type a. a Data.result -> (unit -> a Data.dataFormat) -> a -> existencialResult = +type a. a Data.returnType -> (unit -> a Data.dataFormat) -> a -> existencialResult = fun resultFormat f res -> let (x:a Data.value) = Data.inject' resultFormat f res in Result x @@ -242,7 +202,6 @@ let register3 name (typ1, typ2, typ3) result f = let call name args = begin let name' = UTF8.to_utf8string name in begin try match args with - | [] -> let C.Fn1(ret, f) = C.find_function !catalog name' (C.T1 Data.Unit) in inject ret (fun () -> raise Errors.TypeError) (f ()) @@ -278,19 +237,19 @@ let repr mapper value = begin (** Extract the value from a raw type. If the value is Undefined, raise an exception. *) - let extract_value = begin function - | ScTypes.Num (n,s) -> Result (Data.Num (Data.Number, (D.Num.of_num n))) - | ScTypes.Bool b -> Result (Data.Bool b) - | ScTypes.Date d -> Result (Data.Num (Data.Date, (D.Num.of_num d))) - | ScTypes.Str s -> Result (Data.String s) + let extract_value : ScTypes.result -> existencialResult = begin function + | ScTypes.Result (ScTypes.Num (f, n)) -> Result (Data.Num (f, n)) + | ScTypes.Result (ScTypes.Bool b) -> Result (Data.Bool b) + | ScTypes.Result (ScTypes.Str s) -> Result (Data.String s) + | ScTypes.Error x -> raise x end in - let add_elem: type a. a Data.typ -> a list * a Data.dataFormat -> ScTypes.types option -> a list * a Data.dataFormat = + let add_elem: type a. a Data.typ -> a list * a Data.dataFormat -> ScTypes.result option -> a list * a Data.dataFormat = begin fun type_of (result, format_of) next -> let Result r = match next with | Some x -> extract_value x | None -> begin match type_of with - | Data.Num -> Result (Data.Num (Data.Number, (D.Num.nan))) + | Data.Num -> Result (Data.Num (ScTypes.Number, D.Num.nan)) | Data.Bool -> Result (Data.Bool false) | Data.String -> Result (Data.String (UTF8.empty)) | Data.List x -> Result (Data.List ((Data.default_format_for_type x), [])) @@ -304,26 +263,6 @@ let repr mapper value = begin end end in - (* Return the result for any expression as an ScTypes.types result *) - let rec get_repr: type a. a Data.value -> ScTypes.types = begin function - | Data.Bool b -> ScTypes.Bool b - | Data.Num (format, n) -> begin match format with - | Data.Number -> ScTypes.Num (D.Num.to_num n, None) - | Data.Date -> ScTypes.Date (D.Num.to_num n) - | _ -> raise Errors.TypeError (* This pattern could be refuted *) - end - | Data.String s -> ScTypes.Str s - | Data.List (t, l) -> - List.hd l (* Extract the first element *) - |> Data.build_value t (* Convert it in boxed value *) - |> get_repr (* Return it's representation *) - | Data.List2 (t, l) -> - List.hd l (* Extract the first element *) - |> List.hd - |> Data.build_value t (* Convert it in boxed value *) - |> get_repr (* Return it's representation *) - end in - (** Extract the value from an expression. [extract typ expr] will evaluate the expression and return it. If the result cannot be evaluated (because of references pointing to missing @@ -357,19 +296,25 @@ let repr mapper value = begin let elems, format = List.fold_left (add_elem type_of) ([], format_of) elems in elems::result, (Data.most_generic_format format_of format) ) ([], format_of) l in - Result (Data.List2 (format, elems)) + Result (Data.Matrix (format, elems)) end (* Evaluate the expression *) | ScTypes.Expression e -> extract e - | ScTypes.Value v -> extract_value v + | ScTypes.Value v -> extract_value (ScTypes.Result v) | ScTypes.Call (name, args) -> let args' = List.map extract args in call name args' end in - let Result r = extract value in - get_repr r + let Result r = (extract value) in + + begin match r with + | Data.Bool b -> ScTypes.Result (ScTypes.Bool b) + | Data.Num (format, n) -> ScTypes.Result (ScTypes.Num (format, n)) + | Data.String s -> ScTypes.Result (ScTypes.Str s) + | _ -> raise Errors.TypeError + end end let wrap f = @@ -380,13 +325,13 @@ let wrap f = (* Register the standard functions *) -type 'a result = 'a Data.result +type 'a returnType = 'a ScTypes.returnType -let f_num: DataType.Num.t Data.result = Data.Numeric -let f_date: DataType.Num.t Data.result = Data.Date -let f_number: DataType.Num.t Data.result = Data.Number -let f_string: DataType.String.t Data.result = Data.String -let f_bool: DataType.Bool.t Data.result = Data.Bool +let f_num = ScTypes.f_num +let f_date = ScTypes.f_date +let f_number = ScTypes.f_number +let f_string = ScTypes.f_string +let f_bool = ScTypes.f_bool module Make_Compare(C: D.COMPARABLE) = struct @@ -468,7 +413,7 @@ let () = begin (* Build a date *) register3 "date" (t_int, t_int, t_int) f_date ( fun year month day -> - Tools.Date.get_julian_day + Date.get_julian_day (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num year) (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num month) (Num.int_of_num @@ Num.floor_num @@ D.Num.to_num day) -- cgit v1.2.3 From d8ed0babfa1c03c8f1968443a465972bb3bf460c Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Tue, 31 Oct 2017 15:59:38 +0100 Subject: Merged Evaluator types with ScTypes --- evaluator.ml | 11 +++++------ expression.ml | 4 ++-- sheet.ml | 7 +------ 3 files changed, 8 insertions(+), 14 deletions(-) (limited to 'evaluator.ml') diff --git a/evaluator.ml b/evaluator.ml index c17a397..f2a49d9 100755 --- a/evaluator.ml +++ b/evaluator.ml @@ -280,8 +280,8 @@ let repr mapper value = begin | ScTypes.Refs.Array1 l -> (* Guess the list type from it's first defined element *) let Result r = extract_value (Tools.List.find_map (fun x -> x) l) in - let format_of = Data.format_of_value r in - let type_of = Data.type_of_value r in + let format_of = Data.format_of_value r + and type_of = Data.type_of_value r in (* Build the list with all the elements *) let elems, format = List.fold_left (add_elem type_of) ([], format_of) l in Result (Data.List (format, elems)) @@ -289,13 +289,13 @@ let repr mapper value = begin (* Guess the list type from it's first defined element *) let Result r = extract_value (Tools.List.find_map2 (fun x -> x) l) in - let format_of = Data.format_of_value r in - let type_of = Data.type_of_value r in + let format_of = Data.format_of_value r + and type_of = Data.type_of_value r in (* Build the list with all the elements *) let elems, format = List.fold_left (fun (result, format_of) elems -> let elems, format = List.fold_left (add_elem type_of) ([], format_of) elems in elems::result, (Data.most_generic_format format_of format) - ) ([], format_of) l in + ) ([], format_of) l in Result (Data.Matrix (format, elems)) end @@ -308,7 +308,6 @@ let repr mapper value = begin end in let Result r = (extract value) in - begin match r with | Data.Bool b -> ScTypes.Result (ScTypes.Bool b) | Data.Num (format, n) -> ScTypes.Result (ScTypes.Num (format, n)) diff --git a/expression.ml b/expression.ml index c61131e..31b6369 100755 --- a/expression.ml +++ b/expression.ml @@ -35,8 +35,8 @@ let load content = begin with Not_found -> content in try let ScTypes.Result r = - Lexing.from_string content' - |> ExpressionParser.content ExpressionLexer.read in + ExpressionParser.content ExpressionLexer.read + @@ Lexing.from_string content' in Basic r with _ -> Basic (ScTypes.Str (UTF8.from_utf8string content')) ) diff --git a/sheet.ml b/sheet.ml index 241039e..67b1ee1 100755 --- a/sheet.ml +++ b/sheet.ml @@ -50,13 +50,8 @@ module Raw = struct *) let get_ref from t ref : ScTypes.result option ScTypes.Refs.range = begin - let extract_values = begin function - | ScTypes.Error e -> raise e - | v -> v - end in - ScTypes.Refs.collect ref - |> ScTypes.Refs.map (fun coord -> Option.map extract_values (get_value coord t)) + |> ScTypes.Refs.map (fun coord -> get_value coord t) end -- cgit v1.2.3