From 824f2987d47e87d58ee2a4a96d7be417aad6aeab Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Wed, 31 Jan 2018 13:20:20 +0100 Subject: API refactoring : made the GADT abstract, provide contructor for each case, and deported the expression with evaluation with module functors --- src/evaluator.ml | 150 -------------- src/evaluator.mli | 4 - src/expression.ml | 86 +++++---- src/expression.mli | 10 +- src/expressionParser.mly | 66 ++++--- src/expressions/collect_sources.ml | 69 +++++++ src/expressions/eval_ref.ml | 136 +++++++++++++ src/expressions/evaluate.ml | 142 ++++++++++++++ src/expressions/show_expr.ml | 62 ++++++ src/expressions/show_ref.ml | 11 ++ src/expressions/show_type.ml | 26 +++ src/expressions/sym_expr.ml | 31 +++ src/expressions/sym_ref.ml | 12 ++ src/expressions/sym_type.ml | 18 ++ src/functions.ml | 22 +-- src/functions.mli | 4 +- src/main.ml | 19 +- src/odf/odf.ml | 140 +++++++------- src/odf/odfLoader.ml | 14 +- src/odf/odf_ExpressionParser.mly | 48 +++-- src/scTypes.ml | 387 +++++++++++++------------------------ src/scTypes.mli | 190 ++++++++++-------- src/sheet.ml | 129 ++++++------- src/sheet.mli | 15 +- src/tools.ml | 104 +--------- 25 files changed, 1038 insertions(+), 857 deletions(-) delete mode 100755 src/evaluator.ml delete mode 100755 src/evaluator.mli create mode 100755 src/expressions/collect_sources.ml create mode 100755 src/expressions/eval_ref.ml create mode 100755 src/expressions/evaluate.ml create mode 100755 src/expressions/show_expr.ml create mode 100755 src/expressions/show_ref.ml create mode 100755 src/expressions/show_type.ml create mode 100755 src/expressions/sym_expr.ml create mode 100755 src/expressions/sym_ref.ml create mode 100755 src/expressions/sym_type.ml (limited to 'src') diff --git a/src/evaluator.ml b/src/evaluator.ml deleted file mode 100755 index 05b975f..0000000 --- a/src/evaluator.ml +++ /dev/null @@ -1,150 +0,0 @@ -module D = DataType -module F = Functions - -module Data = struct - - (*** Values definitions *) - - type 'a value = - | Bool: D.Bool.t -> D.Bool.t value - | Num: D.Num.t ScTypes.dataFormat * D.Num.t -> D.Num.t value - | String: UTF8.t -> UTF8.t value - | List: 'a ScTypes.dataFormat * 'a list -> 'a list value - | Matrix: 'a ScTypes.dataFormat * 'a list list -> 'a list list value - - (** Extract the type and the content from a value *) - let get_argument: type a. a value -> a F.typ * a = function - | Bool b -> F.t_bool, b - | Num (_, n) -> F.t_int, n - | String s -> F.t_string, s - | List (t, l) -> F.t_list (F.typ_of_format t), l - | Matrix (t, l) -> F.t_list (F.t_list (F.typ_of_format t)), l - -end - -(** Functions are stored as a mutable catalog. A setter is given *) -let catalog = ref (F.C.compile F.C.empty) - -let set_catalog t = catalog := t - -type existencialResult = - | Result : 'a Data.value -> existencialResult [@@unboxed] - -let inject: -type a. a ScTypes.dataFormat -> a -> existencialResult = fun resultFormat res -> - begin match resultFormat with - | ScTypes.Bool -> Result (Data.Bool res) - | ScTypes.String -> Result (Data.String res) - | ScTypes.Number -> Result (Data.Num (resultFormat, res)) - | ScTypes.Date -> Result (Data.Num (resultFormat, res)) - end - - -(** Extract the format from a list of results *) -let build_format_list ll () = - - List.map (fun (Result x) -> - begin match x with - | Data.Bool _ -> ScTypes.DataFormat.F (ScTypes.Bool) - | Data.Num (x, _) -> ScTypes.DataFormat.F x - | Data.String _ -> ScTypes.DataFormat.F (ScTypes.String) - | Data.List (f, _) -> ScTypes.DataFormat.F f - | Data.Matrix (f, _) -> ScTypes.DataFormat.F f - end - ) ll - -(** Call the function with the arguments *) -let call name args = begin - let name' = UTF8.to_utf8string name in - begin try match args with - | [] -> - let arg1 = (F.t_unit, ()) in - let F.C.R(ret, res) = F.C.eval1 !catalog name' arg1 in - let returnType = ScTypes.DataFormat.guess_format_result ret (fun () -> raise Errors.TypeError) in - inject returnType res - - | (Result p1)::[] -> - let arg1 = Data.get_argument p1 in - let F.C.R(ret, res) = F.C.eval1 !catalog name' arg1 in - let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in - inject returnType res - - | (Result p1)::(Result p2)::[] -> - let arg1 = Data.get_argument p1 - and arg2 = Data.get_argument p2 in - let F.C.R(ret, res) = F.C.eval2 !catalog name' arg1 arg2 in - let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in - inject returnType res - - | (Result p1)::(Result p2)::(Result p3)::[] -> - let arg1 = Data.get_argument p1 - and arg2 = Data.get_argument p2 - and arg3 = Data.get_argument p3 in - let F.C.R(ret, res) = F.C.eval3 !catalog name' arg1 arg2 arg3 in - let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in - inject returnType res - - | _ -> raise Not_found - with Not_found -> - let signature = List.map (fun (Result x) -> - let formatter = Format.str_formatter in - Functions.repr formatter (fst @@ Data.get_argument x); - Format.flush_str_formatter ()) args in - - raise (Errors.Undefined (name, signature)) - end -end - -let eval mapper value = begin - - (** Extract the value from a raw type. - If the value is Undefined, raise an exception. - *) - 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 - - (** Extract the value from an expression. - [extract expr] will evaluate the expression and return it. If the result - cannot be evaluated (because of references pointing to missing values) a - default value of type [typ] will be returned. - *) - let rec extract = begin function - (* For a reference to an external we first extract the value pointed *) - | ScTypes.Ref r -> ScTypes.Refs.( - begin match ScTypes.Refs.get_content @@ mapper r with - | Value (format, f) -> begin match format with - | ScTypes.Date -> Result (Data.Num (format, f)) - | ScTypes.Number -> Result (Data.Num (format, f)) - | ScTypes.String -> Result (Data.String f) - | ScTypes.Bool -> Result (Data.Bool f) - end - | List (format, l) -> Result (Data.List (format, l)) - | Matrix (format, l) -> Result (Data.Matrix (format, l)) - end) - - (* Evaluate the expression *) - | ScTypes.Expression e -> extract e - | ScTypes.Value v -> extract_value (ScTypes.Result v) - | ScTypes.Call (name, args) -> - (* The function is not tail recursive, but I don't think we will have - more than 100 nested functions here... *) - let args' = List.map extract args in - call name args' - end in - - let Result r = extract value in - begin match r with - | Data.Bool b -> ScTypes.Result (ScTypes.boolean b) - | Data.String s -> ScTypes.Result (ScTypes.string s) - | Data.Num (format, n) -> - begin match ScTypes.get_numeric_type format with - | ScTypes.Date -> ScTypes.Result (ScTypes.date n) - | ScTypes.Number -> ScTypes.Result (ScTypes.number n) - end - | _ -> raise Errors.TypeError - end -end diff --git a/src/evaluator.mli b/src/evaluator.mli deleted file mode 100755 index e338b8d..0000000 --- a/src/evaluator.mli +++ /dev/null @@ -1,4 +0,0 @@ -val eval: (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.expression -> ScTypes.result - -val set_catalog: Functions.C.t -> unit - diff --git a/src/expression.ml b/src/expression.ml index 20227ad..ae6c85f 100755 --- a/src/expression.ml +++ b/src/expression.ml @@ -3,13 +3,13 @@ module Tuple2 = Tools.Tuple2 let u = UTF8.from_utf8string type t = - | Basic: 'a ScTypes.types -> t (** A direct type *) - | Formula: formula -> t (** A formula *) - | Undefined: t (** The content is not defined *) + | Basic: 'a ScTypes.Type.t -> 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 *) - | Error of int * UTF8.t (** When the expression cannot be parsed *) + | Expression of ScTypes.Expr.t (** A valid expression *) + | Error of int * UTF8.t (** When the expression cannot be parsed *) let is_defined = function @@ -34,11 +34,11 @@ let load content = begin try String.sub content 0 (String.index content '\000') with Not_found -> content in try - let ScTypes.Result r = + let ScTypes.Result.Ok r = ExpressionParser.content ExpressionLexer.read @@ Lexing.from_string content' in Basic r - with _ -> Basic (ScTypes.string (UTF8.from_utf8string content')) + with _ -> Basic (ScTypes.Type.string (UTF8.from_utf8string content')) ) ) else ( (* If the string in empty, build an undefined value *) @@ -49,64 +49,66 @@ end let load_expr expr = expr +module EvalExpr = ScTypes.Expr.Eval(Evaluate) (** Extract the parameters to give to a function. return an Error if one of them is an error *) -let eval expr sources = begin - - let eval_exp f = Evaluator.eval sources f in +let eval expr catalog mapper = begin begin try match expr with - | Basic value -> ScTypes.Result value - | Formula (Expression f) -> eval_exp f - | Formula (Error (i, s)) -> ScTypes.Error ScTypes.Error - | Undefined -> ScTypes.Error Not_found - with ex -> ScTypes.Error ex + | Basic value -> ScTypes.Result.Ok value + | Formula (Expression e) -> EvalExpr.eval e (catalog, mapper) + | Formula (Error (i, s)) -> ScTypes.Result.Error ScTypes.Error + | Undefined -> ScTypes.Result.Error Not_found + with ex -> ScTypes.Result.Error ex end end -let collect_sources expr = begin - let rec collect refs = function - | ScTypes.Ref r -> - begin match ScTypes.Refs.collect r with - | ScTypes.Refs.Single r -> Cell.Set.add r refs - | ScTypes.Refs.Array1 a1 -> - List.fold_left (fun set elt -> Cell.Set.add elt set) refs a1 - | ScTypes.Refs.Array2 a2 -> - List.fold_left (List.fold_left (fun set elt -> Cell.Set.add elt set)) refs a2 - end - | ScTypes.Call (ident, params) -> List.fold_left collect refs params - | ScTypes.Expression f -> collect refs f - | _ -> refs - in match expr with - | Formula (Expression f) -> collect Cell.Set.empty f + +module EvalSources = ScTypes.Expr.Eval(Collect_sources) + +let collect_sources = begin function + | Formula (Expression f) -> EvalSources.eval f () Cell.Set.empty | _ -> Cell.Set.empty end +module Printer = ScTypes.Expr.Eval(Show_expr.Show_Expr(Show_ref)(Show_type)) + +(** Inherit the default representation, but print the float with all decimals *) +module LongPrinter = ScTypes.Type.Eval(struct + + include Show_type + + let num n buffer = + if DataType.Num.is_integer n then + DataType.Num.to_int n + |> string_of_int + |> UTF8.from_utf8string + |> UTF8.Buffer.add_string buffer + else + let f = DataType.Num.to_float n + and to_b = UTF8.Format.formatter_of_buffer buffer in + ignore @@ UTF8.Format.fprintf to_b "%f" f; + Format.pp_print_flush to_b () + +end) + let show e = let buffer = UTF8.Buffer.create 16 in begin match e with | Formula (Expression f) -> UTF8.Buffer.add_char buffer '='; - ScTypes.show_expr buffer f - | Basic b -> ScTypes.Type.show_full buffer b + Printer.eval f () buffer + | Basic b -> LongPrinter.eval b buffer | Formula (Error (i,s)) -> UTF8.Buffer.add_string buffer s | Undefined -> () end; UTF8.Buffer.contents buffer -let shift vector = - - let rec shift_exp: ScTypes.expression -> ScTypes.expression = function - | ScTypes.Value v -> ScTypes.Value v - | ScTypes.Call (ident, params) -> ScTypes.Call (ident, List.map shift_exp params) - | ScTypes.Ref r -> ScTypes.Ref (ScTypes.Refs.shift vector r) - | ScTypes.Expression expr -> ScTypes.Expression (shift_exp expr) - - in function - | Formula (Expression f) -> Formula (Expression (shift_exp f)) +let shift vector = function + | Formula (Expression f) -> Formula (Expression (ScTypes.Expr.shift_exp vector f)) | other -> other let (=) t1 t2 = match t1, t2 with diff --git a/src/expression.mli b/src/expression.mli index 8cab479..5867d48 100755 --- a/src/expression.mli +++ b/src/expression.mli @@ -1,10 +1,10 @@ type t = - | Basic: 'a ScTypes.types -> t (** A direct type *) - | Formula: formula -> t (** A formula *) - | Undefined: t (** The content is not defined *) + | Basic: 'a ScTypes.Type.t -> 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 *) + | Expression of ScTypes.Expr.t (** A valid Expr.t *) | Error of int * UTF8.t (** When the expression cannot be parsed *) @@ -16,7 +16,7 @@ val load_expr: t -> t val is_defined: t -> bool (** Evaluate the expression *) -val eval: t -> (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.result +val eval: t -> Functions.C.t -> ((int * int) -> ScTypes.Result.t option) -> ScTypes.Result.t (** Collect all the cell referenced in the expression *) val collect_sources: t -> Cell.Set.t diff --git a/src/expressionParser.mly b/src/expressionParser.mly index 473797f..1c2769c 100755 --- a/src/expressionParser.mly +++ b/src/expressionParser.mly @@ -1,11 +1,19 @@ %{ open ScTypes + open ScTypes.Result module S = Symbols let u = UTF8.from_utf8string let extractColumnNameFromNum (fixed, (str, value)) = (fixed, value) + let build_call ident = function + | [] -> Expr.call0 ident + | [p1] -> Expr.call1 ident p1 + | [p1;p2] -> Expr.call2 ident p1 p2 + | [p1;p2;p3] -> Expr.call3 ident p1 p2 p3 + | n -> Expr.callN ident n + %} %token REAL @@ -34,8 +42,8 @@ %left TIMES DIVIDE %left POW -%start value -%start content +%start value +%start content %% @@ -46,18 +54,18 @@ content: | basic EOF {$1} basic: - | PLUS num {Result (number $2)} - | MINUS num {Result (number (DataType.Num.neg $2))} - | num {Result (number $1)} - | NUM DIVIDE NUM DIVIDE NUM {Result ( - date ( - DataType.Date.get_julian_day + | PLUS num {Ok (Type.number $2)} + | MINUS num {Ok (Type.number (DataType.Num.neg $2))} + | num {Ok (Type.number $1)} + | NUM DIVIDE NUM DIVIDE NUM {Ok ( + Type.date ( + DataType.Date.get_julian_day (int_of_string $1) (int_of_string $3) (int_of_string $5) ))} - | NUM COLON NUM COLON NUM {Result ( - date ( + | NUM COLON NUM COLON NUM {Ok ( + Type.date ( let nhour = DataType.Num.div (DataType.Num.of_int @@ int_of_string $1) (DataType.Num.of_int 24) and nmin = DataType.Num.div (DataType.Num.of_int @@ int_of_string $3) (DataType.Num.of_int 1440) and nsec = DataType.Num.div (DataType.Num.of_int @@ int_of_string $5) (DataType.Num.of_int 86400) @@ -66,34 +74,34 @@ basic: )} expr: - | num {Value (number ($1))} - | MINUS expr {Call (S.sub, [$2])} - | PLUS expr {Call (S.add, [$2])} + | num {Expr.value (Type.number ($1))} + | MINUS expr {Expr.call1 S.sub $2} + | PLUS expr {Expr.call1 S.add $2} - | LETTERS ident LPAREN separated_list(SEMICOLON, expr) RPAREN { Call (u($1 ^ $2), $4) } + | LETTERS ident LPAREN separated_list(SEMICOLON, expr) RPAREN { build_call (u($1 ^ $2)) $4 } - | cell {Ref (Cell $1)} - | cell COLON cell {Ref (Range ($1, $3))} + | cell {Expr.ref (Refs.cell $1)} + | cell COLON cell {Expr.ref (Refs.range $1 $3)} - | LPAREN expr RPAREN {Expression $2} - | STR {Value (string (u $1))} + | LPAREN expr RPAREN {Expr.expression $2} + | STR {Expr.value (Type.string (u $1))} (* Mathematical operators *) - | expr MINUS expr {Call (S.sub, [$1; $3])} - | expr DIVIDE expr {Call (S.div, [$1; $3])} - | expr TIMES expr {Call (S.mul, [$1; $3])} - | expr PLUS expr {Call (S.add, [$1; $3])} - | expr POW expr {Call (S.pow, [$1; $3])} + | expr MINUS expr {Expr.call2 S.sub $1 $3} + | expr DIVIDE expr {Expr.call2 S.div $1 $3} + | expr TIMES expr {Expr.call2 S.mul $1 $3} + | expr PLUS expr {Expr.call2 S.add $1 $3} + | expr POW expr {Expr.call2 S.pow $1 $3} (* Comparaison *) - | expr EQ expr {Call (S.eq, [$1; $3])} - | expr NEQ expr {Call (S.neq, [$1; $3])} - | expr LT expr {Call (S.lt, [$1; $3])} - | expr GT expr {Call (S.gt, [$1; $3])} - | expr LE expr {Call (S.le, [$1; $3])} - | expr GE expr {Call (S.ge, [$1; $3])} + | expr EQ expr {Expr.call2 S.eq $1 $3} + | expr NEQ expr {Expr.call2 S.neq $1 $3} + | expr LT expr {Expr.call2 S.lt $1 $3} + | expr GT expr {Expr.call2 S.gt $1 $3} + | expr LE expr {Expr.call2 S.le $1 $3} + | expr GE expr {Expr.call2 S.ge $1 $3} %inline cell: | LETTERS NUM { Cell.from_string (false, $1) (false, int_of_string $2) } diff --git a/src/expressions/collect_sources.ml b/src/expressions/collect_sources.ml new file mode 100755 index 0000000..d898b86 --- /dev/null +++ b/src/expressions/collect_sources.ml @@ -0,0 +1,69 @@ +module T = struct + + type 'a t = unit + + type 'a obs = ('a -> 'a) + + let str s = () + + let num n = () + + let date d = () + + let bool b = () + + let observe () x = x + +end + +module R = struct + + type 'a obs = Cell.Set.t -> Cell.Set.t + + type 'a t = 'a obs + + let cell (c:Cell.t) set = Cell.Set.add (Cell.to_pair c) set + + let range c1 c2 set = begin + + let x1, y1 = Cell.to_pair c1 + and x2, y2 = Cell.to_pair c2 in + + let f_x x acc = begin + let f_y y acc = begin + Cell.Set.add (x, y) acc + end in + Tools.fold_for f_y y1 y2 acc + end in + Tools.fold_for f_x x1 x2 set + end + + let observe elem set = elem set + + +end + +let observe f value = f value + +let value v () = T.observe v + +let ref r () = R.observe r + +let call0 ident () acc = acc + +let call1 ident p1 () acc = observe p1 acc + +let call2 ident p1 p2 () acc = observe p2 (observe p1 acc) + +let call3 ident p1 p2 p3 () acc = observe p3 (observe p2 (observe p1 acc)) + +let callN ident params () acc = List.fold_left (fun acc p -> observe p acc) acc params + +let expression e () = e + +type obs = Cell.Set.t -> Cell.Set.t + +type t = unit + +type repr = obs + diff --git a/src/expressions/eval_ref.ml b/src/expressions/eval_ref.ml new file mode 100755 index 0000000..d367d2d --- /dev/null +++ b/src/expressions/eval_ref.ml @@ -0,0 +1,136 @@ +type 'a range = + | Single of 'a + | Array1 of 'a list + | Array2 of 'a list list + +type content = + | Value: 'a ScTypes.DataFormat.t * 'a -> content + | List: 'a ScTypes.DataFormat.t * 'a list -> content + | Matrix: 'a ScTypes.DataFormat.t * 'a list list -> content + +(** Type for the mapper function. + + This function should be able to read the cell from the spreadsheet from + it coordinates, and return the associated value. + +*) +type mapper = (int * int -> ScTypes.Result.t option) + +type 'a t = mapper -> ScTypes.Result.t option range + +type 'a obs = mapper -> content + +let cell t mapper = begin + Single (mapper (Cell.to_pair t)) +end + +let range fst snd mapper = begin + let (x1, y1) = Cell.to_pair fst + and (x2, y2) = Cell.to_pair snd in + let min_x = min x1 x2 + and max_x = max x1 x2 + and min_y = min y1 y2 + and max_y = max y1 y2 in + if (min_x = max_x) || (min_y = max_y) then ( + (* There is only a one dimension array *) + 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 + done + done; + Array1 (!elms) + ) else ( + (* This a two-dimension array *) + let elmx = ref [] in + 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 + done; + elmx := !elmy::!elmx + done; + Array2 (!elmx) + ) +end + +module TypeContent = struct + + type 'a t = 'a ScTypes.DataFormat.t * 'a + + type value = Value: ('a ScTypes.DataFormat.t * 'a) -> value [@@unboxed] + + type 'a obs = value + + let str s = (ScTypes.DataFormat.String, s) + + let bool b = (ScTypes.DataFormat.Bool, b) + + let num n : DataType.Num.t t = (ScTypes.DataFormat.Number, n) + + let date d : DataType.Num.t t = (ScTypes.DataFormat.Date, d) + + let observe (f, t) = Value (f, t) + +end + +module M = ScTypes.Type.Eval(TypeContent) + +(** Add one element in a typed list. + + 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 = +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) -> + + 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 + format + else + format' in + new_format, element::elements + 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)) -> + 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 + (* 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 + (* 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 + (format, List.rev (elems::result)) + )(format, []) l in + Matrix(format, List.rev values) + end + + +let observe t mapper = get_content (t mapper) diff --git a/src/expressions/evaluate.ml b/src/expressions/evaluate.ml new file mode 100755 index 0000000..e910c19 --- /dev/null +++ b/src/expressions/evaluate.ml @@ -0,0 +1,142 @@ +(** Internal representation for each type *) +type 'a value = + | Bool: DataType.Bool.t -> DataType.Bool.t value + | Num: DataType.Num.t ScTypes.DataFormat.t * DataType.Num.t -> DataType.Num.t value + | String: DataType.String.t -> DataType.String.t value + | List: 'a ScTypes.DataFormat.t * 'a list -> 'a list value + | Matrix: 'a ScTypes.DataFormat.t * 'a list list -> 'a list list 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 + + type 'a obs = existencialResult + + let str s = String s + + let num n = Num (ScTypes.DataFormat.Number, n) + + let date d = Num (ScTypes.DataFormat.Date, d) + + let bool b = Bool b + + let observe x = Result x + +end + +module R = Eval_ref + +(** Extract the type and the content from a value *) +let get_argument: type a. a value -> a Functions.typ * a = function + | Bool b -> Functions.t_bool, b + | Num (_, n) -> Functions.t_int, n + | String s -> Functions.t_string, s + | List (t, l) -> Functions.t_list (Functions.typ_of_format t), l + | Matrix (t, l) -> Functions.t_list (Functions.t_list (Functions.typ_of_format t)), l + +let wrap_call (Functions.C.R(ret, res)) type_builder = begin + let returnType = ScTypes.ReturnType.guess_format_result ret type_builder in + begin match returnType with + | ScTypes.DataFormat.Bool -> T.observe (T.bool res) + | ScTypes.DataFormat.String -> T.observe (T.str res) + | ScTypes.DataFormat.Number -> T.observe (T.num res) + | ScTypes.DataFormat.Date -> T.observe (T.date res) + end +end + +(** Extract the format from a list of results *) +let build_format_list ll = + + List.map (fun (Result x) -> + begin match x with + | Bool _ -> ScTypes.DataFormat.F (ScTypes.DataFormat.Bool) + | Num (x, _) -> ScTypes.DataFormat.F x + | String _ -> ScTypes.DataFormat.F (ScTypes.DataFormat.String) + | List (f, _) -> ScTypes.DataFormat.F f + | Matrix (f, _) -> ScTypes.DataFormat.F f + end + ) ll + +let value v _ = T.observe v + +let ref r (_, mapper) = begin + match R.observe r mapper with + | R.Value (f, res) -> begin match f with + | ScTypes.DataFormat.Bool -> T.observe (T.bool res) + | ScTypes.DataFormat.String -> T.observe (T.str res) + | ScTypes.DataFormat.Number -> T.observe (T.num res) + | ScTypes.DataFormat.Date -> T.observe (T.date res) + end + | R.List (t, l) -> Result (List(t, l)) + | R.Matrix (t, l) -> Result (Matrix(t, l)) +end + +let call0 ident (catalog, _) = + let name' = UTF8.to_utf8string ident in + let arg1 = (Functions.t_unit, ()) in + wrap_call + (Functions.C.eval1 catalog name' arg1) + (fun () -> raise Errors.TypeError) + +let call1 ident p1 (catalog, _) = + let name' = UTF8.to_utf8string ident in + let (Result r1) = p1 in + let arg1 = get_argument r1 in + wrap_call + (Functions.C.eval1 catalog name' arg1) + (fun () -> build_format_list [p1]) + +let call2 ident p1 p2 (catalog, _) = + let name' = UTF8.to_utf8string ident in + let (Result r1) = p1 in + let (Result r2) = p2 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]) + +let call3 ident p1 p2 p3 (catalog, _) = + let name' = UTF8.to_utf8string ident in + let (Result r1) = p1 in + let (Result r2) = p2 in + let (Result r3) = p3 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]) + +let callN ident params (catalog, _) = + let signature = List.map (fun (Result r) -> + let formatter = Format.str_formatter in + Functions.repr formatter (fst @@ get_argument r); + Format.flush_str_formatter ()) 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/show_expr.ml b/src/expressions/show_expr.ml new file mode 100755 index 0000000..3a54929 --- /dev/null +++ b/src/expressions/show_expr.ml @@ -0,0 +1,62 @@ +let u = UTF8.from_utf8string + +module Show_Expr + (R:Sym_ref.SYM_REF with type 'a obs = (UTF8.Buffer.buffer -> unit)) + (T:Sym_type.SYM_TYPE with type 'a obs = (UTF8.Buffer.buffer -> unit)) = struct + + module T = T + module R = R + + type t = unit + type repr = 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 ref r () buffer = R.observe r buffer + + let call0 ident () buffer = + let utf8ident = UTF8.to_utf8string ident in + UTF8.Printf.bprintf buffer "%s()" utf8ident + + 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 utf8ident = UTF8.to_utf8string ident in + begin match utf8ident with + | "+" | "*" | "-" | "/" | "^" | "=" + | "<>" | "<=" | ">=" | "<" | ">" -> + UTF8.Printf.bprintf buffer "%a%s%a" + (fun x b -> observe b x) p1 + utf8ident + (fun x b -> observe b x) p2 + | _ -> + UTF8.Printf.bprintf buffer "%s(%a;%a)" + utf8ident + (fun x b -> observe b x) p1 + (fun x b -> observe b x) p2 + end + + let call3 ident p1 p2 p3 () buffer = + let utf8ident = UTF8.to_utf8string ident in + UTF8.Printf.bprintf buffer "%s(%a;%a;%a)" + utf8ident + (fun x b -> observe b x) p1 + (fun x b -> observe b x) p2 + (fun x b -> observe b x) p3 + + let callN ident (params: repr list) () buffer = + UTF8.Buffer.add_string buffer ident; + Tools.List.printb ~sep:(u";") (fun buffer value -> value buffer) buffer params + + let expression e () buffer = + UTF8.Printf.bprintf buffer "(%a)" + (fun x b -> b x) e + +end diff --git a/src/expressions/show_ref.ml b/src/expressions/show_ref.ml new file mode 100755 index 0000000..97d8022 --- /dev/null +++ b/src/expressions/show_ref.ml @@ -0,0 +1,11 @@ +type 'a t = UTF8.Buffer.buffer -> unit + +type 'a obs = UTF8.Buffer.buffer -> unit + +let cell t buffer = + UTF8.Buffer.add_string buffer @@ Cell.to_string t + +let range c1 c2 buffer = + Tools.Tuple2.printb ~first:"" ~last:"" ~sep:":" Cell.to_buffer Cell.to_buffer buffer (c1, c2) + +let observe elem buffer = elem buffer diff --git a/src/expressions/show_type.ml b/src/expressions/show_type.ml new file mode 100755 index 0000000..c459dca --- /dev/null +++ b/src/expressions/show_type.ml @@ -0,0 +1,26 @@ +type 'a t = UTF8.Buffer.buffer -> unit +type 'a obs = UTF8.Buffer.buffer -> unit + +let str s buffer = + UTF8.Buffer.add_string buffer s + +let num n buffer = + if DataType.Num.is_integer n then + DataType.Num.to_int n + |> string_of_int + |> UTF8.from_utf8string + |> UTF8.Buffer.add_string buffer + else + let f = DataType.Num.to_float n + and to_b = UTF8.Format.formatter_of_buffer buffer in + ignore @@ UTF8.Format.fprintf to_b "%.2f" f; + Format.pp_print_flush to_b () + +let date n buffer = + let y, m, d = DataType.Date.date_from_julian_day n in + UTF8.Printf.bprintf buffer "%d/%d/%d" y m d + +let bool b buffer = + UTF8.Printf.bprintf buffer "%B" b + +let observe elem buffer = elem buffer diff --git a/src/expressions/sym_expr.ml b/src/expressions/sym_expr.ml new file mode 100755 index 0000000..5ff828e --- /dev/null +++ b/src/expressions/sym_expr.ml @@ -0,0 +1,31 @@ +module type SYM_EXPR = sig + + module T:Sym_type.SYM_TYPE + + module R:Sym_ref.SYM_REF + + type t + + type repr + + type obs + + val value : 'a T.t -> t -> repr + + val ref : 'a R.t -> t -> repr + + val call0 : UTF8.t -> t -> repr + + val call1 : UTF8.t -> repr -> t -> repr + + val call2 : UTF8.t -> repr -> repr -> t -> repr + + val call3 : UTF8.t -> repr -> repr -> repr -> t -> repr + + val callN: UTF8.t -> repr list -> t -> repr + + val expression : repr -> t -> repr + + val observe : repr -> obs + +end diff --git a/src/expressions/sym_ref.ml b/src/expressions/sym_ref.ml new file mode 100755 index 0000000..aba8053 --- /dev/null +++ b/src/expressions/sym_ref.ml @@ -0,0 +1,12 @@ +module type SYM_REF = sig + + type 'a t + + type 'a obs + + val cell : Cell.t -> 'a t + + val range : Cell.t -> Cell.t -> 'a t + + val observe : 'a t -> 'a obs +end diff --git a/src/expressions/sym_type.ml b/src/expressions/sym_type.ml new file mode 100755 index 0000000..31c9534 --- /dev/null +++ b/src/expressions/sym_type.ml @@ -0,0 +1,18 @@ +module type SYM_TYPE = sig + + type 'a t + + type 'a obs + + val str : DataType.String.t -> DataType.String.t t + + val num : DataType.Num.t -> DataType.Num.t t + + val date: DataType.Num.t -> DataType.Num.t t + + val bool : DataType.Bool.t -> DataType.Bool.t t + + val observe : 'a t -> 'a obs + +end + diff --git a/src/functions.ml b/src/functions.ml index 62426e9..309de6c 100755 --- a/src/functions.ml +++ b/src/functions.ml @@ -14,11 +14,11 @@ let t_int: DataType.Num.t typ = Num let t_string: UTF8.t typ = String let t_list (t: 'a typ): 'a list typ = List t -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 typ_of_format: type a. a ScTypes.DataFormat.t -> a typ = function + | ScTypes.DataFormat.Date -> Num + | ScTypes.DataFormat.Number -> Num + | ScTypes.DataFormat.String -> String + | ScTypes.DataFormat.Bool -> Bool let rec repr: @@ -53,16 +53,16 @@ module C = Catalog.Make(struct type 'a t = 'a typ - type 'a returnType = 'a ScTypes.returnType + type 'a returnType = 'a ScTypes.ReturnType.t end) -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 +let f_num = ScTypes.ReturnType.f_num +let f_date = ScTypes.ReturnType.f_date +let f_number = ScTypes.ReturnType.f_number +let f_string = ScTypes.ReturnType.f_string +let f_bool = ScTypes.ReturnType.f_bool module Make_Compare(Comp: D.COMPARABLE) = struct diff --git a/src/functions.mli b/src/functions.mli index c6904b2..43a6fc2 100755 --- a/src/functions.mli +++ b/src/functions.mli @@ -9,13 +9,13 @@ val t_int: DataType.Num.t typ val t_string: UTF8.t typ val t_list: 'a typ -> 'a list typ -val typ_of_format: 'a ScTypes.dataFormat -> 'a typ +val typ_of_format: 'a ScTypes.DataFormat.t -> 'a typ val repr: Format.formatter -> 'a typ -> unit module C : Catalog.CATALOG with type 'a argument = 'a typ - and type 'a returnType = 'a ScTypes.returnType + and type 'a returnType = 'a ScTypes.ReturnType.t (** Load all the built_in functions *) val built_in: C.catalog_builder -> C.catalog_builder diff --git a/src/main.ml b/src/main.ml index 4491025..8e557ce 100755 --- a/src/main.ml +++ b/src/main.ml @@ -1,3 +1,5 @@ +module E:Sym_expr.SYM_EXPR = Evaluate + let u = UTF8.from_utf8string let redraw t screen = @@ -13,6 +15,8 @@ let action f msg (t, screen) = begin t', screen' end +let catalog = Functions.C.compile @@ Functions.built_in Functions.C.empty + let f screen = ActionParser.( begin match Screen.read_key screen with | "\027" -> ESC @@ -127,14 +131,17 @@ let rec normal_mode (t, screen) = begin normal_mode @@ redraw t' screen end +(* | Actions.Search -> let expr = Screen.search screen |> Expression.load in - let pattern = Expression.eval expr (fun _ -> ScTypes.Refs.Single None) in + (*let pattern = Expression.eval expr (fun _ -> ScTypes.Refs.Single None) in*) + let pattern = Expression.eval' expr catalog in begin match Sheet.search (`Pattern (Some pattern)) t with | Some t' -> normal_mode @@ redraw t' screen | None -> normal_mode (t, screen) end +*) | Actions.Button1_clicked coord -> begin match Screen.get_cell screen coord with @@ -227,7 +234,7 @@ and command (t, screen) action = begin normal_mode @@ redraw t screen *) | ("enew", _) -> (* Start a new spreadsheet *) - normal_mode @@ redraw (Sheet.create Sheet.Raw.empty) screen + normal_mode @@ redraw (Sheet.create catalog Sheet.Raw.empty) screen | ("q", _) -> (* Quit *) t | _ -> normal_mode @@ redraw t screen @@ -235,16 +242,12 @@ end let () = begin - let catalog = Functions.built_in Functions.C.empty in - ignore @@ Evaluator.set_catalog (Functions.C.compile catalog); - - let sheet = if Array.length Sys.argv = 1 then Sheet.Raw.empty else - Odf.load Sys.argv.(1) in + Odf.load catalog Sys.argv.(1) in Screen.run (fun window -> - ignore @@ normal_mode @@ redraw (Sheet.create sheet) window) + ignore @@ normal_mode @@ redraw (Sheet.create catalog sheet) window) end diff --git a/src/odf/odf.ml b/src/odf/odf.ml index 048be2e..176e70a 100755 --- a/src/odf/odf.ml +++ b/src/odf/odf.ml @@ -5,14 +5,14 @@ let u = UTF8.from_utf8string type t -let load_xml input = begin +let load_xml catalog input = begin let source = Xmlm.make_input ~enc:(Some `UTF_8) (`Channel input) in - let sheet = OdfLoader.load source in + let sheet = OdfLoader.load catalog source in sheet end -let load file = +let load catalog file = let tmp_file = Filename.temp_file "content" ".xml" in Unix.unlink tmp_file; @@ -22,14 +22,13 @@ let load file = let input = open_in_bin tmp_file in Tools.try_finally - (fun () -> load_xml input) + (fun () -> load_xml catalog input) (fun () -> close_in input; Unix.unlink tmp_file; Zip.close_in zip ) - let write_type ovalue_type cvalue_type attrs output value = begin let attrs = (NS.ovalue_type_attr, ovalue_type):: @@ -50,87 +49,86 @@ let write_bool = write_type "bool" "bool" let write_error = write_type "string" "error" let write_date = write_type "date" "date" -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.Num (data_type, d) -> - begin match ScTypes.get_numeric_type data_type with - | ScTypes.Number -> - let f = DataType.Num.to_float d in - let value = string_of_float f in - write_num ((NS.value_attr, value)::attrs) output value - | ScTypes.Date -> - let value = DataType.Date.to_string d in - write_date ((NS.date_value_attr, value)::attrs) output value - end -end +module BasicWriter = ScTypes.Type.Eval(struct + + type 'a t = (Xmlm.attribute list -> Xmlm.output -> unit) + type 'a obs = 'a t + + let str s attrs output = write_str attrs output (UTF8.to_utf8string s) + + let bool b attrs output = write_bool attrs output (string_of_bool b) + + let num n attrs output = + let f = DataType.Num.to_float n in + let value = string_of_float f in + write_num ((NS.value_attr, value)::attrs) output value + + let date d attrs output = + let value = DataType.Date.to_string d in + write_date ((NS.date_value_attr, value)::attrs) output value + + let observe value attrs output = value attrs output + +end) + +let write_basic: type a. 'b list -> Xmlm.output -> a ScTypes.Type.t -> unit = fun attrs output types -> + BasicWriter.eval types attrs output let write_formula output attrs f = begin function - | ScTypes.Result x -> write_basic attrs output x - | ScTypes.Error exn -> write_str attrs output "#NAME?" + | ScTypes.Result.Ok x -> write_basic attrs output x + | ScTypes.Result.Error exn -> write_str attrs output "#NAME?" end -let print_ref buffer c = - UTF8.Buffer.add_string buffer @@ u"[."; - begin match c with - | ScTypes.Cell c -> UTF8.Buffer.add_string buffer @@ Cell.to_string c; - | ScTypes.Range (c1, c2) -> +(** Print a reference *) +module Show_ref = struct + type 'a t = UTF8.Buffer.buffer -> unit + + type 'a obs = UTF8.Buffer.buffer -> unit + + let cell t buffer = + UTF8.Buffer.add_string buffer @@ u"[."; + UTF8.Buffer.add_string buffer @@ Cell.to_string t; + UTF8.Buffer.add_string buffer @@ u"]" + + let range c1 c2 buffer = + UTF8.Buffer.add_string buffer @@ u"[."; UTF8.Buffer.add_string buffer @@ Cell.to_string c1; UTF8.Buffer.add_string buffer @@ u":."; UTF8.Buffer.add_string buffer @@ Cell.to_string c2; - end; - UTF8.Buffer.add_string buffer @@ u"]" - -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 @@ u"]" + + let observe elem buffer = elem buffer +end + +module Show_type = struct + type 'a t = UTF8.Buffer.buffer -> unit + type 'a obs = UTF8.Buffer.buffer -> unit + + let str s buffer = + UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string s) + + let num n buffer = + let f = DataType.Num.to_float n in + UTF8.Buffer.add_string buffer @@ u(string_of_float f) + + let date n buffer = DataType.Date.to_string n + |> u |> UTF8.Buffer.add_string buffer - | ScTypes.Value (ScTypes.Num (data_type, d)) -> - begin match ScTypes.get_numeric_type data_type with - | ScTypes.Number -> - let f = DataType.Num.to_float d in - UTF8.Buffer.add_string buffer @@ u(string_of_float f) - | ScTypes.Date -> - DataType.Date.to_string d - |> u - |> UTF8.Buffer.add_string buffer - end - | ScTypes.Ref r -> print_ref buffer r - | ScTypes.Expression x -> - UTF8.Buffer.add_char buffer '('; - print_expr buffer x; - UTF8.Buffer.add_char buffer ')'; - | ScTypes.Call (ident, params) -> - begin match (UTF8.to_utf8string ident) with - | "+" | "*" | "-" | "/" | "^" | "=" - | "<>" | "<=" | ">=" | "<" | ">" -> begin match params with - | v1::[] -> - UTF8.Printf.bprintf buffer "%s%a" - (UTF8.to_utf8string ident) - print_expr v1 - | v1::v2::[] -> - UTF8.Printf.bprintf buffer "%a%s%a" - print_expr v1 - (UTF8.to_utf8string ident) - print_expr v2 - | _ -> - UTF8.Buffer.add_string buffer ident; - Tools.List.printb ~sep:(u";") print_expr buffer params - end - | _ -> - UTF8.Buffer.add_string buffer ident; - Tools.List.printb ~sep:(u";") print_expr buffer params - end + + let bool b buffer = + UTF8.Buffer.add_string buffer @@ u(string_of_bool b) + + let observe elem buffer = elem buffer end +module ExpressionPrinter = ScTypes.Expr.Eval(Show_expr.Show_Expr(Show_ref)(Show_type)) + let write_cell output value = begin function | Expression.Undefined -> () | Expression.Basic b -> write_basic [] output b | Expression.Formula (Expression.Expression f) -> let buffer = UTF8.Buffer.create 10 in - print_expr buffer f; + ExpressionPrinter.eval f () buffer; let formula = UTF8.Buffer.contents buffer |> UTF8.to_utf8string in write_formula output [(NS.formula_attr, ("of:=" ^formula))] f value diff --git a/src/odf/odfLoader.ml b/src/odf/odfLoader.ml index 9420fdd..93a6c62 100755 --- a/src/odf/odfLoader.ml +++ b/src/odf/odfLoader.ml @@ -16,18 +16,18 @@ end let load_content cache content = begin function | "float" -> Expression.Basic ( - ScTypes.number ( + ScTypes.Type.number ( DataType.Num.of_float (float_of_string content) )) | "date" -> Expression.Basic ( - ScTypes.date ( + ScTypes.Type.date ( DataType.Num.of_float (float_of_string content) )) | _ -> (* If the same text is present many times, use the same string instead of creating a new one *) memoization cache content (fun content -> Expression.Basic ( - ScTypes.string ( + ScTypes.Type.string ( UTF8.from_utf8string content))) end @@ -83,7 +83,7 @@ let build_p (attributes:Xmlm.attribute list) = begin function end -let build_row (sheet:Sheet.Raw.t ref) (row_num:int ref) (attributes:Xmlm.attribute list) (childs:tree list) = begin +let build_row (sheet:Sheet.Raw.t ref) (row_num:int ref) catalog (attributes:Xmlm.attribute list) (childs:tree list) = begin let repetition = try int_of_string @@ List.assoc (NS.table, "number-rows-repeated") attributes @@ -94,7 +94,7 @@ let build_row (sheet:Sheet.Raw.t ref) (row_num:int ref) (attributes:Xmlm.attribu List.iter (function | Cell cell -> for i = 1 to cell.repetition do - sheet := snd @@ Sheet.Raw.add (!cell_num, !row_num) cell.expression !sheet; + sheet := snd @@ Sheet.Raw.add (!cell_num, !row_num) cell.expression catalog !sheet; cell_num := !cell_num + cell.cell_width done; | _ -> () @@ -106,7 +106,7 @@ end let data str = Data str -let load source = begin +let load catalog source = begin (* Mutable datas *) let sheet = ref Sheet.Raw.empty in @@ -115,7 +115,7 @@ let load source = begin let table = Base.String_dict.of_alist_exn [ ((NS.text ^ "p"), build_p); ((NS.table ^ "table-cell"), build_cell cache); - ((NS.table ^ "table-row"), build_row sheet (ref 1)) + ((NS.table ^ "table-row"), build_row sheet (ref 1) catalog) ] in let el (((ns, name), attributes):Xmlm.tag) childs = begin diff --git a/src/odf/odf_ExpressionParser.mly b/src/odf/odf_ExpressionParser.mly index 54836cd..2acd1b8 100755 --- a/src/odf/odf_ExpressionParser.mly +++ b/src/odf/odf_ExpressionParser.mly @@ -6,6 +6,13 @@ let extractColumnNameFromNum (fixed, str) = (fixed, int_of_string str) + let build_call ident = function + | [] -> Expr.call0 ident + | [p1] -> Expr.call1 ident p1 + | [p1;p2] -> Expr.call2 ident p1 p2 + | [p1;p2;p3] -> Expr.call3 ident p1 p2 p3 + | n -> Expr.callN ident n + %} %token REAL @@ -35,7 +42,7 @@ %left TIMES DIVIDE %left POW -%start value +%start value %% @@ -43,37 +50,36 @@ value: | LETTERS COLON EQ expr EOF {$4} expr: - | num {Value (number ($1))} - | MINUS expr {Call (S.sub, [$2])} - | PLUS expr {Call (S.add, [$2])} + | num {Expr.value (Type.number ($1))} + | MINUS expr {Expr.call1 S.sub $2} + | PLUS expr {Expr.call1 S.add $2} | L_SQ_BRACKET ref R_SQ_BRACKET {$2} - | LPAREN expr RPAREN {Expression $2} - | STR {Value (string (u $1))} + | LPAREN expr RPAREN {Expr.expression $2} + | STR {Expr.value (Type.string (u $1))} (* Mathematical operators *) - | expr MINUS expr {Call (S.sub, [$1; $3])} - | expr DIVIDE expr {Call (S.div, [$1; $3])} - | expr TIMES expr {Call (S.mul, [$1; $3])} - | expr PLUS expr {Call (S.add, [$1; $3])} - | expr POW expr {Call (S.pow, [$1; $3])} + | expr MINUS expr {Expr.call2 S.sub $1 $3} + | expr DIVIDE expr {Expr.call2 S.div $1 $3} + | expr TIMES expr {Expr.call2 S.mul $1 $3} + | expr PLUS expr {Expr.call2 S.add $1 $3} + | expr POW expr {Expr.call2 S.pow $1 $3} (* Comparaison *) - | expr EQ expr {Call (S.eq, [$1; $3])} - | expr NEQ expr {Call (S.neq, [$1; $3])} - | expr LT expr {Call (S.lt, [$1; $3])} - | expr GT expr {Call (S.gt, [$1; $3])} - | expr LE expr {Call (S.le, [$1; $3])} - | expr GE expr {Call (S.ge, [$1; $3])} - - | ident LPAREN separated_list(SEMICOLON, expr) RPAREN { Call (u $1, $3) } + | expr EQ expr {Expr.call2 S.eq $1 $3} + | expr NEQ expr {Expr.call2 S.neq $1 $3} + | expr LT expr {Expr.call2 S.lt $1 $3} + | expr GT expr {Expr.call2 S.gt $1 $3} + | expr LE expr {Expr.call2 S.le $1 $3} + | expr GE expr {Expr.call2 S.ge $1 $3} + | ident LPAREN separated_list(SEMICOLON, expr) RPAREN { build_call (u $1) $3 } ref: - | cell {Ref (Cell $1)} - | cell COLON cell {Ref (Range ($1, $3))} + | cell {Expr.ref (Refs.cell $1)} + | cell COLON cell {Expr.ref (Refs.range $1 $3)} cell: | DOT fixed(LETTERS) fixed(NUM){Cell.from_string $2 (extractColumnNameFromNum $3)} diff --git a/src/scTypes.ml b/src/scTypes.ml index fc6dd1f..ef39af3 100755 --- a/src/scTypes.ml +++ b/src/scTypes.ml @@ -4,87 +4,29 @@ let u = UTF8.from_utf8string exception Error -type cell = Cell.t - -type ident = UTF8.t - -type _ dataFormat = - | Date: DataType.Num.t dataFormat (* Date *) - | Number: DataType.Num.t dataFormat (* Number *) - | String: DataType.String.t dataFormat(* String *) - | Bool: DataType.Bool.t dataFormat (* Boolean *) - -type numericType = - | Date - | Number - -let get_numeric_type: DataType.Num.t dataFormat -> numericType = function - | Date -> Date - | Number -> Number - -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 *) - -let number n = Num (Number, n) -let string s = Str s -let date d = Num (Date, d) -let boolean b = Bool b - - -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 refs = - | Cell of cell (** A cell *) - | Range of cell * cell (** An area of cells *) - -type 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 : 'a types -> result - | Error : exn -> result - module DataFormat = struct - type formats = F : 'a dataFormat -> formats [@@unboxed] + type _ t = + | Date: DataType.Num.t t (* Date *) + | Number: DataType.Num.t t (* Number *) + | String: DataType.String.t t(* String *) + | Bool: DataType.Bool.t t (* Boolean *) + + type formats = F : 'a t -> formats [@@unboxed] - let priority: type a. a dataFormat -> int = function + let priority: type a. a t -> int = function | Date -> 1 | Number -> 0 | String -> 0 | Bool -> 0 - let collect_format: DataType.Num.t dataFormat -> formats -> DataType.Num.t dataFormat = begin + let collect_format: DataType.Num.t t -> formats -> DataType.Num.t t = begin fun dataFormat -> function | F Date -> Date | _ -> dataFormat end - let guess_format_result: type a. a returnType -> (unit -> formats list) -> a dataFormat = - fun return params -> begin match return with - | Str -> String - | Bool -> Bool - | Num (Some x) -> x - | Num None -> List.fold_left collect_format Number (params ()) - end - - let default_value_for: type a. a dataFormat -> a = function + let default_value_for: type a. a t -> a = function | Date -> DataType.Num.zero | Number -> DataType.Num.zero | Bool -> false @@ -92,7 +34,7 @@ module DataFormat = struct type ('a, 'b) equality = Eq : ('a, 'a) equality - let compare_format: type a b. a dataFormat -> b dataFormat -> (a, b) equality = + let compare_format: type a b. a t -> b t -> (a, b) equality = fun a b -> begin match a, b with | Date, Date -> Eq | String, String -> Eq @@ -107,117 +49,44 @@ end module Type = struct - let (=) : type a b. a types -> b types -> bool = fun t1 t2 -> + type 'a t = + | Num : DataType.Num.t DataFormat.t * DataType.Num.t -> DataType.Num.t t (** A number *) + | Str : DataType.String.t -> DataType.String.t t (** A string *) + | Bool : DataType.Bool.t -> DataType.Bool.t t (** A boolean *) + + let number n = Num (Number, n) + let string s = Str s + let date d = Num (Date, d) + let boolean b = Bool b + + let (=) : type a b. a t -> b t -> bool = fun t1 t2 -> match t1, t2 with | 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 - *) - let rec show_list printer buffer = begin function - | [] -> () - | hd::[] -> - UTF8.Printf.bprintf buffer "%a" - printer hd - | hd::tl -> - UTF8.Printf.bprintf buffer "%a, " - printer hd; - show_list printer buffer tl - end - - let 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 - | Num (Number, n) -> - if DataType.Num.is_integer n then - DataType.Num.to_int n - |> string_of_int - |> UTF8.from_utf8string - |> UTF8.Buffer.add_string buffer - else - let f = DataType.Num.to_float n - and to_b = UTF8.Format.formatter_of_buffer buffer in - ignore @@ UTF8.Format.fprintf to_b "%.2f" f; - Format.pp_print_flush to_b () - | Num (Date, n) -> - let y, m, d = DataType.Date.date_from_julian_day n in - UTF8.Printf.bprintf buffer "%d/%d/%d" y m d - end + module Eval(T:Sym_type.SYM_TYPE) = struct - let show_full: 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 - | Num (Number, n) -> - if DataType.Num.is_integer n then - DataType.Num.to_int n - |> string_of_int - |> UTF8.from_utf8string - |> UTF8.Buffer.add_string buffer - else - let f = DataType.Num.to_float n - and to_b = UTF8.Format.formatter_of_buffer buffer in - ignore @@ UTF8.Format.fprintf to_b "%f" f; - Format.pp_print_flush to_b () - | Num (Date, n) -> - let y, m, d = DataType.Date.date_from_julian_day n in - UTF8.Printf.bprintf buffer "%d/%d/%d" y m d - end + let eval_type : type a. a t -> a T.t = function + | Str s -> T.str s + | Bool b -> T.bool b + | Num (f, n) -> + match f with + | DataFormat.Number -> T.num n + | DataFormat.Date -> T.date n - type t = - | Value: 'a dataFormat * 'a -> t + let eval t = T.observe (eval_type t) - let get_content : type a. a types -> t = begin function - | Num (format, data) -> Value (format, data) - | Str s -> Value (String, s) - | Bool b -> Value (Bool, b) end end module Refs = struct - type 'a range = - | Single of 'a - | Array1 of 'a list - | Array2 of 'a list list - - let collect = function - | Cell x -> Single (Pervasives.fst x) - | Range (fst, snd) -> - let (x1, y1) = Pervasives.fst fst - and (x2, y2) = Pervasives.fst snd in - let min_x = min x1 x2 - and max_x = max x1 x2 - and min_y = min y1 y2 - and max_y = max y1 y2 in - if (min_x = max_x) || (min_y = max_y) then ( - (* There is only a one dimension array *) - let elms = ref [] in - for x = min_x to max_x do - for y = min_y to max_y do - elms := (x, y)::!elms - done - done; - Array1 (!elms) - ) else ( - (* This a two-dimension array *) - let elmx = ref [] in - for x = min_x to max_x do - let elmy = ref [] in - for y = min_y to max_y do - elmy := (x, y)::!elmy - done; - elmx := !elmy::!elmx - done; - Array2 (!elmx) - ) - - let map f = function - | Single coord -> Single (f coord) - | Array1 values -> Array1 (List.map f values) - | Array2 values -> Array2 (List.map (List.map f) values) + type t = + | Cell of Cell.t (** A cell *) + | Range of Cell.t * Cell.t (** An area of cells *) let shift (vector_x, vector_y) ref = let _shift ((x, y), (fixed_x, fixed_y)) = @@ -228,74 +97,90 @@ module Refs = struct | Cell x -> Cell (_shift x) | Range (fst, snd) -> Range (_shift fst, _shift snd) - let show buffer = begin function - | Cell r -> UTF8.Buffer.add_string buffer @@ Cell.to_string r - | Range (f,t) -> - Tools.Tuple2.printb ~first:"" ~last:"" ~sep:":" Cell.to_buffer Cell.to_buffer buffer (f,t) + let cell c = Cell c + let range c1 c2 = Range (c1, c2) + + module Eval(R:Sym_ref.SYM_REF) = struct + + let eval_ref = function + | Cell c -> R.cell c + | Range(c1, c2) -> R.range c1 c2 + + let eval t = R.observe (eval_ref t) + end - type content = - | Value: 'a dataFormat * 'a -> content - | List: 'a dataFormat * 'a list -> content - | Matrix: 'a dataFormat * 'a list list -> content - - (** Add one element in a typed list. - - The function will raise Error.TypeError if the elements does not match - with the list type. - *) - let add_elem: type a b. a dataFormat * a list -> result option -> a dataFormat * a list = - fun (format, elements) result -> - begin match result with - | None -> format, (DataFormat.default_value_for format)::elements - | Some (Error x) -> raise x - | Some (Result r) -> - let Type.Value (format', element) = Type.get_content r in - let DataFormat.Eq = DataFormat.compare_format format format' in - let new_format = if (DataFormat.priority format) > (DataFormat.priority format') then - format - else - format' in - new_format, element::elements +end + +module Expr = struct + + type ident = UTF8.t + + type t = + | Value : 'a Type.t -> t (** A direct value *) + | Ref : Refs.t -> t (** A reference to another cell *) + | Call0 : ident -> t (** A call to a 0 arg function *) + | Call1 : ident * t -> t (** A call to a 1 arg function *) + | Call2 : ident * t * t -> t (** A call to a 2 arg function *) + | Call3 : ident * t * t * t -> t (** A call to a 3 arg function *) + | CallN : ident * t list -> t (** A call to a function *) + | Expression : t -> t (** An expression *) + + let value v = Value v + let ref r = Ref r + let call0 ident = Call0 ident + let call1 ident expr = Call1 (ident, expr) + let call2 ident expr1 expr2 = Call2(ident, expr1, expr2) + let call3 ident expr1 expr2 expr3 = Call3(ident, expr1, expr2, expr3) + let callN ident params = CallN(ident, params) + let expression e = Expression e + + let rec shift_exp vector = function + | Value v -> Value v + | Call0 ident -> Call0 ident + | Call1 (ident, p1) -> Call1 (ident, shift_exp vector p1) + | Call2 (ident, p1, p2) -> Call2 (ident, shift_exp vector p1, shift_exp vector p2) + | Call3 (ident, p1, p2, p3) -> Call3 (ident, shift_exp vector p1, shift_exp vector p2, shift_exp vector p3) + | CallN (ident, params) -> CallN (ident, List.map (shift_exp vector) params) + | Ref r -> Ref (Refs.shift vector r) + | Expression expr -> Expression (shift_exp vector expr) + + module Eval(E:Sym_expr.SYM_EXPR) = struct + + module T = Type.Eval(E.T) + module R = Refs.Eval(E.R) + + let eval e t = begin + + let rec eval_expr : t -> E.repr = function + | Ref r -> E.ref (R.eval_ref r) t + | Value v -> E.value (T.eval_type v) t + | Call0 ident -> E.call0 ident t + | Call1 (ident, p1) -> E.call1 ident (eval_expr p1) t + | Call2 (ident, p1, p2) -> E.call2 ident (eval_expr p1) (eval_expr p2) t + | Call3 (ident, p1, p2, p3) -> E.call3 ident (eval_expr p1) (eval_expr p2) (eval_expr p3) t + | CallN (ident, exprs) -> E.callN ident (List.map (fun x -> eval_expr x) exprs) t + | Expression e -> E.expression (eval_expr e) t + in + E.observe (eval_expr e) end - let get_content = begin function - | Single None -> raise Errors.TypeError - | Single (Some (Error x)) -> raise x - | Single (Some (Result r)) -> - let Type.Value (format, c) = Type.get_content r in - Value (format, c) - | Array1 l -> - (* Get the first element in the list in order to get the format *) - let Type.Value (format, _) = - begin match (Tools.List.find_map (fun x -> x) l) with - | Error x -> raise x - | Result r -> Type.get_content 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 Type.Value (format, _) = - begin match (Tools.List.find_map2 (fun x -> x) l) with - | Error x -> raise x - | Result r -> Type.get_content 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 - (format, List.rev (elems::result)) - )(format, []) l in - Matrix(format, List.rev values) end end +module TypeRepr = Type.Eval(Show_type) + module Result = struct + + (** Result from a computation *) + type t = + | Ok : 'a Type.t -> t + | Error : exn -> t + let (=) t1 t2 = match t1, t2 with - | Result v1, Result v2 -> Type.(=) v1 v2 + | Ok v1, Ok v2 -> Type.(=) v1 v2 | _, _ -> t1 = t2 let show = begin function @@ -308,45 +193,33 @@ module Result = struct u(Buffer.contents buffer) *) u"#Error" - | Result v -> + | Ok v -> let buffer = UTF8.Buffer.create 16 in - Type.show buffer v; + TypeRepr.eval v buffer; UTF8.Buffer.contents buffer end end -(** Represent an expression. - *) -let rec show_expr buffer : expression -> unit = begin function - | Value (Str x) -> - (** Print the value with quotes *) - UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string x) - | Value v -> Type.show buffer v - | Ref r -> Refs.show buffer r - | Call (ident, params) -> - let utf8ident = UTF8.to_utf8string ident in - begin match utf8ident with - | "+" | "*" | "-" | "/" | "^" | "=" - | "<>" | "<=" | ">=" | "<" | ">" -> begin match params with - | v1::[] -> - UTF8.Printf.bprintf buffer "%s%a" - utf8ident - show_expr v1 - | v1::v2::[] -> - UTF8.Printf.bprintf buffer "%a%s%a" - show_expr v1 - utf8ident - show_expr v2 - | _ -> - UTF8.Buffer.add_string buffer ident; - Tools.List.printb ~sep:(u";") show_expr buffer params - end - | _ -> - UTF8.Buffer.add_string buffer ident; - Tools.List.printb ~sep:(u";") show_expr buffer params - end - | Expression expr -> - UTF8.Printf.bprintf buffer "(%a)" show_expr expr -end +module ReturnType = struct + + type 'a t = + | Num : DataType.Num.t DataFormat.t option -> DataType.Num.t t (** A number *) + | Str : DataType.String.t t (** A string *) + | Bool : DataType.Bool.t t (** A boolean *) + let f_num: DataType.Num.t t = Num None + let f_date: DataType.Num.t t = Num (Some Date) + let f_number: DataType.Num.t t = Num (Some Number) + let f_string: DataType.String.t t = Str + let f_bool: DataType.Bool.t t = Bool + + let guess_format_result: type a. a t -> (unit -> DataFormat.formats list) -> a DataFormat.t = + fun return params -> begin match return with + | Str -> DataFormat.String + | Bool -> DataFormat.Bool + | Num (Some x) -> x + | Num None -> List.fold_left DataFormat.collect_format DataFormat.Number (params ()) + end + +end diff --git a/src/scTypes.mli b/src/scTypes.mli index 46b48c6..f7bcc1b 100755 --- a/src/scTypes.mli +++ b/src/scTypes.mli @@ -1,123 +1,159 @@ (** All the types used in the spreadsheet. *) -exception Error +(** This module describe the most basic type use in the spreadsheet : every content is, -type cell = (int * int) * (bool * bool) +- either a ['a t] +- either an expression which result to one ['a t] -type ident = UTF8.t +*) +module Type : sig -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 *) - | Bool: DataType.Bool.t dataFormat (* Boolean *) + type 'a t -type numericType = - | Date - | Number + (** Create a new number *) + val number: DataType.Num.t -> DataType.Num.t t -val get_numeric_type: DataType.Num.t dataFormat -> numericType + (** Create a new string *) + val string: DataType.String.t -> DataType.String.t t -type 'a types = private - | 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 *) + (** Create a new boolean *) + val boolean: DataType.Bool.t -> DataType.Bool.t t -val number: DataType.Num.t -> DataType.Num.t types -val string: DataType.String.t -> DataType.String.t types -val boolean: DataType.Bool.t -> DataType.Bool.t types -val date: DataType.Num.t -> DataType.Num.t types + (** Create a new date *) + val date: DataType.Num.t -> DataType.Num.t t -(** Private type for an internal representation of return format *) -type 'a returnType + val (=) : 'a t -> 'b t -> bool -(** Numeric (any format) *) -val f_num: DataType.Num.t returnType + (** Evaluate a type and get the result *) + module Eval(T:Sym_type.SYM_TYPE): sig -(** Date *) -val f_date: DataType.Num.t returnType + val eval: 'a t -> 'a T.obs -(** Number *) -val f_number: DataType.Num.t returnType + end -(** Boolean result *) -val f_bool: DataType.Bool.t returnType +end -(** String *) -val f_string: DataType.String.t returnType +(** A reference to another cell. -type refs = - | Cell of cell (** A cell *) - | Range of cell * cell (** An area of cells *) +The reference can be a single cell (ie : A$1) or a range. -(** This is the cell content *) -type 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 *) +*) +module Refs : sig -(** Result from a computation *) -type result = - | Result : 'a types -> result - | Error : exn -> result + type t -module DataFormat : sig + val cell : Cell.t -> t + + val range : Cell.t -> Cell.t -> t + + val shift: (int * int) -> t -> t - type formats = F : 'a dataFormat -> formats [@@unboxed] + (** Evaluate a reference and get the result *) + module Eval(R:Sym_ref.SYM_REF): sig - val guess_format_result: 'a returnType -> (unit -> formats list) -> 'a dataFormat + val eval: t -> 'a R.obs + + end end -module Type : sig +module Expr : sig - type t = Value: 'a dataFormat * 'a -> t + type ident = UTF8.t - val (=) : 'a types -> 'b types -> bool + (** This is the cell content *) + type t - val show: UTF8.Buffer.buffer -> 'a types -> unit + (** Declare a direct value *) + val value: 'a Type.t -> t - val show_full: UTF8.Buffer.buffer -> 'a types -> unit + (** Declare a reference to another cell *) + val ref: Refs.t -> t -end + (** Declare a call to a 0 arg function *) + val call0: ident -> t -module Refs : sig + (** Declare a call to a 1 arg function *) + val call1 : ident -> t -> t - type 'a range = - | Single of 'a - | Array1 of 'a list - | Array2 of 'a list list + (** Declare a call to a 2 arg function *) + val call2 : ident -> t -> t -> t - (* Collect all the cells defined by a range. The cell are defined by their - coordinates *) - val collect: refs -> (int * int) range + (** Declare a call to a 3 arg function *) + val call3 : ident -> t -> t -> t -> t - val map: ('a -> 'b) -> 'a range -> 'b range - - val shift: (int * int) -> refs -> refs + (** Declare a call to a function *) + val callN : ident -> t list -> t - (** Each content from a reference contains a format and the appropriate value. *) - type content = - | Value: 'a dataFormat * 'a -> content - | List: 'a dataFormat * 'a list -> content - | Matrix: 'a dataFormat * 'a list list -> content + (** An expression *) + val expression : t -> t - (** extract the content from a range. + val shift_exp: (int * int) -> t -> t - May raise Errors.TypeError if the range cannot be unified. - *) - val get_content : result option range -> content + module Eval(E:Sym_expr.SYM_EXPR): sig + + val eval: t -> E.t -> E.obs + + end end -val show_expr: UTF8.Buffer.buffer -> expression -> unit +module DataFormat : sig + + type 'a t = + | Date: DataType.Num.t t (* A date in julian day *) + | Number: DataType.Num.t t (* Number *) + | String: DataType.String.t t (* String *) + | Bool: DataType.Bool.t t (* Boolean *) + + type formats = F : 'a t -> formats [@@unboxed] + + val default_value_for: 'a t -> 'a + + type ('a, 'b) equality = Eq : ('a, 'a) equality + + val compare_format: 'a t -> 'b t -> ('a, 'b) equality + + val priority: 'a t -> int + +end + +module ReturnType : sig + + (** Private type for an internal representation of return format *) + type 'a t + + (** Numeric (any format) *) + val f_num: DataType.Num.t t + + (** Date *) + val f_date: DataType.Num.t t + + (** Number *) + val f_number: DataType.Num.t t + + (** Boolean result *) + val f_bool: DataType.Bool.t t + + (** String *) + val f_string: DataType.String.t t + + val guess_format_result: 'a t -> (unit -> DataFormat.formats list) -> 'a DataFormat.t + +end module Result : sig - val (=) : result -> result -> bool + (** Result from a computation *) + type t = + | Ok : 'a Type.t -> t + | Error : exn -> t - val show: result -> UTF8.t + val (=) : t -> t -> bool + + val show: t -> UTF8.t end +exception Error + diff --git a/src/sheet.ml b/src/sheet.ml index 3dc83a0..6d3c34a 100755 --- a/src/sheet.ml +++ b/src/sheet.ml @@ -1,9 +1,7 @@ -module Option = Tools.Option - type cell = int * int type search = [ - | `Pattern of ScTypes.result option + | `Pattern of ScTypes.Result.t option | `Next | `Previous ] @@ -12,7 +10,7 @@ module Raw = struct type content = { expr : Expression.t; (** The expression *) - value : ScTypes.result option; (** The content evaluated *) + value : ScTypes.Result.t option; (** The content evaluated *) sink : Cell.Set.t; (** All the cell which references this one *) } @@ -29,7 +27,6 @@ module Raw = struct type t = Map.t - (** The sheet is a map which always contains evaluated values. When a cell is updated, all the cell which references this value are also updated. *) @@ -39,22 +36,12 @@ module Raw = struct let get_expr id t = (Map.find id t).expr - (** 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.result option ScTypes.Refs.range = begin - - ScTypes.Refs.collect ref - |> ScTypes.Refs.map (fun coord -> get_value coord t) - - end - (** Update the value for the given cell. Evaluate the new expression and compare it with the previous value. @return Some map if the map has been updated *) - let update cell content t = begin - let new_val = Expression.eval content.expr (get_ref cell t) in + let update catalog cell content t = begin + let new_val = Expression.eval content.expr catalog (fun id -> get_value id t) in match content.value with | None -> (* If the previous value wasn't defined, update the map *) @@ -68,54 +55,54 @@ module Raw = struct None end + exception Cycle of Cell.Set.t * t + (** Parse all the successors from an element, apply a function to each of them, and return them. The function is too long and should be rewriten… *) let rec traverse (f:(cell -> content -> t -> t option)) source (init, t) = begin + try Cell.Set.fold (successors init f init source) source.sink (init, t) + with Cycle (succ, t) -> (succ, t) + end - let exception Cycle of Cell.Set.t * t in - - let rec successors parents element (succ, t) = begin + and successors init f parents source element (succ, t) = begin - let content = Map.find element t in + let content = Map.find element t in - if Cell.Set.mem element parents then ( + 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 the cell has already been visited, mark it in error, and all the + descendant *) + let cycle_error = Some (ScTypes.Result.Error Errors.Cycle) in - 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) in - let succ, t = traverse set_error source (init, t) in - raise (Cycle (succ, t)) - ) + if content.value = cycle_error then ( + (* The content has already been updated, do not process it again *) + (succ, t) ) else ( - begin match f element content t with - | None -> - (* The content does not change, we do not update the successors *) - (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 - (succ', t') + 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 - Cell.Set.fold (successors parents') content.sink (succ', t') - end + 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)) ) - end in - try Cell.Set.fold (successors init) source.sink (init, t) - with Cycle (succ, t) -> (succ, t) + ) else ( + begin match f element content t with + | None -> + (* The content does not change, we do not update the successors *) + (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 + (succ', t') + else + Cell.Set.fold (successors init f parents' source) content.sink (succ', t') + end + ) end (** Remove the cell from the sheet *) @@ -156,15 +143,15 @@ module Raw = struct end end - let remove id t = begin + let remove id catalog t = begin match remove_element id t with | t, None -> Cell.Set.empty, t | t, Some content -> (** Update all the successors *) - traverse update content (Cell.Set.singleton id, t) + traverse (update catalog) content (Cell.Set.singleton id, t) end - let add_element id content_builder t = begin + let add_element catalog id content_builder t = begin (** Add the references in each sources. If the sources does not exists, create it. @@ -191,29 +178,29 @@ module Raw = struct in (** Update the value for each sink already evaluated *) - traverse update content (Cell.Set.singleton id, updated) + traverse (update catalog) content (Cell.Set.singleton id, updated) end - let add id expression t = begin + let add id expression catalog t = begin if not (Expression.is_defined expression) then (Cell.Set.empty, t) else let f cell t = begin { cell with expr = expression ; - value = Some (Expression.eval expression (get_ref id t)) } + value = Some (Expression.eval expression catalog (fun id -> get_value id t)) } end in - add_element id f t + add_element catalog id f t end - let paste id shift content t = begin + let paste catalog id shift content t = begin let expr = Expression.shift shift content.expr in let f cell t = { cell with expr = expr ; - value = Some (Expression.eval expr (get_ref id t)) + value = Some (Expression.eval expr catalog (fun id -> get_value id t)) } in - add_element id f t + add_element catalog id f t end let search pattern t = begin @@ -252,7 +239,8 @@ type t = { selected: Selection.t; (* The selected cell *) data: Raw.t; history: history; (* Unlimited history *) - yank: yank list + yank: yank list; + catalog: Functions.C.t; } let undo t = begin @@ -262,9 +250,9 @@ let undo t = begin let data = List.fold_left ( fun data (id, expression) -> if Expression.is_defined expression then - snd @@ Raw.add id expression data + snd @@ Raw.add id expression t.catalog data else - snd @@ Raw.remove id data + snd @@ Raw.remove id t.catalog data ) t.data hd in Some { t with data = data; history = tl} end @@ -284,9 +272,10 @@ let move direction t = Some {t with selected = Selection.create position'} let delete t = begin + let catalog = t.catalog in let history = Selection.fold (fun acc id -> (id, Raw.get_expr id t.data)::acc) [] t.selected in let count, data' = Selection.fold (fun (count, c) t -> - (count + 1, snd @@ Raw.remove t c)) (0, t.data) t.selected in + (count + 1, snd @@ Raw.remove t catalog c)) (0, t.data) t.selected in let t' = { t with data = data'; history = history::t.history @@ -313,6 +302,7 @@ let yank t = begin end let paste t = begin + let catalog = t.catalog in (* Origin of first cell *) let (shift_x, shift_y) as shift = Selection.extract t.selected in @@ -321,7 +311,7 @@ let paste t = begin id, Raw.get_expr id t.data) t.yank in let _paste (count, t) ((x, y), content) = begin - count + 1, snd @@ Raw.paste (shift_x + x, shift_y + y) shift content t + count + 1, snd @@ Raw.paste catalog (shift_x + x, shift_y + y) shift content t end in let count, data' = List.fold_left _paste (0, t.data) t.yank in @@ -332,7 +322,7 @@ end let add expression t = begin let id = Selection.extract t.selected in let prev_expression = Raw.get_expr id t.data in - let cells, data' = Raw.add id expression t.data in + let cells, data' = Raw.add id expression t.catalog t.data in cells, { t with data = data'; history = [id, prev_expression]::t.history } end @@ -345,9 +335,10 @@ let search action t = begin match action with | _ -> None end -let create data = { +let create catalog data = { data = data; selected = Selection.create (1, 1); history = []; yank = []; + catalog = catalog } diff --git a/src/sheet.mli b/src/sheet.mli index d768b8f..14856d4 100755 --- a/src/sheet.mli +++ b/src/sheet.mli @@ -12,21 +12,21 @@ module Raw: sig (** Add a new value in the sheet. The previous value is replaced @return All the successors to update and the new sheet. *) - val add: cell -> Expression.t -> t -> Cell.Set.t * t + val add: cell -> Expression.t -> Functions.C.t -> t -> Cell.Set.t * t - val remove: cell -> t -> Cell.Set.t * t + val remove: cell -> Functions.C.t -> t -> Cell.Set.t * t (** Get the value content. @return None if the cell is not defined *) - val get_value: cell -> t -> ScTypes.result option + val get_value: cell -> t -> ScTypes.Result.t option val get_expr: cell -> t -> Expression.t val get_sink: cell -> t -> Cell.Set.t (** Fold over all the defined values *) - val fold: ('a -> cell -> (Expression.t * ScTypes.result ) -> 'a) -> 'a -> t -> 'a + val fold: ('a -> cell -> (Expression.t * ScTypes.Result.t ) -> 'a) -> 'a -> t -> 'a end @@ -37,11 +37,12 @@ type t = { selected: Selection.t; (* The selected cell *) data: Raw.t; history: history; (* Unlimited history *) - yank: yank list (* All the selected cells *) + yank: yank list; (* All the selected cells *) + catalog: Functions.C.t } type search = [ - | `Pattern of ScTypes.result option + | `Pattern of ScTypes.Result.t option | `Next | `Previous ] @@ -75,5 +76,5 @@ val paste: t -> t * int val add: Expression.t -> t -> Cell.Set.t * t (** Create an empty sheet *) -val create: Raw.t -> t +val create: Functions.C.t -> Raw.t -> t diff --git a/src/tools.ml b/src/tools.ml index 7f500bf..8481d59 100755 --- a/src/tools.ml +++ b/src/tools.ml @@ -298,101 +298,11 @@ module ArrayMap(Ord: COMPARABLE_TYPE) = struct end -(** Map for any comparable value. - This map can bind 'a key -> 'a value as long as the key are comparable. - *) -module Map(Ord: COMPARABLE_TYPE) = struct - - type 'a key = 'a Ord.t - - type wrapper = Ex: 'a key * 'a -> wrapper - - type t = - | Empty : t - | Node : t * 'a key * 'a * t * int -> t - - let singleton x d = Node(Empty, x, d, Empty, 1) - - let empty = Empty - - let is_empty = function - | Empty -> true - | _ -> false - - let height = function - | Empty -> 0 - | Node(_,_,_,_,h) -> h - - let create l x d r = - let hl = height l and hr = height r in - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - let bal l x d r = - let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in - let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in - if hl > hr + 2 then begin - match l with - Empty -> invalid_arg "Map.bal" - | Node(ll, lv, ld, lr, _) -> - if height ll >= height lr then - create ll lv ld (create lr x d r) - else begin - match lr with - Empty -> invalid_arg "Map.bal" - | Node(lrl, lrv, lrd, lrr, _)-> - create (create ll lv ld lrl) lrv lrd (create lrr x d r) - end - end else if hr > hl + 2 then begin - match r with - Empty -> invalid_arg "Map.bal" - | Node(rl, rv, rd, rr, _) -> - if height rr >= height rl then - create (create l x d rl) rv rd rr - else begin - match rl with - Empty -> invalid_arg "Map.bal" - | Node(rll, rlv, rld, rlr, _) -> - create (create l x d rll) rlv rld (create rlr rv rd rr) - end - end else - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - - - let rec add: type a. a key -> a -> t -> t = begin fun x data t -> match t with - | Empty -> Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) -> - match Ord.comp x v with - | Eq -> Node(l, x, data, r, h) - | Lt -> bal (add x data l) v d r - | Gt -> bal l v d (add x data r) - end - - let rec find: type a. a key -> t -> a = begin fun x t -> match t with - | Empty -> raise Not_found - | Node(l, k, v, r, _) -> - match Ord.comp x k with - | Eq -> v - | Lt -> find x l - | Gt -> find x r - end +let fold_for f a b init = + let rec _fold res i = begin + if i >= b then res + else + _fold (f i res) (i + 1) + end in + (_fold[@tailcall]) init a - let rec mem: type a. a key -> t -> bool = begin fun x t -> match t with - | Empty -> false - | Node(l, k, v, r, _) -> - match Ord.comp x k with - | Eq -> true - | Lt -> mem x l - | Gt -> mem x r - end - - (* - let rec fold: ('a -> wrapper -> 'a) -> 'a -> t -> 'a = - begin fun f init t -> match t with - | Empty -> init - | Node(l, k, v, r, _) -> - let res_left = fold f init l in - let result = f res_left @@ Ex (k, v) in - fold f result r - end - *) -end -- cgit v1.2.3