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 --- UTF8.ml | 12 ++ UTF8.mli | 10 +- catalog.ml | 8 +- catalog.mli | 10 +- date.ml | 2 +- evaluator.ml | 235 +++++++++++++-------------------- evaluator.mli | 22 +-- expression.ml | 19 +-- expression.mli | 8 +- expressionParser.mly | 45 ++++--- odf/odf.ml | 42 +++--- odf/odf_ExpressionParser.mly | 5 +- scTypes.ml | 104 ++++++++++----- scTypes.mli | 64 +++++++-- sheet.ml | 41 +++--- tests/expressionParser_test.ml | 9 +- tests/expression_test.ml | 29 ++-- tests/odf/odf_ExpressionParser_test.ml | 11 +- tests/sheet_test.ml | 11 +- tools.ml | 6 - 20 files changed, 391 insertions(+), 302 deletions(-) diff --git a/UTF8.ml b/UTF8.ml index 4fa5eca..fa02040 100755 --- a/UTF8.ml +++ b/UTF8.ml @@ -38,3 +38,15 @@ module Printf = struct include Printf end + +module Format = struct + + include Format + + let bprintf buffer fformat = begin + let to_b = formatter_of_buffer buffer in + let x = fprintf to_b fformat in + x + end + +end diff --git a/UTF8.mli b/UTF8.mli index 9e957ac..f91b1fd 100755 --- a/UTF8.mli +++ b/UTF8.mli @@ -60,7 +60,13 @@ end module Printf : sig val bprintf : Buffer.buffer -> ('a, Buffer.buffer, unit) format -> 'a - - val sprintf : ('a, unit, string) format -> 'a + +end + +module Format: sig + + val formatter_of_buffer : Buffer.buffer -> Format.formatter + + val fprintf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a end diff --git a/catalog.ml b/catalog.ml index 19fb3f4..bd17a18 100755 --- a/catalog.ml +++ b/catalog.ml @@ -3,7 +3,7 @@ module type DATA_SIG = sig type 'a typ - type 'a result + type 'a returnType val compare_typ: 'a typ -> 'b typ -> ('a, 'b) T.cmp @@ -20,9 +20,9 @@ module Make(Data:DATA_SIG) = struct (** This is the way the function is store in the map. We just the return type, and the function itself. *) type _ t_function = - | Fn1: 'b Data.result * ('a -> 'b) -> 'a t_function - | Fn2: 'c Data.result * ('a -> 'b -> 'c) -> ('a * 'b) t_function - | Fn3: 'd Data.result * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function + | Fn1: 'b Data.returnType * ('a -> 'b) -> 'a t_function + | Fn2: 'c Data.returnType * ('a -> 'b -> 'c) -> ('a * 'b) t_function + | Fn3: 'd Data.returnType * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function (** This is the key for storing functions in the map. *) type _ sig_typ = diff --git a/catalog.mli b/catalog.mli index d2bb707..d5e5cfd 100644 --- a/catalog.mli +++ b/catalog.mli @@ -2,7 +2,7 @@ module type DATA_SIG = sig type 'a typ - type 'a result + type 'a returnType val compare_typ: 'a typ -> 'b typ -> ('a, 'b) Tools.cmp @@ -13,9 +13,9 @@ module Make(D:DATA_SIG): sig type t type 'a t_function = - | Fn1: 'b D.result * ('a -> 'b) -> 'a t_function - | Fn2: 'c D.result * ('a -> 'b -> 'c) -> ('a * 'b) t_function - | Fn3: 'd D.result * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function + | Fn1: 'b D.returnType * ('a -> 'b) -> 'a t_function + | Fn2: 'c D.returnType * ('a -> 'b -> 'c) -> ('a * 'b) t_function + | Fn3: 'd D.returnType * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function type 'a sig_typ = | T1: 'a D.typ -> 'a t_function sig_typ @@ -26,7 +26,7 @@ module Make(D:DATA_SIG): sig val empty: t (** Register a new function in the catalog *) - val register : t -> string -> 'a sig_typ -> 'a -> t + val register : t -> string -> 'a t_function sig_typ -> 'a t_function -> t (** Find a function with the given name and signature *) val find_function: t -> string -> 'a t_function sig_typ -> 'a t_function diff --git a/date.ml b/date.ml index 9b24afe..4869f38 100644 --- a/date.ml +++ b/date.ml @@ -24,7 +24,7 @@ let get_julian_day year month day = begin end -let date_from_julian_day day = begin +let date_from_julian_day (day:Num.num) = begin let shift_day = Num.floor_num day |> Num.add_num (Num.num_of_int 2415019) in 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) diff --git a/evaluator.mli b/evaluator.mli index d695b68..de03ffc 100755 --- a/evaluator.mli +++ b/evaluator.mli @@ -1,4 +1,4 @@ -val repr: (ScTypes.refs -> ScTypes.types option ScTypes.Refs.range) -> ScTypes.expression -> ScTypes.types +val repr: (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.expression -> ScTypes.result (** Type definitions *) @@ -10,49 +10,49 @@ val t_list: 'a typ -> 'a list typ (** Result formats *) -type 'a result +type 'a returnType (** Numeric (any format) *) -val f_num: DataType.Num.t result +val f_num: DataType.Num.t returnType (** Date *) -val f_date: DataType.Num.t result +val f_date: DataType.Num.t returnType (** Number *) -val f_number: DataType.Num.t result +val f_number: DataType.Num.t returnType (** Boolean result *) -val f_bool: DataType.Bool.t result +val f_bool: DataType.Bool.t returnType (** String *) -val f_string: DataType.String.t result +val f_string: DataType.String.t returnType (** Catalog *) val register0: string -> (* The function name *) - 'a result -> (* The return type *) + 'a returnType -> (* The return type *) (unit -> 'a) (* The function to call *) -> unit val register1: string -> (* The function name *) 'a typ -> (* The signature *) - 'b result -> (* The return type *) + 'b returnType -> (* The return type *) ('a -> 'b) (* The function to call *) -> unit val register2: string -> (* The function name *) ('a typ * 'b typ) ->(* The signature *) - 'c result -> (* The return type *) + 'c returnType -> (* The return type *) ( 'a -> 'b -> 'c) (* The function to call*) -> unit val register3: string -> (* The function name *) ('a typ * 'b typ * 'c typ) ->(* The signature *) - 'd result -> (* The return type *) + 'd returnType -> (* The return type *) ( 'a -> 'b -> 'c -> 'd) (* The function to call*) -> unit diff --git a/expression.ml b/expression.ml index 0bc8f43..c61131e 100755 --- a/expression.ml +++ b/expression.ml @@ -3,9 +3,9 @@ module Tuple2 = Tools.Tuple2 let u = UTF8.from_utf8string type t = - | Basic of ScTypes.types (** A direct type *) - | Formula of formula (** A formula *) - | Undefined (** The content is not defined *) + | Basic: 'a ScTypes.types -> t (** A direct type *) + | Formula: formula -> t (** A formula *) + | Undefined: t (** The content is not defined *) and formula = | Expression of ScTypes.expression (** A valid expression *) @@ -33,11 +33,12 @@ let load content = begin let content' = try String.sub content 0 (String.index content '\000') with Not_found -> content in - Basic ( - try Lexing.from_string content' - |> ExpressionParser.content ExpressionLexer.read - with _ -> ScTypes.Str (UTF8.from_utf8string content') - ) + try + let ScTypes.Result r = + Lexing.from_string content' + |> ExpressionParser.content ExpressionLexer.read in + Basic r + with _ -> Basic (ScTypes.Str (UTF8.from_utf8string content')) ) ) else ( (* If the string in empty, build an undefined value *) @@ -58,7 +59,7 @@ let eval expr sources = begin begin try match expr with | Basic value -> ScTypes.Result value - | Formula (Expression f) -> ScTypes.Result (eval_exp f) + | Formula (Expression f) -> eval_exp f | Formula (Error (i, s)) -> ScTypes.Error ScTypes.Error | Undefined -> ScTypes.Error Not_found with ex -> ScTypes.Error ex diff --git a/expression.mli b/expression.mli index e54d2a0..8cab479 100755 --- a/expression.mli +++ b/expression.mli @@ -1,7 +1,7 @@ type t = - | Basic of ScTypes.types (** A direct type *) - | Formula of formula (** A formula *) - | Undefined (** The content is not defined *) + | Basic: 'a ScTypes.types -> t (** A direct type *) + | Formula: formula -> t (** A formula *) + | Undefined: t (** The content is not defined *) and formula = | Expression of ScTypes.expression (** A valid expression *) @@ -16,7 +16,7 @@ val load_expr: t -> t val is_defined: t -> bool (** Evaluate the expression *) -val eval: t -> (ScTypes.refs -> ScTypes.types option ScTypes.Refs.range) -> ScTypes.result +val eval: t -> (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.result (** Collect all the cell referenced in the expression *) val collect_sources: t -> Cell.Set.t diff --git a/expressionParser.mly b/expressionParser.mly index f85f44f..303e683 100755 --- a/expressionParser.mly +++ b/expressionParser.mly @@ -35,7 +35,7 @@ %left POW %start value -%start content +%start content %% @@ -46,26 +46,33 @@ content: | basic EOF {$1} basic: - | num {Num ((snd $1), Some (u(fst $1)))} - | MINUS num {Num (Num.minus_num (snd $2), Some (u("-" ^(fst $2)) ))} - | PLUS num {Num ((snd $2), Some (u(fst $2)))} - | NUM DIVIDE NUM DIVIDE NUM { - Date (Tools.Date.get_julian_day - (Num.int_of_num @@ snd $1) - (Num.int_of_num @@ snd $3) - (Num.int_of_num @@ snd $5) - )} - | NUM COLON NUM COLON NUM { - Date (Num.( - let nhour = (snd $1) // (num_of_int 24) - and nmin = (snd $3) // (num_of_int 1440) - and nsec = (snd $5) // (num_of_int 86400) - in nhour +/ nmin +/ nsec - )) - } + | PLUS num {Result (Num (ScTypes.Number, (DataType.Num.of_num (snd $2))))} + | MINUS num {Result (Num (ScTypes.Number, (DataType.Num.of_num @@ Num.minus_num (snd $2))))} + | num {Result (Num (ScTypes.Number, (DataType.Num.of_num (snd $1))))} + | NUM DIVIDE NUM DIVIDE NUM {Result ( + Num ( + ScTypes.Date, + DataType.Num.of_num @@ (Date.get_julian_day + (Num.int_of_num @@ snd $1) + (Num.int_of_num @@ snd $3) + (Num.int_of_num @@ snd $5) + )))} + | NUM COLON NUM COLON NUM {Result ( + Num ( + ScTypes.Date, + (Num.( + let nhour = (snd $1) // (num_of_int 24) + and nmin = (snd $3) // (num_of_int 1440) + and nsec = (snd $5) // (num_of_int 86400) + in DataType.Num.of_num @@ nhour +/ nmin +/ nsec)) + ) + )} expr: - | num {Value (Num ((snd $1), Some (u(fst $1))))} + | num {Value (Num ( + ScTypes.Number, + DataType.Num.of_num (snd $1) + ))} | MINUS expr {Call (F.sub, [$2])} | PLUS expr {Call (F.add, [$2])} diff --git a/odf/odf.ml b/odf/odf.ml index 7af44a9..b091bc9 100755 --- a/odf/odf.ml +++ b/odf/odf.ml @@ -31,10 +31,14 @@ let load_formula formula = let load_content content = begin function | "float" -> Expression.Basic ( ScTypes.Num ( - (Tools.Num.of_float_string content), Some (u @@ Tools.String.filter_float content))) + ScTypes.Number, + DataType.Num.of_num (Tools.Num.of_float_string content) + )) | "date" -> Expression.Basic ( - ScTypes.Date ( - Tools.Date.from_string content)) + ScTypes.Num ( + ScTypes.Date, + DataType.Num.of_num (Tools.Num.of_float_string content) + )) | _ -> Expression.Basic ( ScTypes.Str ( UTF8.from_utf8string content)) @@ -164,15 +168,19 @@ let write_bool = write_type "bool" "bool" let write_error = write_type "string" "error" let write_date = write_type "date" "date" -let write_basic attrs output = begin function - | ScTypes.Num (n,_) -> - let value = (string_of_float @@ Num.float_of_num n) in - write_num ((NS.value_attr, value)::attrs) output value +let write_basic: type a. 'b list -> Xmlm.output -> a ScTypes.types -> unit = fun attrs output types -> begin match types with | ScTypes.Str s -> write_str attrs output (UTF8.to_utf8string s) | ScTypes.Bool b -> write_bool attrs output (string_of_bool b) - | ScTypes.Date d -> - let value = Tools.Date.to_string d in + | ScTypes.Num (data_type, d) -> + let n = DataType.Num.to_num d in + begin match ScTypes.get_numeric_type data_type with + | ScTypes.Number -> + let value = (string_of_float @@ Num.float_of_num n) in + write_num ((NS.value_attr, value)::attrs) output value + | ScTypes.Date -> + let value = Date.to_string n in write_date ((NS.date_value_attr, value)::attrs) output value + end end let write_formula output attrs f = begin function @@ -191,17 +199,21 @@ let print_ref buffer c = end; UTF8.Buffer.add_string buffer @@ u"]" -let rec print_expr buffer = begin function - | ScTypes.Value (ScTypes.Num (n, _)) -> - UTF8.Buffer.add_string buffer @@ u(string_of_float @@ Num.float_of_num n) +let rec print_expr : UTF8.Buffer.buffer -> ScTypes.expression -> unit = fun buffer -> begin function | ScTypes.Value (ScTypes.Str s) -> UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string s) | ScTypes.Value (ScTypes.Bool b) -> u(string_of_bool b) |> UTF8.Buffer.add_string buffer - | ScTypes.Value (ScTypes.Date d) -> - u(Tools.Date.to_string d) - |> UTF8.Buffer.add_string buffer + | ScTypes.Value (ScTypes.Num (data_type, d)) -> + let n = DataType.Num.to_num d in + begin match ScTypes.get_numeric_type data_type with + | ScTypes.Number -> + UTF8.Buffer.add_string buffer @@ u(string_of_float @@ Num.float_of_num n) + | ScTypes.Date -> + u(Date.to_string n) + |> UTF8.Buffer.add_string buffer + end | ScTypes.Ref r -> print_ref buffer r | ScTypes.Expression x -> UTF8.Buffer.add_char buffer '('; diff --git a/odf/odf_ExpressionParser.mly b/odf/odf_ExpressionParser.mly index 9731699..1b60e1c 100755 --- a/odf/odf_ExpressionParser.mly +++ b/odf/odf_ExpressionParser.mly @@ -43,7 +43,10 @@ value: | LETTERS COLON EQ expr EOF {$4} expr: - | num {Value (Num ((snd $1), Some (u(fst $1))))} + | num {Value (Num ( + Number, + DataType.Num.of_num @@ snd $1 + ))} | MINUS expr {Call (F.sub, [$2])} | PLUS expr {Call (F.add, [$2])} diff --git a/scTypes.ml b/scTypes.ml index 869df8b..f8c3d38 100755 --- a/scTypes.ml +++ b/scTypes.ml @@ -8,36 +8,79 @@ type cell = Cell.t type ident = UTF8.t -type types = - | Num of Num.num * (UTF8.t option) (** A number *) - | Str of UTF8.t (** A string *) - | Date of Num.num (** A date in julian day *) - | Bool of bool (** A boolean *) +type 'a number_format = (float -> 'a, Format.formatter, unit) format + +type _ dataFormat = + | Date: DataType.Num.t dataFormat (* Date *) + | Number: DataType.Num.t dataFormat (* Number *) + | String: DataType.String.t dataFormat (* String result, there is only one representation *) + | Bool: DataType.Bool.t dataFormat (* Boolean result *) + +type numericType = + | Date + | Number + +let get_numeric_type: DataType.Num.t dataFormat -> numericType = function + | Date -> Date + | Number -> Number + +let priority: type a. a dataFormat -> int = function + | Date -> 1 + | Number -> 0 + | String -> 0 + | Bool -> 0 + +type 'a types = + | Num : DataType.Num.t dataFormat * DataType.Num.t -> DataType.Num.t types (** A number *) + | Str : DataType.String.t -> DataType.String.t types (** A string *) + | Bool : DataType.Bool.t -> DataType.Bool.t types (** A boolean *) + +type 'a returnType = + | Num : DataType.Num.t dataFormat option -> DataType.Num.t returnType (** A number *) + | Str : DataType.String.t returnType (** A string *) + | Bool : DataType.Bool.t returnType (** A boolean *) + +let f_num: DataType.Num.t returnType = Num None +let f_date: DataType.Num.t returnType = Num (Some Date) +let f_number: DataType.Num.t returnType = Num (Some Number) +let f_string: DataType.String.t returnType = Str +let f_bool: DataType.Bool.t returnType = Bool + +type typeContainer = + | Value: 'a types -> typeContainer + +let guess_format_result: + type a. a returnType -> typeContainer list -> (a -> a types) = + fun return params -> begin match return with + | Str -> fun value -> Str value + | Bool -> fun value -> Bool value + | Num (Some x) -> fun value -> Num (x, value) + | Num None -> fun value -> Num (Number, value) +end type refs = - | Cell of cell (** A cell *) - | Range of cell * cell (** An area of cells *) + | Cell of cell (** A cell *) + | Range of cell * cell (** An area of cells *) type expression = - | Value of types (** A direct value *) - | Ref of refs (** A reference to another cell *) - | Call of ident * expression list (** A call to a function *) - | Expression of expression (** An expression *) + | Value : 'a types -> expression (** A direct value *) + | Ref : refs -> expression (** A reference to another cell *) + | Call : ident * expression list -> expression (** A call to a function *) + | Expression : expression -> expression (** An expression *) (** Result from a computation *) type result = - | Result of types - | Error of exn + | Result : 'a types -> result + | Error : exn -> result module Type = struct (* Required because Num.Big_int cannot be compared with Pervasives.(=) *) - let (=) t1 t2 = + let (=) : type a b. a types -> b types -> bool = fun t1 t2 -> match t1, t2 with - | Num (n1,_), Num (n2,_) -> Num.eq_num n1 n2 - | Date n1, Date n2 -> Num.eq_num n1 n2 - | Num _, Date n2 -> false - | Date n1, Num _ -> false - | _, _ -> t1 = t2 + | Num (_, n1), Num (_, n2) -> DataType.Num.eq n1 n2 + | Bool b1, Bool b2 -> b1 = b2 + | Str s1, Str s2 -> s1 = s2 + | _, _ -> false (** Show a list of elements *) @@ -52,20 +95,19 @@ module Type = struct show_list printer buffer tl end - and show buffer = begin function - | Num (n,x) -> - begin match x with - | Some value -> UTF8.Buffer.add_string buffer value - | None -> - if Num.is_integer_num n then - UTF8.Buffer.add_string buffer @@ u(Num.string_of_num n) - else - UTF8.Printf.bprintf buffer "%.*f" 2 (Num.float_of_num n) - end + and show: type a. UTF8.Buffer.buffer -> a types -> unit = fun buffer -> begin function | Str x -> UTF8.Buffer.add_string buffer x | Bool b -> UTF8.Printf.bprintf buffer "%B" b - | Date n -> - let y, m, d = Tools.Date.date_from_julian_day n in + | Num (Number, n) -> + let n = DataType.Num.to_num n in + if Num.is_integer_num n then + UTF8.Buffer.add_string buffer @@ u(Num.string_of_num n) + else + let to_b = UTF8.Format.formatter_of_buffer buffer in + ignore @@ UTF8.Format.fprintf to_b "%.2f" (Num.float_of_num n); + Format.pp_print_flush to_b () + | Num (Date, n) -> + let y, m, d = Date.date_from_julian_day (DataType.Num.to_num n) in UTF8.Printf.bprintf buffer "%d/%d/%d" y m d end diff --git a/scTypes.mli b/scTypes.mli index 1d8fe54..17b51eb 100755 --- a/scTypes.mli +++ b/scTypes.mli @@ -6,32 +6,70 @@ type cell = (int * int) * (bool * bool) type ident = UTF8.t -type types = - | Num of Num.num * (UTF8.t option) (** A number *) - | Str of UTF8.t (** A string *) - | Date of Num.num (** A date in julian day *) - | Bool of bool (** A boolean *) +type 'a number_format = (float -> 'a, Format.formatter, unit) format + +type 'a dataFormat = + | Date: DataType.Num.t dataFormat (* A date in julian day *) + | Number: DataType.Num.t dataFormat (* Number *) + | String: DataType.String.t dataFormat (* String result, there is only one representation *) + | Bool: DataType.Bool.t dataFormat (* Boolean result *) + +type 'a returnType = + | Num : DataType.Num.t dataFormat option -> DataType.Num.t returnType (** A number *) + | Str : DataType.String.t returnType (** A string *) + | Bool : DataType.Bool.t returnType (** A boolean *) + +type numericType = + | Date + | Number + +val get_numeric_type: DataType.Num.t dataFormat -> numericType + +type 'a types = + | Num : DataType.Num.t dataFormat * DataType.Num.t -> DataType.Num.t types (** A number *) + | Str : DataType.String.t -> DataType.String.t types (** A string *) + | Bool : DataType.Bool.t -> DataType.Bool.t types (** A boolean *) + +type typeContainer = + | Value: 'a types -> typeContainer + + +(** Numeric (any format) *) +val f_num: DataType.Num.t returnType + +(** Date *) +val f_date: DataType.Num.t returnType + +(** Number *) +val f_number: DataType.Num.t returnType + +(** Boolean result *) +val f_bool: DataType.Bool.t returnType + +(** String *) +val f_string: DataType.String.t returnType type refs = | Cell of cell (** A cell *) | Range of cell * cell (** An area of cells *) +(** This is the cell content *) type expression = - | Value of types (** A direct value *) - | Ref of refs (** A reference to another cell *) - | Call of ident * expression list (** A call to a function *) - | Expression of expression (** An expression *) + | Value : 'a types -> expression (** A direct value *) + | Ref : refs -> expression (** A reference to another cell *) + | Call : ident * expression list -> expression (** A call to a function *) + | Expression : expression -> expression (** An expression *) (** Result from a computation *) type result = - | Result of types - | Error of exn + | Result : 'a types -> result + | Error : exn -> result module Type : sig - val (=) : types -> types -> bool + val (=) : 'a types -> 'b types -> bool - val show: UTF8.Buffer.buffer -> types -> unit + val show: UTF8.Buffer.buffer -> 'a types -> unit end diff --git a/sheet.ml b/sheet.ml index a17c08c..241039e 100755 --- a/sheet.ml +++ b/sheet.ml @@ -48,11 +48,11 @@ module Raw = struct (** Extract a value from a reference. This function is given to the evaluator for getting the values from a reference. *) - let get_ref from t ref : ScTypes.types option ScTypes.Refs.range = begin + let get_ref from t ref : ScTypes.result option ScTypes.Refs.range = begin let extract_values = begin function - | ScTypes.Result v -> v | ScTypes.Error e -> raise e + | v -> v end in ScTypes.Refs.collect ref @@ -79,50 +79,52 @@ module Raw = struct None end - (** Parse all the successors from an element, apply a function to each of them, and return them *) let rec traverse (f:(cell -> content -> t -> t option)) source (init, t) = begin - let rec successors element (parents, succ, t) = begin + let exception Cycle of Cell.Set.t * t in + + let rec successors parents element (succ, t) = begin let content = Map.find element t in if Cell.Set.mem element parents then ( + (* if the cell has already been visited, mark it in error, and all the descendant *) let cycle_error = Some (ScTypes.Error Errors.Cycle) in - if content.value = cycle_error then - (* The content has already been update, do not process it again *) - (parents, succ, t) - else + if content.value = cycle_error then ( + (* The content has already been updated, do not process it again *) + (succ, t) + ) else ( let t = Map.add element { content with value = cycle_error } t and set_error cell content t = if content.value = cycle_error then None else - Some (Map.add cell { content with value = cycle_error } t) - and succ = Cell.Set.add element succ in - let succ, t = traverse set_error content (succ, t) in - (parents, succ, t) + Some (Map.add cell { content with value = cycle_error } t) in + let succ, t = traverse set_error source (init, t) in + raise (Cycle (succ, t)) + ) ) else ( begin match f element content t with | None -> (* The content does not change, we do not update the successors *) - (init, succ, t) + (succ, t) | Some t' -> let parents' = Cell.Set.add element parents and succ' = Cell.Set.add element succ in if (Cell.Set.is_empty content.sink) then - (init, succ', t') + (succ', t') else - Cell.Set.fold successors content.sink (parents', succ', t') + Cell.Set.fold (successors parents') content.sink (succ', t') end ) end in - let _, succ, t = Cell.Set.fold successors source.sink (init, init, t) in - succ, t + try Cell.Set.fold (successors init) source.sink (init, t) + with Cycle (succ, t) -> (succ, t) end (** Remove the cell from the sheet *) @@ -219,9 +221,8 @@ module Raw = struct add_element id f t end - exception Found of (int * int) - let search pattern t = begin + let exception Found of (int * int) in let _search key content = if content.value = pattern then raise (Found key) in try @@ -246,7 +247,7 @@ module Raw = struct end -type yank =cell * Raw.content +type yank = cell * Raw.content type t = { selected: Selection.t; (* The selected cell *) diff --git a/tests/expressionParser_test.ml b/tests/expressionParser_test.ml index 25d9d00..476e3aa 100755 --- a/tests/expressionParser_test.ml +++ b/tests/expressionParser_test.ml @@ -21,7 +21,9 @@ let test_num ctx = begin Expression.Expression ( ScTypes.Value ( ScTypes.Num ( - Num.num_of_int 1, Some (u"1"))))) in + ScTypes.Number, + DataType.Num.of_num (Num.num_of_int 1) + )))) in let result = load_expr "=1" in assert_equal @@ -52,7 +54,10 @@ let test_call2 ctx = begin let expected = Expression.Formula ( Expression.Expression ( ScTypes.Call ( - u"foo2", [ScTypes.Value (ScTypes.Num (Num.num_of_int 4, Some (u"4")))]))) in + u"foo2", [ScTypes.Value (ScTypes.Num ( + ScTypes.Number, + DataType.Num.of_num (Num.num_of_int 4) + ))]))) in let result = load_expr "=foo2(4)" in assert_equal diff --git a/tests/expression_test.ml b/tests/expression_test.ml index 3f00e67..0950383 100755 --- a/tests/expression_test.ml +++ b/tests/expression_test.ml @@ -6,11 +6,11 @@ let u = UTF8.from_utf8string let _msg ~expected ~result = let get_type = function - | Expression.Basic ScTypes.Num _ -> "N" - | Expression.Basic ScTypes.Str _ -> "S" - | Expression.Basic ScTypes.Date _ -> "D" - | Expression.Basic ScTypes.Bool _ -> "B" - | Expression.Formula _ -> "F" in + | Expression.Basic ScTypes.Num (ScTypes.Number, _) -> "N" + | Expression.Basic ScTypes.Num (ScTypes.Date, _) -> "D" + | Expression.Basic ScTypes.Str _ -> "S" + | Expression.Basic ScTypes.Bool _ -> "B" + | Expression.Formula _ -> "F" in Printf.sprintf "Expected %s:%s but got %s:%s" (UTF8.raw_encode @@ Expression.show expected) @@ -52,7 +52,10 @@ end let test_num ctx = begin let result = Expression.load @@ u"123" in let expected = Expression.load_expr @@ Expression.Basic ( - ScTypes.Num (Num.num_of_int 123, None)) in + ScTypes.Num ( + ScTypes.Number, + DataType.Num.of_num @@ Num.num_of_int 123 + )) in assert_equal expected result end @@ -60,21 +63,29 @@ let test_float ctx = begin let result = Expression.load @@ u"12.45" in let expected = Expression.load_expr @@ Expression.Basic ( ScTypes.Num ( - T.Num.of_float_string "12.45", None)) in + ScTypes.Number, + DataType.Num.of_num @@ T.Num.of_float_string "12.45" + )) in assert_equal expected result end let test_relative ctx = begin let result = Expression.load @@ u"-123" in let expected = Expression.load_expr @@ Expression.Basic ( - ScTypes.Num (Num.num_of_int (-123), None)) in + ScTypes.Num ( + ScTypes.Number, + DataType.Num.of_num @@ Num.num_of_int (-123) + )) in assert_equal expected result end let test_date ctx = begin let result = Expression.load @@ u"1900/01/01" and expected = Expression.load_expr @@ Expression.Basic ( - ScTypes.Date (Tools.Date.get_julian_day 1900 01 01)) in + ScTypes.Num ( + ScTypes.Date, + DataType.Num.of_num @@ Date.get_julian_day 1900 01 01 + )) in assert_equal expected result end diff --git a/tests/odf/odf_ExpressionParser_test.ml b/tests/odf/odf_ExpressionParser_test.ml index 2cdb3bb..becf9ab 100755 --- a/tests/odf/odf_ExpressionParser_test.ml +++ b/tests/odf/odf_ExpressionParser_test.ml @@ -13,6 +13,13 @@ let _msg ~(expected:ScTypes.expression) ~(result:ScTypes.expression) = (UTF8.raw_encode @@ UTF8.Buffer.contents b2) + +let build_num value = ScTypes.Num ( + ScTypes.Number, + DataType.Num.of_num @@ Num.num_of_int value +) + + let test_formula ctx = begin let test1 = "of:=CONCATENATE(SUM([.F16:.AJ16]);\"/\";8*NETWORKDAYS([.F6]; [.F6]+(ORG.OPENOFFICE.DAYSINMONTH([.F6])-1)))" in @@ -27,7 +34,7 @@ let test_formula ctx = begin Ref (Range (((6, 16), (false, false)), (((36, 16), (false, false)))))]); Value (Str (u"/")); Call(u"*", [ - Value (Num ((Num.num_of_int 8, Some (u"8")))); + Value (build_num 8); Call(u"NETWORKDAYS", [ Ref (Cell ((6, 6), (false, false))); Call(u"+", [ @@ -36,7 +43,7 @@ let test_formula ctx = begin Call( u"-", [ Call(u"ORG.OPENOFFICE.DAYSINMONTH", [ Ref (Cell ((6, 6), (false, false)))]); - Value (Num ((Num.num_of_int 1, Some (u"1")))); + Value (build_num 1); ]))])])])])) in assert_equal diff --git a/tests/sheet_test.ml b/tests/sheet_test.ml index 71f5749..084118f 100755 --- a/tests/sheet_test.ml +++ b/tests/sheet_test.ml @@ -16,6 +16,11 @@ let _msg ~expected ~result = begin (get_string result) end +let build_num value = ScTypes.Num ( + ScTypes.Number, + DataType.Num.of_num @@ Num.num_of_int value +) + (** Test a simple references between two cells *) let test_create_ref_1 ctx = begin @@ -24,7 +29,7 @@ let test_create_ref_1 ctx = begin |> snd |> Sheet.Raw.add (0,0) @@ Expression.load @@ u"=C3" |> snd in let result = (Sheet.Raw.get_value (0, 0) s) in - let expected = Some (ScTypes.Result (ScTypes.Num (Num.num_of_int (-1), None))) in + let expected = Some (ScTypes.Result (build_num (-1))) in assert_equal ~msg:(_msg ~expected ~result) @@ -42,7 +47,7 @@ let test_create_ref_2 ctx = begin let result = (Sheet.Raw.get_value (2, 2) s) in - let expected = Some (ScTypes.Result (ScTypes.Num (Num.num_of_int 123, None))) in + let expected = Some (ScTypes.Result (build_num 123)) in assert_equal ~msg:(_msg ~expected ~result) @@ -96,7 +101,7 @@ let test_check_cycle3 ctx = begin |> snd in let result = (Sheet.Raw.get_value (1, 3) s) in (* A3 = A1 + A1 = 4 *) - let expected = Some (ScTypes.Result (ScTypes.Num (Num.num_of_int 4, None))) in + let expected = Some (ScTypes.Result (build_num 4)) in assert_equal ~msg:(_msg ~expected ~result) diff --git a/tools.ml b/tools.ml index 0954be1..45c9bab 100755 --- a/tools.ml +++ b/tools.ml @@ -281,12 +281,6 @@ module NCurses = struct end -module Date = struct - - include Date - -end - let try_finally f except = try let res = f () in except (); -- cgit v1.2.3