aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-x.gitignore3
-rwxr-xr-x.merlin2
-rwxr-xr-xMakefile7
-rwxr-xr-xdataType.ml133
-rwxr-xr-xdataType.mli67
-rwxr-xr-xerrors.ml12
-rwxr-xr-xevaluator.ml556
-rwxr-xr-xevaluator.mli65
-rwxr-xr-xexpression.ml22
-rwxr-xr-xexpression.mli2
-rwxr-xr-xfunctions.ml100
-rwxr-xr-xmain.ml12
-rwxr-xr-xodf/odf.ml1
-rwxr-xr-xreadme.rst18
-rwxr-xr-xscTypes.ml78
-rwxr-xr-xscTypes.mli32
-rwxr-xr-xscreen.ml67
-rwxr-xr-xsheet.ml42
-rwxr-xr-xtests/dataType_test.ml44
-rwxr-xr-xtests/expression_test.ml1
-rwxr-xr-xtests/sheet_test.ml8
-rwxr-xr-xtests/test.ml1
-rwxr-xr-xtools.ml257
23 files changed, 1274 insertions, 256 deletions
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