From 023c11470e32744a43b7e3c7c248f3c47ebdc687 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Mon, 21 Nov 2016 17:06:19 +0100 Subject: Use gadt for function catalog --- .gitignore | 3 + .merlin | 2 +- Makefile | 7 +- dataType.ml | 133 ++++++++++++ dataType.mli | 67 ++++++ errors.ml | 12 + evaluator.ml | 556 +++++++++++++++++++++++++++++++++++++++++++++++ evaluator.mli | 65 ++++++ expression.ml | 22 +- expression.mli | 2 +- functions.ml | 100 --------- main.ml | 12 +- odf/odf.ml | 1 - readme.rst | 18 +- scTypes.ml | 78 ++++--- scTypes.mli | 32 +-- screen.ml | 67 +++--- sheet.ml | 42 ++-- tests/dataType_test.ml | 44 ++++ tests/expression_test.ml | 1 - tests/sheet_test.ml | 8 +- tests/test.ml | 1 + tools.ml | 257 +++++++++++++++++++--- 23 files changed, 1274 insertions(+), 256 deletions(-) create mode 100755 dataType.ml create mode 100755 dataType.mli create mode 100755 errors.ml create mode 100755 evaluator.ml create mode 100755 evaluator.mli create mode 100755 tests/dataType_test.ml diff --git a/.gitignore b/.gitignore index 31cdc19..884e8f0 100755 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,6 @@ _build/ *.native *.swp *.docdir +*.o +*.so +*.a diff --git a/.merlin b/.merlin index a3f38e6..3194a14 100755 --- a/.merlin +++ b/.merlin @@ -1,4 +1,4 @@ -PKG num curses camlzip ezxmlm uutf text calendar oUnit menhirLib +PKG num curses camlzip ezxmlm uutf text oUnit menhirLib S . S odf/* S tests/* diff --git a/Makefile b/Makefile index a792dd6..f90a98c 100755 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ OCAMLBUILD ?= ocamlbuild -PACKAGES=num,curses,camlzip,ezxmlm,text,calendar,menhirLib +PACKAGES=num,curses,camlzip,ezxmlm,text,str,menhirLib PATHS=.,odf MENHIR=-use-menhir @@ -18,13 +18,14 @@ stub: $(MAKE) -C stub LIB=$(LIB) deps: - opam install ocamlbuild curses camlzip ezxmlm ounit text menhir calendar + opam install ocamlbuild curses camlzip ezxmlm ounit text menhir byte: stub $(OCAMLBUILD) -pkgs $(PACKAGES) $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS) main.byte native: stub - $(OCAMLBUILD) -pkgs $(PACKAGES) $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS) main.native + $(OCAMLBUILD) -tags optimize\(3\) -pkgs $(PACKAGES) $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS) main.native + #$(OCAMLBUILD) -pkgs $(PACKAGES) $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS) main.native doc: $(OCAMLBUILD) -pkgs $(PACKAGES) -menhir -Is $(PATHS) licht.docdir/index.html diff --git a/dataType.ml b/dataType.ml new file mode 100755 index 0000000..3937465 --- /dev/null +++ b/dataType.ml @@ -0,0 +1,133 @@ +module type COMPARABLE = sig + type t + val eq: t -> t -> bool + val neq: t -> t -> bool + val lt: t -> t -> bool + val le: t -> t -> bool + val gt: t -> t -> bool + val ge: t -> t -> bool +end + +module Comparable = struct + + let eq = (=) + let neq = (<>) + let lt = (<) + let le = (<=) + let gt = (>) + let ge = (>=) + +end + +module Num = struct + + type t = + | NAN + | N of Num.num + + let nan = NAN + + let of_num n = N n + + let zero = Num.num_of_int 0 + + let to_num = function + | NAN -> zero + | N n -> n + + let eq v1 v2 = match v1, v2 with + | N n1, N n2 -> Num.eq_num n1 n2 + | _, _ -> false + + let neq a b = not (eq a b) + + let lt v1 v2 = match v1, v2 with + | N n1, N n2 -> Num.lt_num n1 n2 + | N x, NAN -> Num.lt_num x (zero) + | NAN, N x -> Num.lt_num (zero) x + | NAN, NAN -> false + + let le v1 v2 = match v1, v2 with + | N n1, N n2 -> Num.le_num n1 n2 + | N x, NAN -> Num.le_num x (zero) + | NAN, N x -> Num.le_num (zero) x + | NAN, NAN -> false + + let gt v1 v2 = match v1, v2 with + | N n1, N n2 -> Num.gt_num n1 n2 + | N x, NAN -> Num.gt_num x (zero) + | NAN, N x -> Num.gt_num (zero) x + | NAN, NAN -> false + + let ge v1 v2 = match v1, v2 with + | N n1, N n2 -> Num.ge_num n1 n2 + | N x, NAN -> Num.ge_num x (zero) + | NAN, N x -> Num.ge_num (zero) x + | NAN, NAN -> false + + let add v1 v2 = match v1, v2 with + | N n1, N n2 -> N (Num.add_num n1 n2) + | n1, NAN -> n1 + | NAN, n1 -> n1 + + let mult v1 v2 = match v1, v2 with + | N n1, N n2 -> N (Num.mult_num n1 n2) + | _, _ -> N zero + + let div v1 v2 = match v1, v2 with + | N n1, N n2 -> N (Num.div_num n1 n2) + | _, N _ -> N zero + | _, _ -> raise Division_by_zero + + let sub v1 v2 = match v1, v2 with + | N n1, N n2 -> N (Num.sub_num n1 n2) + | v, NAN -> v + | NAN, N n -> N (Num.minus_num n) + + let pow v1 v2 = match v1, v2 with + | N n1, N n2 -> N (Num.power_num n1 n2) + | _, NAN -> N (Num.num_of_int 1) + | NAN, _ -> N zero + + let rnd () = N ( + Num.div_num + (Num.num_of_int @@ Int32.to_int @@ Random.int32 Int32.max_int) + (Num.num_of_int @@ Int32.to_int @@ Int32.max_int) + ) + + let min v1 v2 = match v1, v2 with + | N n1, N n2 -> N (Num.min_num n1 n2) + | NAN, x -> x + | x, NAN -> x + + let max v1 v2 = match v1, v2 with + | N n1, N n2 -> N (Num.max_num n1 n2) + | NAN, x -> x + | x, NAN -> x + + let abs = function + | NAN -> NAN + | N n1 -> N (Num.abs_num n1) + +end + +module Bool = struct + + type t = bool + include Comparable + + let true_ = true + let false_ = false + + let or_ = (||) + let and_ = (&&) + let not = Pervasives.not + +end + +module String = struct + + type t = UTF8.t + include Comparable + +end diff --git a/dataType.mli b/dataType.mli new file mode 100755 index 0000000..09b0082 --- /dev/null +++ b/dataType.mli @@ -0,0 +1,67 @@ +module type COMPARABLE = sig + type t + val eq: t -> t -> bool + val neq: t -> t -> bool + val lt: t -> t -> bool + val le: t -> t -> bool + val gt: t -> t -> bool + val ge: t -> t -> bool +end + +module Num: sig + + type t + + val of_num: Num.num -> t + val nan: t + + val to_num: t -> Num.num + + val eq: t -> t -> bool + val neq: t -> t -> bool + val lt: t -> t -> bool + val le: t -> t -> bool + val gt: t -> t -> bool + val ge: t -> t -> bool + + val add: t -> t -> t + val sub: t -> t -> t + val mult: t -> t -> t + val div: t -> t -> t + val pow: t -> t -> t + + val rnd: unit -> t + + val max: t -> t -> t + val min: t -> t -> t + + val abs: t -> t +end + +module Bool: sig + type t = bool + + val true_ : bool + val false_: bool + + val eq: t -> t -> bool + val neq: t -> t -> bool + val lt: t -> t -> bool + val le: t -> t -> bool + val gt: t -> t -> bool + val ge: t -> t -> bool + + val not: t -> t + val and_: t -> t -> t + val or_: t -> t -> t +end + +module String: sig + type t = UTF8.t + val eq: t -> t -> bool + val neq: t -> t -> bool + val lt: t -> t -> bool + val le: t -> t -> bool + val gt: t -> t -> bool + val ge: t -> t -> bool +end diff --git a/errors.ml b/errors.ml new file mode 100755 index 0000000..8f389ce --- /dev/null +++ b/errors.ml @@ -0,0 +1,12 @@ + +(** The function is undefined *) +exception Undefined of UTF8.t * string list + +exception TypeError + +let printf formatter = function + | Undefined (name, args) -> Format.fprintf formatter + "There is no function '%s' with signature %a" + (UTF8.to_utf8string name) + (Format.pp_print_list Format.pp_print_text) args + | _ -> Format.fprintf formatter "#Error" diff --git a/evaluator.ml b/evaluator.ml new file mode 100755 index 0000000..3adf7fa --- /dev/null +++ b/evaluator.ml @@ -0,0 +1,556 @@ +module D = DataType +module T = Tools + +let u = UTF8.from_utf8string + +exception RegisteredFunction + +(** Data format *) + +type _ dataFormat = + | Date: D.Num.t dataFormat (* Date *) + | Number: D.Num.t dataFormat (* Number *) + | String: UTF8.t dataFormat (* String result, there is only one representation *) + | Bool: D.Bool.t dataFormat (* Boolean result *) + +let most_generic_format: type a. a dataFormat -> a dataFormat -> a dataFormat = + begin fun a b -> match a, b with + | Number, x -> x + | x, Number -> x + | x, _ -> x +end + +(*** Type definitions *) + +type _ typ = + | Unit: unit typ + | Bool: D.Bool.t typ + | Num: D.Num.t typ + | String: UTF8.t typ + | List: 'a typ -> 'a list typ + +let t_bool= Bool +let t_int = Num +let t_string = String +let t_list t = List t + +let typ_of_format: type a. a dataFormat -> a typ = function + | Date -> Num + | Number -> Num + | String -> String + | Bool -> Bool + +let rec compare_typ: type a b. a typ -> b typ -> (a, b) T.cmp = begin fun a b -> + match a, b with + | Unit, Unit -> T.Eq + | Bool, Bool -> T.Eq + | Num, Num -> T.Eq + | String, String -> T.Eq + | List l1, List l2 -> + begin match compare_typ l1 l2 with + | T.Lt -> T.Lt + | T.Eq -> T.Eq + | T.Gt -> T.Gt + end + | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt +end + +let rec print_typ: type a. Format.formatter -> a typ -> unit = fun printer typ -> match typ with + | Unit -> Format.fprintf printer "Unit" + | Bool -> Format.fprintf printer "Bool" + | Num -> Format.fprintf printer "Num" + | String -> Format.fprintf printer "String" + | List t -> Format.fprintf printer "List[%a]" + print_typ t + +let default_format_for_type: type a. a typ -> a dataFormat = function + | Num -> Date + | String -> String + | Bool -> Bool + | List _ -> raise Errors.TypeError + | Unit -> raise Errors.TypeError + +(** Results format. + Any value which can be encoded with different representation requires as + many format than there are representations for this value. +*) + +type _ result = + | Numeric: D.Num.t result (* Any numeric format : the representation depends from the inputs *) + | Date: D.Num.t result (* Date *) + | Number: D.Num.t result (* Number *) + | String: UTF8.t result (* String result, there is only one representation *) + | Bool: D.Bool.t result (* Boolean result *) + +let f_num = Numeric +let f_date = Date +let f_number = Number +let f_string = String +let f_bool = Bool + +let specialize_result: type a. a result -> a dataFormat -> a result = + begin fun a b -> match a, b with + | Date, _ -> Date + | _, Date -> Date + | x, y -> x +end + +let typ_of_result: type a. a result -> a typ = function + | Numeric -> Num + | Number -> Num + | Date -> Num + | Bool -> Bool + | String -> String + +let rec compare_result: type a b. a result -> b result -> (a, b) T.cmp = begin fun a b -> + match a, b with + | Bool, Bool -> T.Eq + | Numeric, Numeric-> T.Eq + | String, String -> T.Eq + | Number, Number -> T.Eq + | Date, Date -> T.Eq + | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt + +end +(*** Values definitions *) + +type 'a value = + | Bool: D.Bool.t -> D.Bool.t value + | Num: D.Num.t dataFormat * D.Num.t -> D.Num.t value + | String: UTF8.t -> UTF8.t value + | List: 'a dataFormat * 'a list -> 'a list value + | List2: 'a dataFormat * 'a list list -> 'a list list value + +(** Get the value out of the box *) +let get_value_content: type a. a value -> a = function + | Bool b -> b + | Num (_, n) -> n + | String s -> s + | List (t, l) -> l + | List2 (t, l) -> l + +(** Create a value from a known type and an unboxed value *) +let build_value: type a. a dataFormat -> a -> a value = begin fun format content -> + match (typ_of_format format), content with + | Unit, _ -> raise Errors.TypeError + | Bool, x -> Bool x + | Num, x -> Num (format, x) + | String, s -> String s + | List t, l -> raise Errors.TypeError +end + +(* Extract the type from a boxed value *) +let type_of_value: type a. a value -> a typ = function + | Bool b -> Bool + | Num (n, _) -> Num + | String s -> String + | List (t, l) -> List (typ_of_format t) + | List2 (t, l) -> List (List (typ_of_format t)) + +let format_of_value: type a. a value -> a dataFormat = function + | Bool b -> Bool + | Num (f, _) -> f + | String s -> String + | List (t, l) -> raise Errors.TypeError + | List2 (t, l) -> raise Errors.TypeError + +type existencialResult = + | Result : 'a value -> existencialResult + +(** Catalog for all functions *) +module C = struct + + (** This is the way the function is store in the map. + We just the return type, and the function itself. + + For Fn1 and T1 constructors, we need to add extra information in the + GADT signature in order to help the compiler: 'a could be any ('a * 'b), + ('a * 'b * 'c) and so on… + + Instead of returning a signature with type 'a t_function, we have to + force it as 'a typ t_function. + *) + type _ t_function = + | Fn1: 'b result * ('a -> 'b) -> 'a typ t_function + | Fn2: 'c result * ('a -> 'b -> 'c) -> ('a * 'b) t_function + | Fn3: 'd result * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function + + (** This is the key for storing functions in the map. + *) + type _ sig_typ = + | T1: 'a typ -> 'a typ t_function sig_typ + | T2: 'a typ * 'b typ -> ('a * 'b) t_function sig_typ + | T3: 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) t_function sig_typ + + let print_sig_typ: type a. Format.formatter -> a sig_typ -> unit = begin fun printer typ -> + match typ with + | T1 a -> Format.fprintf printer "(%a)" + print_typ a + | T2 (a, b) -> Format.fprintf printer "(%a, %a)" + print_typ a + print_typ b + | T3 (a, b, c) -> Format.fprintf printer "(%a, %a, %a)" + print_typ a + print_typ b + print_typ c + end + + module ComparableSignature = struct + + type 'a t = 'a sig_typ + + (** Compare two signature *) + let eq: type a b. a sig_typ -> b sig_typ -> (a, b) T.cmp = begin fun a b -> + match a, b with + | T1(a), T1(b) -> + begin match compare_typ a b with + | T.Lt -> T.Lt + | T.Gt -> T.Gt + | T.Eq -> T.Eq + end + | T2(a, b), T2(c, d) -> + begin match (compare_typ a c) with + | T.Lt -> T.Lt + | T.Gt -> T.Gt + | T.Eq -> + begin match (compare_typ b d) with + | T.Lt -> T.Lt + | T.Gt -> T.Gt + | T.Eq -> T.Eq + end + end + | T3(a, b, c), T3(d, e, f) -> + begin match (compare_typ a d) with + | T.Lt -> T.Lt + | T.Gt -> T.Gt + | T.Eq -> + begin match (compare_typ b e) with + | T.Lt -> T.Lt + | T.Gt -> T.Gt + | T.Eq -> + begin match (compare_typ c f) with + | T.Lt -> T.Lt + | T.Gt -> T.Gt + | T.Eq -> T.Eq + end + end + end + | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt + end + + end + + module Catalog = Map.Make(String) + module Functions = Tools.Map(ComparableSignature) + + + (* This is the map which contains all the registered functions. + Each name is binded with another map with contains the function for each + signature. + *) + let (catalog:Functions.t Catalog.t ref) = ref Catalog.empty + + (** + Register a function in the catalog. If the function is already defined, + raise an exception. + *) + let register name signature f = begin + + let name' = String.uppercase_ascii name in + let map = begin match Catalog.find name' !catalog with + | exception Not_found -> + Functions.singleton signature f + | x -> + (* We prevent any update to already registered function *) + if (Functions.mem signature x) then + raise RegisteredFunction + else + Functions.add signature f x + end in + + catalog := Catalog.add name' map !catalog + end + + let inject: type a. a result -> (unit -> a dataFormat) -> a -> existencialResult = fun resultFormat f res -> + let (x:a value) = begin match resultFormat, res with + | Bool, x -> Bool x + | Numeric, x -> Num (f (), x) + | Date, x -> Num(Date, x) + | Number, x -> Num(Number, x) + | String, s -> String s + end in + Result x + + (** Look in the catalog for a function with the given name and signature *) + let find_function: type a. string -> a t_function sig_typ -> a t_function = begin fun name signature -> + Catalog.find (String.uppercase_ascii name) !catalog + |> Functions.find signature + end + +end + +(** Guess the format to use for the result function from the arguments given. + The most specialized format take over the others. +*) +let guess_format_result: type a. a result -> existencialResult list -> unit -> a dataFormat = + begin fun init_value values () -> + + let init_typ = typ_of_result init_value in + + (* fold over the arguments, and check if they have the same format *) + let compare_format (currentResult: a result) (Result value): a result = + + (* If the argument as the same type as the result format, just the most specialized *) + match compare_typ init_typ (type_of_value value) with + | T.Eq -> begin match value with + | Bool b -> Bool + | String s -> String + | Num (f, v) -> specialize_result currentResult f + (* There is no possibility to get init_typ as List typ*) + | List (f, v) -> raise Errors.TypeError + | List2 (f, v) -> raise Errors.TypeError + end + (* The types differ, handle the special cases for Lists *) + | _ -> + begin match value with + | List (f, v) -> + begin match compare_typ init_typ (typ_of_format f) with + | T.Eq -> specialize_result currentResult f + | _ -> currentResult + end + | List2 (f, v) -> + begin match compare_typ init_typ (typ_of_format f) with + | T.Eq -> specialize_result currentResult f + | _ -> currentResult + end + | _ -> currentResult + end in + + begin match List.fold_left compare_format init_value values with + | String -> String + | Bool -> Bool + | Number -> Number + | Date -> Date + | Numeric -> Number + end + +end + +let register0 name returnType f = + C.register name (C.T1(Unit)) (C.Fn1 (returnType, f)) + +let register1 name typ1 returnType f = + C.register name (C.T1(typ1)) (C.Fn1 (returnType, f)) + +let register2 name (typ1, typ2) result f = + C.register name (C.T2(typ1, typ2)) (C.Fn2 (result, f)) + +let register3 name (typ1, typ2, typ3) result f = + C.register name (C.T3(typ1, typ2, typ3)) (C.Fn3 (result, f)) + +let call name args = begin + let name' = UTF8.to_utf8string name in + begin try match args with + + | [] -> + let C.Fn1(ret, f) = C.find_function name' (C.T1 Unit) in + C.inject ret (fun () -> raise Errors.TypeError) (f ()) + + | (Result p1)::[] -> + let C.Fn1(ret, f) = + C.find_function name' (C.T1 (type_of_value p1)) in + C.inject ret (guess_format_result ret args) (f (get_value_content p1)) + + | (Result p1)::(Result p2)::[] -> + let C.Fn2(ret, f) = + C.find_function name' (C.T2 (type_of_value p1, type_of_value p2)) in + C.inject ret (guess_format_result ret args) (f (get_value_content p1) (get_value_content p2)) + + | (Result p1)::(Result p2)::(Result p3)::[] -> + let C.Fn3(ret, f) = + C.find_function name' (C.T3 (type_of_value p1, type_of_value p2, type_of_value p3)) in + C.inject ret (guess_format_result ret args) (f (get_value_content p1) (get_value_content p2) (get_value_content p3)) + + | _ -> raise Not_found + with Not_found -> + let signature = List.map (fun (Result x) -> + let formatter = Format.str_formatter in + print_typ formatter (type_of_value x); + Format.flush_str_formatter ()) args in + + raise (Errors.Undefined (name, signature)) + end +end + +let repr mapper value = begin + + (** Extract the value from a raw type. + If the value is Undefined, raise an exception. + *) + let extract_value = begin function + | ScTypes.Num (n,s) -> Result (Num (Number, (D.Num.of_num n))) + | ScTypes.Bool b -> Result (Bool b) + | ScTypes.Date d -> Result (Num (Date, (D.Num.of_num d))) + | ScTypes.Str s -> Result (String s) + | ScTypes.Undefined -> raise Errors.TypeError + end in + + (** Extract the value from a raw type. + If the value is Undefined, provide a default result. + *) + let guess_value: type a. a typ -> ScTypes.types -> existencialResult = fun typ value -> begin + try extract_value value with Errors.TypeError -> + match typ with + | Num -> Result (Num (Number, (D.Num.nan))) + | Bool -> Result (Bool false) + | String -> Result (String (u"")) + | List x -> Result (List ((default_format_for_type x), [])) + | Unit -> raise Errors.TypeError + end in + + + let add_elem: type a. a typ -> a list * a dataFormat -> ScTypes.types -> a list * a dataFormat = + begin fun type_of (result, format_of) next -> + let Result r = guess_value type_of next in + begin match compare_typ type_of (type_of_value r) with + | T.Eq -> + let l' = (get_value_content r)::result in + l' , (most_generic_format (format_of_value r) format_of) + | _ -> raise Errors.TypeError + end + end in + + (* Return the result for any expression as an ScTypes.types result *) + let rec get_repr: type a. a value -> ScTypes.types = begin function + | Bool b -> ScTypes.Bool b + | Num (format, n) -> begin match format with + | Number -> ScTypes.Num (D.Num.to_num n, None) + | Date -> ScTypes.Date (D.Num.to_num n) + | _ -> raise Errors.TypeError (* This pattern could be refuted *) + end + | String s -> ScTypes.Str s + | List (t, l) -> + List.hd l (* Extract the first element *) + |> build_value t (* Convert it in boxed value *) + |> get_repr (* Return it's representation *) + | List2 (t, l) -> + List.hd l (* Extract the first element *) + |> List.hd + |> build_value t (* Convert it in boxed value *) + |> get_repr (* Return it's representation *) + end in + + (** Extract the value from an expression. + [extract typ expr] will evaluate the expression and return it. If the + result cannot be evaluated (because of references pointing to missing + 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 -> + begin match mapper r with + | ScTypes.Refs.Single v -> extract_value v + | ScTypes.Refs.Array1 l -> + + (* Guess the list type from it's first defined element *) + let Result r = extract_value (List.find ((!=) ScTypes.Undefined) l) in + let format_of = format_of_value r in + let type_of = type_of_value r in + (* Build the list with all the elements *) + let elems, format = List.fold_left (add_elem type_of) ([], format_of) l in + Result (List (format, elems)) + | ScTypes.Refs.Array2 l -> + (* Guess the list type from it's first defined element *) + let Result r = extract_value (Tools.List.find2 ((!=) ScTypes.Undefined) l) in + let format_of = format_of_value r in + let type_of = type_of_value r in + (* Build the list with all the elements *) + let elems, format = List.fold_left (fun (result, format_of) elems -> + let elems, format = List.fold_left (add_elem type_of) ([], format_of) elems in + elems::result, (most_generic_format format_of format) + ) ([], format_of) l in + Result (List2 (format, elems)) + end + + (* Evaluate the expression *) + | ScTypes.Expression e -> extract e + | ScTypes.Value v -> extract_value v + | ScTypes.Call (name, args) -> + let args' = List.map extract args in + call name args' + end + in + let Result r = extract value in + get_repr r +end + +let wrap f = + let old_catalog = !C.catalog in + Tools.try_finally + (fun () -> C.catalog := C.Catalog.empty; f ()) + (fun () -> C.catalog := old_catalog) + +(* Register the standard functions *) + +module MAKE(C: D.COMPARABLE) = struct + + let register t = begin + register2 "=" (t, t) f_bool C.eq; + register2 "<>" (t, t) f_bool C.neq; + register2 ">" (t, t) f_bool C.gt; + register2 ">=" (t, t) f_bool C.ge; + register2 "<" (t, t) f_bool C.lt; + register2 "<=" (t, t) f_bool C.le; + end + +end + +(* Helper for list functions : reduce over a list of elements *) +let reduce name typ res f = begin + register1 name (t_list typ) res (fun x -> + List.fold_left f (List.hd x) x); + register1 name (t_list (t_list typ)) res (fun x -> + List.fold_left (List.fold_left f) (List.hd (List.hd x)) x); +end + +(* Helper for list functions : fold over a list of elements *) +let fold name t_in t_out f init = begin + register1 name (t_list t_in) t_out (fun x -> + List.fold_left f init x); + register1 name (t_list (t_list t_in)) t_out (fun x -> + List.fold_left (List.fold_left f) init x); +end + + +let () = begin + + let module CompareNum = MAKE(D.Num) in + CompareNum.register t_int; + register0 "rand" f_number D.Num.rnd; + register2 "+" (t_int, t_int) f_num D.Num.add; + register2 "-" (t_int, t_int) f_num D.Num.sub; + register2 "*" (t_int, t_int) f_number D.Num.mult; + register2 "/" (t_int, t_int) f_number D.Num.div; + register2 "^" (t_int, t_int) f_number D.Num.pow; + + register1 "abs" t_int f_number D.Num.abs; + + fold "sum" t_int f_number D.Num.add (D.Num.of_num (Num.num_of_int 0)); + fold "product" t_int f_number D.Num.mult (D.Num.of_num (Num.num_of_int 1)); + + reduce "min" t_int f_num D.Num.min; (* Minimum value from a list *) + reduce "max" t_int f_num D.Num.max; (* Maximum value from a list *) + + let module CompareBool = MAKE(D.Bool) in + CompareBool.register t_bool; + register0 "true" f_bool (fun () -> D.Bool.true_); + register0 "false" f_bool (fun () -> D.Bool.false_); + register1 "not" t_bool f_bool D.Bool.not; + register2 "and" (t_bool, t_bool) f_bool D.Bool.and_; + register2 "or" (t_bool, t_bool) f_bool D.Bool.or_; + register2 "xor" (t_bool, t_bool) f_bool D.Bool.neq; + + let module CompareString = MAKE(D.String) in + CompareString.register t_string; + +end diff --git a/evaluator.mli b/evaluator.mli new file mode 100755 index 0000000..9fa280b --- /dev/null +++ b/evaluator.mli @@ -0,0 +1,65 @@ +val repr: (ScTypes.refs -> ScTypes.types ScTypes.Refs.range) -> ScTypes.expression -> ScTypes.types + +(** Type definitions *) + +type 'a typ +val t_bool: DataType.Bool.t typ +val t_int: DataType.Num.t typ +val t_string: UTF8.t typ +val t_list: 'a typ -> 'a list typ + +(** Result formats *) + +type 'a result + +(** Numeric (any format) *) +val f_num: DataType.Num.t result + +(** Date *) +val f_date: DataType.Num.t result + +(** Number *) +val f_number: DataType.Num.t result + +(** Boolean result *) +val f_bool: DataType.Bool.t result + +(** String *) +val f_string: DataType.String.t result + +(** Catalog *) + +(** We cannot update an existing function. Any [registerX] function will raise + [RegisteredFunction] if a function with the same signature already exists in the catalog. *) +exception RegisteredFunction + +val register0: + string -> (* The function name *) + 'a result -> (* The return type *) + (unit -> 'a) (* The function to call *) + -> unit + +val register1: + string -> (* The function name *) + 'a typ -> (* The signature *) + 'b result -> (* The return type *) + ('a -> 'b) (* The function to call *) + -> unit + +val register2: + string -> (* The function name *) + ('a typ * 'b typ) ->(* The signature *) + 'c result -> (* The return type *) + ( 'a -> 'b -> 'c) (* The function to call*) + -> unit + +val register3: + string -> (* The function name *) + ('a typ * 'b typ * 'c typ) ->(* The signature *) + 'd result -> (* The return type *) + ( 'a -> 'b -> 'c -> 'd) (* The function to call*) + -> unit + + +(** [wrap f] run [f] inside a context where there is no functions *) +val wrap: (unit -> 'a) -> 'a diff --git a/expression.ml b/expression.ml index f516463..1feb62e 100755 --- a/expression.ml +++ b/expression.ml @@ -1,6 +1,5 @@ module C = Catalog - -module Calendar = CalendarLib.Calendar.Precise +module Tuple2 = Tools.Tuple2 let u = UTF8.from_utf8string @@ -35,7 +34,6 @@ let load content = begin try String.sub content 0 (String.index content '\000') with Not_found -> content in Basic ( - (*try ScTypes.Num (Tools.Num.of_float_string content')*) try Lexing.from_string content' |> ExpressionParser.content ExpressionLexer.read with _ -> ScTypes.Str (UTF8.from_utf8string content') @@ -47,19 +45,16 @@ let load content = begin ) end + let load_expr expr = expr + (** Extract the parameters to give to a function. return an Error if one of them is an error *) let eval expr sources = begin - let rec eval_exp: ScTypes.expression -> ScTypes.types = function - | ScTypes.Value v -> v - | ScTypes.Call (ident, params) -> C.eval ident (List.map eval_exp params) - | ScTypes.Ref r -> sources r - | ScTypes.Expression expr -> eval_exp expr - in + let eval_exp f = Evaluator.repr sources f in begin try match expr with | Basic value -> ScTypes.Result value @@ -72,7 +67,14 @@ end let collect_sources expr = begin let rec collect refs = function - | ScTypes.Ref r -> Cell.Set.union refs (Cell.Set.of_list @@ ScTypes.Refs.collect r) + | 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 diff --git a/expression.mli b/expression.mli index 9888ece..f7f0ece 100755 --- a/expression.mli +++ b/expression.mli @@ -15,7 +15,7 @@ val load_expr: t -> t val is_defined: t -> bool (** Evaluate the expression *) -val eval: t -> (ScTypes.refs -> ScTypes.types) -> ScTypes.result +val eval: t -> (ScTypes.refs -> ScTypes.types ScTypes.Refs.range) -> ScTypes.result (** Collect all the cell referenced in the expression *) val collect_sources: t -> Cell.Set.t diff --git a/functions.ml b/functions.ml index 2014d2e..56d7530 100755 --- a/functions.ml +++ b/functions.ml @@ -1,5 +1,3 @@ -open Catalog - let u = UTF8.from_utf8string let eq = u"=" @@ -14,101 +12,3 @@ let mul = u"*" let pow = u"^" let div = u"/" let sub = u"-" - -let sum = u"sum" - -let () = - - (** Comparaison *) - let compare = function - | ScTypes.Num (n1,_)::ScTypes.Num (n2,_)::[] -> Num.compare_num n1 n2 - | ScTypes.Date n1::ScTypes.Date n2::[] -> Num.compare_num n1 n2 - | ScTypes.Str s1::ScTypes.Str s2::[] -> UTF8.compare s1 s2 - | ScTypes.Bool b1::ScTypes.Bool b2::[] -> Pervasives.compare b1 b2 - | ScTypes.List l1::ScTypes.List l2::[] -> Pervasives.compare l1 l2 - | t1::t2::[] -> Pervasives.compare t1 t2 - | _ -> raise ScTypes.Error - in - register eq (fun args -> ScTypes.Bool ((compare args) = 0)); - register neq (fun args -> ScTypes.Bool ((compare args) != 0)); - register lt (fun args -> ScTypes.Bool ((compare args) < 0)); - register le (fun args -> ScTypes.Bool ((compare args) <= 0)); - register gt (fun args -> ScTypes.Bool ((compare args) > 0)); - register ge (fun args -> ScTypes.Bool ((compare args) >= 0)); - - (** Basic *) - - register sum (fun args -> - - let rec sum value = function - | ScTypes.Undefined -> value - | ScTypes.Num (n,_) -> Num.add_num value n - | ScTypes.Date n -> Num.add_num value n - | ScTypes.List l -> List.fold_left sum value l - | _ -> raise ScTypes.Error in - - ScTypes.Num (List.fold_left sum (Num.num_of_int 0) args, None) - ); - - let rec operation f = begin function - | ScTypes.Undefined , x -> operation f (ScTypes.Num (Num.num_of_int 0, None), x) - | x, ScTypes.Undefined -> operation f (x, ScTypes.Num (Num.num_of_int 0, None)) - | ScTypes.Num (n1,_), ScTypes.Num (n2,_) -> ScTypes.Num (f n1 n2, None) - | ScTypes.Date n1, ScTypes.Date n2 -> ScTypes.Date (f n1 n2) - | ScTypes.Date n1, ScTypes.Num (n2,_) -> ScTypes.Date (f n1 n2) - | ScTypes.Num (n1,_), ScTypes.Date n2 -> ScTypes.Date (f n1 n2) - | _ -> raise ScTypes.Error - end - in - - register add (function - | t1::t2::[] -> (operation Num.add_num) (t1, t2) - | _ -> raise ScTypes.Error - ); - - register mul (function - | t1::t2::[] -> (operation Num.mult_num) (t1, t2) - | _ -> raise ScTypes.Error - ); - - register div (function - | t1::t2::[] -> (operation Num.div_num) (t1, t2) - | _ -> raise ScTypes.Error - ); - - register sub (function - | t1::t2::[] -> (operation Num.sub_num) (t1, t2) - | _ -> raise ScTypes.Error - ); - - register pow (function - | t1::t2::[] -> (operation Num.power_num) (t1, t2) - | _ -> raise ScTypes.Error - ); - - (** Binary *) - - register (u"true") (function - | [] -> ScTypes.Bool true - | _ -> raise ScTypes.Error - ); - - register (u"false") (function - | [] -> ScTypes.Bool false - | _ -> raise ScTypes.Error - ); - - register (u"not") (function - | (ScTypes.Bool x):: [] -> ScTypes.Bool (not x) - | _ -> raise ScTypes.Error - ); - - register (u"date") (function - | (ScTypes.Num (x,_)):: [] -> ScTypes.Date x - | _ -> raise ScTypes.Error - ); - - register (u"num") (function - | (ScTypes.Date x):: [] -> ScTypes.Num (x, None) - | _ -> raise ScTypes.Error - ); diff --git a/main.ml b/main.ml index 58cbea5..393d4fe 100755 --- a/main.ml +++ b/main.ml @@ -97,7 +97,7 @@ let rec normal_mode (t, screen) = begin let position = Selection.extract t.Sheet.selected in let expr = Sheet.Raw.get_expr position t.Sheet.data |> Expression.show in - begin match Screen.editor ~position ~init:expr screen with + begin match Screen.editor ~position ~prefix:(u"-> ") ~init:expr screen with | None -> (* Restore the previous value *) Screen.status screen expr; @@ -127,7 +127,7 @@ let rec normal_mode (t, screen) = begin | Actions.Search -> let expr = Screen.search screen |> Expression.load in - let pattern = Expression.eval expr (fun _ -> ScTypes.Undefined) in + let pattern = Expression.eval expr (fun _ -> ScTypes.Refs.Single ScTypes.Undefined) in begin match Sheet.search (`Pattern pattern) t with | Some t' -> normal_mode @@ redraw t' screen | None -> normal_mode (t, screen) @@ -155,7 +155,7 @@ let rec normal_mode (t, screen) = begin end | Actions.Command -> - begin match Screen.editor ~init:(u":") screen with + begin match Screen.editor ~prefix:(u":") screen with | None -> normal_mode (t, screen) | Some content -> @@ -212,13 +212,13 @@ end and command (t, screen) action = begin match action with - | (":w", file) -> (* Save the file *) + | ("w", file) -> (* Save the file *) Odf.save t.Sheet.data file; normal_mode @@ redraw t screen - | (":enew", _) -> (* Start a new spreadsheet *) + | ("enew", _) -> (* Start a new spreadsheet *) let sheet = Sheet.Raw.create in normal_mode @@ redraw (Sheet.create sheet) screen - | (":q", _) -> (* Quit *) + | ("q", _) -> (* Quit *) t | _ -> normal_mode @@ redraw t screen end diff --git a/odf/odf.ml b/odf/odf.ml index cfbd964..df98adb 100755 --- a/odf/odf.ml +++ b/odf/odf.ml @@ -154,7 +154,6 @@ let write_basic attrs output = begin function write_num ((NS.value_attr, value)::attrs) output value | ScTypes.Str s -> write_str attrs output (UTF8.to_utf8string s) | ScTypes.Bool b -> write_bool attrs output (string_of_bool b) - | ScTypes.List l -> write_error attrs output "" | ScTypes.Date d -> let value = Tools.Date.to_string d in write_date ((NS.date_value_attr, value)::attrs) output value diff --git a/readme.rst b/readme.rst index a41c0c0..970817e 100755 --- a/readme.rst +++ b/readme.rst @@ -148,14 +148,13 @@ garanted to not loop.) Range ~~~~~ -Yan can reference a range by naming the two bounds (`C6:A1`). The value is -typed as a List. +Yan can reference a range by naming the two bounds (`C6:A1`). Undefined ~~~~~~~~~ -If a reference point to an an empty cell, the content will be interpreted as Undefined - +If a reference point to an an empty cell, the content will be interpreted as +Undefined. Any formula impliyng Undefined will return Error Formulas ======== @@ -168,12 +167,16 @@ Licht is provided with built-in functions. Generic comparaison ------------------- -Thoses function can be applied to any value, they will never raise error +Thoses function can be applied to any value. =============== =============================== Function Value =============== =============================== *x* `=` *y* True if *x* equals *y* +*x* `>` *y* True if *x* > *y* +*x* `>=` *y* True if *x* >= *y* +*x* `<` *y* True if *x* < *y* +*x* `<=` *y* True if *x* <= *y* *x* `<>` *y* True if *x* does not equals *y* =============== =============================== @@ -192,12 +195,11 @@ Function Value Numeric ------- -In numeric functions, Undefined_ value are considered as `O` - =================== ===================================== Function Value =================== ===================================== -`sum(Numeric List)` Compute the sum of the list. *x* `+` *y* Add two values *x* `**` *y* Compute *x* ^ *y* +`sum(Numeric List)` Compute the sum of the list. +`rnd()` A random number between 0 and 1 =================== ===================================== diff --git a/scTypes.ml b/scTypes.ml index ddbae12..6ea9f35 100755 --- a/scTypes.ml +++ b/scTypes.ml @@ -1,7 +1,5 @@ (** All the types used in the spreadsheet. *) -module Calendar = CalendarLib.Calendar.Precise - let u = UTF8.from_utf8string exception Error @@ -11,13 +9,12 @@ type cell = Cell.t type ident = UTF8.t type types = - | Num : Num.num * (UTF8.t option) -> types (** A number *) - | Str : UTF8.t -> types (** A string *) - | Date : Num.num -> types (** A date in julian day *) + | Num of Num.num * (UTF8.t option) (** A number *) + | Str of UTF8.t (** A string *) + | Date of Num.num (** A date in julian day *) - | Undefined : types (** The content is not defined *) - | Bool : bool -> types (** A boolean *) - | List : types list -> types (** List with heterogenous datas *) + | Undefined (** The content is not defined *) + | Bool of bool (** A boolean *) type refs = | Cell of cell (** A cell *) @@ -70,37 +67,55 @@ module Type = struct end | Str x -> UTF8.Buffer.add_string buffer x | Bool b -> UTF8.Printf.bprintf buffer "%B" b - | List l -> - UTF8.Printf.bprintf buffer "[%a]" - (show_list show) l | Date n -> - Num.float_of_num n - |> Calendar.from_jd - |> CalendarLib.Printer.Precise_Calendar.to_string - |> u - |> UTF8.Buffer.add_string buffer + let y, m, d = Tools.Date.date_from_julian_day n in + UTF8.Printf.bprintf buffer "%d/%d/%d" y m d 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 -> [Pervasives.fst x] - | Range (first, snd) -> - let (x1, y1) = Pervasives.fst first + | 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 - 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; - List.rev (!elms) + 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) let shift (vector_x, vector_y) ref = let _shift ((x, y), (fixed_x, fixed_y)) = @@ -125,9 +140,16 @@ module Result = struct | Result v1, Result v2 -> Type.(=) v1 v2 | _, _ -> t1 = t2 - let show = begin function - | Error _ -> u"#Error" + | Error x -> + (* + let buffer = Buffer.create 16 in + let b = Format.formatter_of_buffer buffer in + Errors.printf b x; + Format.pp_print_flush b (); + u(Buffer.contents buffer) + *) + u"#Error" | Result v -> let buffer = UTF8.Buffer.create 16 in Type.show buffer v; diff --git a/scTypes.mli b/scTypes.mli index 642ecd2..deef1a0 100755 --- a/scTypes.mli +++ b/scTypes.mli @@ -7,23 +7,22 @@ type cell = (int * int) * (bool * bool) type ident = UTF8.t type types = - | Num : Num.num * (UTF8.t option) -> types (** A number *) - | Str : UTF8.t -> types (** A string *) - | Date : Num.num -> types (** A date in julian day *) + | Num of Num.num * (UTF8.t option) (** A number *) + | Str of UTF8.t (** A string *) + | Date of Num.num (** A date in julian day *) - | Undefined : types (** The content is not defined *) - | Bool : bool -> types (** A boolean *) - | List : types list -> types (** List with heterogenous datas *) + | Undefined (** The content is not defined *) + | Bool of bool (** A boolean *) type refs = - | Cell of cell (** A cell *) - | Range of cell * cell (** An area of cells *) + | Cell of cell (** A cell *) + | Range of cell * cell (** An area of cells *) type expression = - | Value of types (** A direct value *) - | Ref of refs (** A reference to another cell *) - | Call of ident * expression list (** A call to a function *) - | Expression of expression (** An expression *) + | Value of types (** A direct value *) + | Ref of refs (** A reference to another cell *) + | Call of ident * expression list (** A call to a function *) + | Expression of expression (** An expression *) (** Result from a computation *) type result = @@ -40,7 +39,14 @@ end module Refs : sig - val collect: refs -> (int * int) list + type 'a range = + | Single of 'a + | Array1 of 'a list + | Array2 of 'a list list + + val collect: refs -> (int * int) range + + val map: ('a -> 'b) -> 'a range -> 'b range val shift: (int * int) -> refs -> refs diff --git a/screen.ml b/screen.ml index 69290d7..d48381a 100755 --- a/screen.ml +++ b/screen.ml @@ -162,9 +162,8 @@ let init () = begin && Curses.init_pair 3 Color.black Color.white (* Selected cell *) && Curses.init_pair 4 Color.black Color.red (* referenced cell *) && Curses.init_pair 5 Color.black Color.green (* sink cell *) - && Curses.curs_set 0 + && Curses.curs_set 0 in - in if not init then raise (Failure "Initialisation") else @@ -186,31 +185,30 @@ end let draw_input t screen = begin - let height, width = screen.size in + let height, width = screen.size in - let expr = Sheet.Raw.get_expr (Selection.extract t.Sheet.selected) t.Sheet.data - |> Expression.show in + let expr = Sheet.Raw.get_expr (Selection.extract t.Sheet.selected) t.Sheet.data + |> Expression.show in - (* Compute the difference between number of bytes in the string, and the - number of character printed : Printf.sprintf format use the bytes number - in the string, while Curses print the characters in the user encoding *) - let result = Sheet.Raw.get_value (Selection.extract t.Sheet.selected) t.Sheet.data - |> ScTypes.Result.show in - let encoded_result = UTF8.encode result in - let result_length_delta = (UTF8.length result) - (String.length encoded_result) in + (* Compute the difference between number of bytes in the string, and the + number of character printed : Printf.sprintf format use the bytes number + in the string, while Curses print the characters in the user encoding *) + let result = Sheet.Raw.get_value (Selection.extract t.Sheet.selected) t.Sheet.data + |> ScTypes.Result.show in + let encoded_result = UTF8.encode result in + let result_length_delta = (UTF8.length result) - (String.length encoded_result) in - ignore ( - encoded_result - |> Printf.sprintf "%-*s" (width - 11 - result_length_delta) - |> Curses.mvwaddstr screen.input 0 10 + ignore ( + encoded_result + |> Printf.sprintf "%-*s" (width - 11 - result_length_delta) + |> Curses.mvwaddstr screen.input 0 10 - && Curses.wrefresh screen.input); - status screen expr; - screen + && Curses.wrefresh screen.input); + status screen expr; + screen end (** Wait for an event and return the key pressed - The signal is always followed by NULL character (0x00) If the key code contains more than one char, they are both returned *) let read_key {window} = begin @@ -227,8 +225,7 @@ let read_key {window} = begin | x -> Buffer.add_char buff @@ char_of_int x; end; ignore @@ Curses.nodelay window false; - let content = Buffer.contents buff in - content + Buffer.contents buff end let resize data t = begin @@ -279,10 +276,12 @@ let editor ?position ?(prefix=UTF8.empty) ?(init=UTF8.empty) t = begin done; end in - let rec _edit (before:UTF8.t list) after = begin function - (* [before] contains all the caracters inserted before the cursor (reverse - ordered), while [after] contains all the caracters after the cursor. + (* Text edition, handle the keycode. + + [before] contains all the caracters inserted before the cursor (reverse + ordered), and [after] contains all the caracters after the cursor. *) + let rec _edit before after = begin function | "\027" -> (* Escape, cancel the modifications *) None | "\010" -> (* Enter, validate the input *) @@ -422,15 +421,12 @@ let editor ?position ?(prefix=UTF8.empty) ?(init=UTF8.empty) t = begin end in - ignore @@ Curses.curs_set 1; - let mode = if with_refs then - select_content position (UTF8.empty) - else - _edit in - let res = mode (UTF8.rev_explode init) [] @@ read_key t in - ignore @@ Curses.curs_set 0; - res - + Tools.try_finally + (fun () -> + ignore @@ Curses.curs_set 1; + try _edit (UTF8.rev_explode init) [] @@ read_key t + with _ -> None) + (fun () -> ignore @@ Curses.curs_set 0) end @@ -442,6 +438,7 @@ let search screen = begin end end +(* let read_input position screen = begin let result = editor ~position ~init:(u"=") screen in begin match result with @@ -449,4 +446,4 @@ let read_input position screen = begin | None -> UTF8.empty end end - +*) diff --git a/sheet.ml b/sheet.ml index 773c784..b604c03 100755 --- a/sheet.ml +++ b/sheet.ml @@ -21,6 +21,9 @@ module Raw = struct sink : Cell.Set.t; (** All the cell which references this one *) } + (** 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. + *) and t = content Map.t (** An empty cell which does contains nothing *) @@ -30,39 +33,37 @@ module Raw = struct sink = Cell.Set.empty; } - let create = Map.empty - let get_value (id: cell) t = begin + let get_value id t = begin try (Map.find id t).value with Not_found -> ScTypes.Result ScTypes.Undefined end - let get_expr (id: cell) t = begin + let get_expr id t = begin try (Map.find id t).expr - with Not_found -> Expression.load @@ UTF8.empty + with Not_found -> empty_cell.expr end - (** Extract a value from a reference. *) - let get_ref (from:cell) (t:t) : ScTypes.refs -> ScTypes.types = begin + (** 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 = begin let extract_values = begin function | ScTypes.Result v -> v | ScTypes.Error e -> raise e end in - begin function - | ScTypes.Cell c -> - let coord = Cell.to_pair c in - if coord = from then raise Cycle; extract_values (get_value coord t) - | ScTypes.Range _ as r -> - ScTypes.Refs.collect r - |> List.map (fun x -> if x = from then raise Cycle; extract_values (get_value x t)) - |> (fun x -> ScTypes.List x) - end + ScTypes.Refs.collect ref + |> ScTypes.Refs.map (fun coord -> extract_values (get_value coord t)) + end - (** Update the value for the given cell *) + (** Update the value for the given cell. + Evaluate the new expression and compare it with the previous value. + @return the map updated if the result differ. + *) let update cell content t = begin let new_val = Expression.eval content.expr (get_ref cell t) in if not (ScTypes.Result.(=) new_val content.value) then @@ -73,8 +74,11 @@ module Raw = struct end (** Parse all the successors from [init] and call [f] for each of them. + + As long as [f] return [Some _], the cell successors will also be updated. + [f] is called only once for each successor. - @return all the successors collected + @return all the successors collected, and the map updated. *) let successors (f:(cell -> content -> t -> t option)) (init:content) (state:Cell.Set.t * t) = begin let rec fold cell (succ, t) = begin @@ -82,7 +86,8 @@ module Raw = struct (* The element has already been parsed, do not cycle *) (succ, t) else ( - (* Map.find cannot raise Not_found here *) + (* Map.find cannot raise Not_found here : we look for a successor from a registered cell. + *) let content = Map.find cell t in match f cell content t with | None -> (succ, t) @@ -176,7 +181,6 @@ module Raw = struct add_element id f t end - let paste id shift content t = begin let expr = Expression.shift shift content.expr in let f cell t = diff --git a/tests/dataType_test.ml b/tests/dataType_test.ml new file mode 100755 index 0000000..3bf51ad --- /dev/null +++ b/tests/dataType_test.ml @@ -0,0 +1,44 @@ +open OUnit2 +module N = DataType.Num + +let test_num_add n1 n2 result ctx = begin + assert_equal + ~cmp:(Num.(=/)) + result + (N.to_num @@ N.add n1 n2) +end + +let test_num_mult n1 n2 result ctx = begin + assert_equal + ~cmp:(Num.(=/)) + result + (N.to_num @@ N.mult n1 n2) +end + +let test_num_sub n1 n2 result ctx = begin + assert_equal + ~cmp:(Num.(=/)) + result + (N.to_num @@ N.sub n1 n2) +end + +let n1 = N.of_num (Num.num_of_int 1) +let n2 = N.of_num (Num.num_of_int 2) + +let num_tests = "num_test">::: [ + + "test_add" >:: test_num_add n1 n1 (Num.num_of_int 2); + "test_add_nan1" >:: test_num_add n1 N.nan (Num.num_of_int 1); + "test_add_nan2" >:: test_num_add N.nan n1 (Num.num_of_int 1); + "test_add_nan3" >:: test_num_add N.nan N.nan (Num.num_of_int 0); + + "test_mult" >:: test_num_mult n2 n1 (Num.num_of_int 2); + "test_mult_nan1" >:: test_num_mult n1 N.nan (Num.num_of_int 0); + "test_mult_nan2" >:: test_num_mult N.nan n1 (Num.num_of_int 0); + "test_mult_nan3" >:: test_num_mult N.nan N.nan (Num.num_of_int 0); + + "test_sub" >:: test_num_sub n1 n1 (Num.num_of_int 0); + "test_sub_nan1" >:: test_num_sub n1 N.nan (Num.num_of_int 1); + "test_sub_nan2" >:: test_num_sub N.nan n1 (Num.num_of_int (-1)); + "test_sub_nan3" >:: test_num_sub N.nan N.nan (Num.num_of_int 0); + ] diff --git a/tests/expression_test.ml b/tests/expression_test.ml index 3674b9a..d1ac2ba 100755 --- a/tests/expression_test.ml +++ b/tests/expression_test.ml @@ -11,7 +11,6 @@ let _msg ~expected ~result = | Expression.Basic ScTypes.Date _ -> "D" | Expression.Basic ScTypes.Undefined -> "U" | Expression.Basic ScTypes.Bool _ -> "B" - | Expression.Basic ScTypes.List _ -> "L" | Expression.Formula _ -> "F" in Printf.sprintf "Expected %s:%s but got %s:%s" diff --git a/tests/sheet_test.ml b/tests/sheet_test.ml index f63d76f..de42730 100755 --- a/tests/sheet_test.ml +++ b/tests/sheet_test.ml @@ -15,7 +15,7 @@ let test_create_ref_1 ctx = begin |> snd |> Sheet.Raw.add (0,0) @@ Expression.load @@ u"=C3" |> snd in let result = (Sheet.Raw.get_value (0, 0) s) in - let expected = (ScTypes.Result (ScTypes.Num (Num.num_of_int (-1), Some (u"-1")))) in + let expected = (ScTypes.Result (ScTypes.Num (Num.num_of_int (-1), None))) in assert_equal ~msg:(_msg ~expected ~result) @@ -33,7 +33,7 @@ let test_create_ref_2 ctx = begin let result = (Sheet.Raw.get_value (2, 2) s) in - let expected = ScTypes.Result (ScTypes.Num (Num.num_of_int 123, Some (u"123"))) in + let expected = ScTypes.Result (ScTypes.Num (Num.num_of_int 123, None)) in assert_equal ~msg:(_msg ~expected ~result) @@ -47,7 +47,7 @@ let test_create_direct_cycle ctx = begin |> Sheet.Raw.add (2,2) @@ Expression.load @@ u"=B2" |> snd in let result = (Sheet.Raw.get_value (2, 2) s) in - let expected = ScTypes.Error Sheet.Raw.Cycle in + let expected = ScTypes.Error Errors.TypeError in assert_equal ~msg:(_msg ~expected ~result) @@ -63,7 +63,7 @@ let test_create_indirect_cycle ctx = begin |> snd |> Sheet.Raw.add (0,0) @@ Expression.load @@ u"=A1" |> snd in let result = (Sheet.Raw.get_value (0, 0) s) in - let expected = ScTypes.Result ScTypes.Undefined in + let expected = ScTypes.Error Errors.TypeError in assert_equal ~msg:(_msg ~expected ~result) diff --git a/tests/test.ml b/tests/test.ml index 1bfd6c1..8a24cd5 100755 --- a/tests/test.ml +++ b/tests/test.ml @@ -1,6 +1,7 @@ let () = let tests = OUnit2.test_list [ Tools_test.tests; + DataType_test.num_tests; ExpressionParser_test.tests; Expression_test.tests; Sheet_test.tests; diff --git a/tools.ml b/tools.ml index 1e0e1c4..0cf8fe6 100755 --- a/tools.ml +++ b/tools.ml @@ -75,6 +75,30 @@ module Num = struct with Not_found -> Num.num_of_string a end + let of_float f = begin + match classify_float f with + | FP_normal + | FP_subnormal -> + let x,e = frexp f in + let n,e = + Big_int.big_int_of_int64 (Int64.of_float (ldexp x 52)), + (e-52) + in + if e >= 0 then + Big_int (Big_int.shift_left_big_int n e) + else + Num.div_num + (Big_int n) + (Big_int Big_int.(shift_left_big_int unit_big_int ~-e)) + | FP_zero -> Num.num_of_int 0 + | FP_nan -> Num.div_num (Num.num_of_int 0) (Num.num_of_int 0) + | FP_infinite -> + if f >= 0. then + Num.div_num (Num.num_of_int 1) (Num.num_of_int 0) + else + Num.div_num (Num.num_of_int (-1)) (Num.num_of_int 0) + end + end module List = struct @@ -101,6 +125,36 @@ module List = struct UTF8.Buffer.add_string buffer last end + let rec findOpt p = begin function + | [] -> None + | x::l -> + if p x then + Some(x) + else + findOpt p l + end + + and find2 p = begin function + | [] -> raise Not_found + | x::l -> + begin match findOpt p x with + | None -> find2 p l + | Some x -> x + end + end + + (** Convert the list [l] as an array *) + let to_array l = begin + let elems = ref l in + let build = fun _ -> + begin match (!elems) with + | [] -> assert false + | hd::tl -> + elems := tl; + hd + end + in Array.init (List.length l) build + end end @@ -152,25 +206,6 @@ module Tuple3 = struct let replace3 v (a, b, c) = (a, b, v) end -(* -module Locale = struct - - type locale = - | LC_ALL - | LC_COLLATE - | LC_CTYPE - | LC_MONETARY - | LC_NUMERIC - | LC_TIME - | LC_MESSAGES - - external set: locale -> string -> string = "c_set_locale" - - external length: string -> int = "c_length" - -end -*) - module NCurses = struct type mouse_event = @@ -215,16 +250,50 @@ module Date = struct type t = Num.num let get_julian_day year month day = begin - CalendarLib.Date.make year month day - |> CalendarLib.Date.to_jd + let y, m = + if month > 2 then + year, month + else + year - 1, month + 12 + in + let b = + if (year > 1582) || (year = 1582 && month > 10) || (year = 1582 && month = 10 && day >= 15) then + let s = y / 100 in + 2 - s + (s / 4) + else + 0 + in + 365 * y + y / 4 + + (int_of_float (30.6001 *. (float_of_int (m + 1)))) + + day + + b + + 1720995 +(* + 2415019 (* Shift to 30/12/1899 *) *) |> Num.num_of_int + end - let date_from_julian_day j = begin - let date = CalendarLib.Date.from_jd (Num.int_of_num @@ Num.floor_num j) in - (CalendarLib.Date.year date), - (CalendarLib.Date.int_of_month @@ CalendarLib.Date.month date), - (CalendarLib.Date.day_of_month date) + let date_from_julian_day day = begin + + + let z = Num.int_of_num (Num.floor_num day) in + let f = + if z >= 2299161 then + (* We use the Num module here to prevent overflow *) + let day' = Num.(((num_of_int 4) */ day +/ (num_of_int 274277)) // (num_of_int 146097)) + |> Num.floor_num + |> Num.int_of_num in + z + 1401 + ((day' * 3) / 4) - 38 + else + z + 1401 + in + let e = (4 * f) + 3 in + let h = 5 * ((e mod 1461) / 4) + 2 in (* 1461 is 365.25 * 4 *) + let d = ((h mod 153) / 5) + 1 + and m = (((h / 153) + 2) mod 12) + 1 in + let y = (e / 1461) - 4716 + (14 - m) / 12 in (* 4716 is day 2 *) + (y, m, d) + end let time_from_julian_day j = begin Num.( @@ -286,3 +355,139 @@ let try_finally f except = with e -> except (); raise e + +type (_,_) cmp = + | Eq : ('a,'a) cmp + | Lt : ('a,'b) cmp + | Gt : ('a,'b) cmp + +(** Existencial type for comparing two types. + This type has no utility, except for structural comparison between two + values. + *) +type existencial = Ex: 'a -> existencial + +module type COMPARABLE_TYPE = sig + + type 'a t + + val eq: 'a t -> 'b t -> ('a, 'b) cmp + +end + +module ArrayMap(Ord: COMPARABLE_TYPE) = struct + + type 'a key = 'a Ord.t + + type t = Val : ('a key * 'a) array -> t + + let find: type a. a key -> t -> a = begin fun k (Val map) -> + let rec find_ idx : a = begin + let x, v = Array.get map idx in + match Ord.eq x k with + | Eq -> v + | Lt -> find_ ((2 * idx) + 1) + | Gt -> find_ ((2 * idx) + 2) + end in + find_ 0 + end + + let from_list l = begin + let compare (key_x, _) (key_y, _) = match Ord.eq key_x key_y with + | Eq -> 0 + | Lt -> -1 + | Gt -> 1 + in + let arr = List.to_array l in + Array.sort compare arr; + Val arr + end + +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 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.eq 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.eq x k with + | Eq -> v + | Lt -> find x l + | Gt -> find x r + end + + 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.eq x k with + | Eq -> true + | Lt -> mem x l + | Gt -> mem x r + end + +end -- cgit v1.2.3