aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorSébastien Dailly <sebastien@chimrod.com>2018-01-31 13:20:20 +0100
committerSébastien Dailly <sebastien@chimrod.com>2018-02-07 13:42:36 +0100
commit824f2987d47e87d58ee2a4a96d7be417aad6aeab (patch)
treebfbaca8d1c13a2eb1e5568f363cdcd6c94f1786f /src
parent112ab4b1c396fc2117191297227d8e411f9b9bb3 (diff)
API refactoring : made the GADT abstract, provide contructor for each case, and deported the
expression with evaluation with module functors
Diffstat (limited to 'src')
-rwxr-xr-xsrc/evaluator.ml150
-rwxr-xr-xsrc/evaluator.mli4
-rwxr-xr-xsrc/expression.ml86
-rwxr-xr-xsrc/expression.mli10
-rwxr-xr-xsrc/expressionParser.mly66
-rwxr-xr-xsrc/expressions/collect_sources.ml69
-rwxr-xr-xsrc/expressions/eval_ref.ml136
-rwxr-xr-xsrc/expressions/evaluate.ml142
-rwxr-xr-xsrc/expressions/show_expr.ml62
-rwxr-xr-xsrc/expressions/show_ref.ml11
-rwxr-xr-xsrc/expressions/show_type.ml26
-rwxr-xr-xsrc/expressions/sym_expr.ml31
-rwxr-xr-xsrc/expressions/sym_ref.ml12
-rwxr-xr-xsrc/expressions/sym_type.ml18
-rwxr-xr-xsrc/functions.ml22
-rwxr-xr-xsrc/functions.mli4
-rwxr-xr-xsrc/main.ml19
-rwxr-xr-xsrc/odf/odf.ml140
-rwxr-xr-xsrc/odf/odfLoader.ml14
-rwxr-xr-xsrc/odf/odf_ExpressionParser.mly48
-rwxr-xr-xsrc/scTypes.ml387
-rwxr-xr-xsrc/scTypes.mli190
-rwxr-xr-xsrc/sheet.ml129
-rwxr-xr-xsrc/sheet.mli15
-rwxr-xr-xsrc/tools.ml104
25 files changed, 1038 insertions, 857 deletions
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 <string> REAL
@@ -34,8 +42,8 @@
%left TIMES DIVIDE
%left POW
-%start<ScTypes.expression> value
-%start<ScTypes.result> content
+%start<ScTypes.Expr.t> value
+%start<ScTypes.Result.t> 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 <string> REAL
@@ -35,7 +42,7 @@
%left TIMES DIVIDE
%left POW
-%start<ScTypes.expression> value
+%start<ScTypes.Expr.t> 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