diff options
| -rwxr-xr-x | .gitignore | 3 | ||||
| -rwxr-xr-x | .merlin | 2 | ||||
| -rwxr-xr-x | Makefile | 7 | ||||
| -rwxr-xr-x | dataType.ml | 133 | ||||
| -rwxr-xr-x | dataType.mli | 67 | ||||
| -rwxr-xr-x | errors.ml | 12 | ||||
| -rwxr-xr-x | evaluator.ml | 556 | ||||
| -rwxr-xr-x | evaluator.mli | 65 | ||||
| -rwxr-xr-x | expression.ml | 22 | ||||
| -rwxr-xr-x | expression.mli | 2 | ||||
| -rwxr-xr-x | functions.ml | 100 | ||||
| -rwxr-xr-x | main.ml | 12 | ||||
| -rwxr-xr-x | odf/odf.ml | 1 | ||||
| -rwxr-xr-x | readme.rst | 18 | ||||
| -rwxr-xr-x | scTypes.ml | 78 | ||||
| -rwxr-xr-x | scTypes.mli | 32 | ||||
| -rwxr-xr-x | screen.ml | 67 | ||||
| -rwxr-xr-x | sheet.ml | 42 | ||||
| -rwxr-xr-x | tests/dataType_test.ml | 44 | ||||
| -rwxr-xr-x | tests/expression_test.ml | 1 | ||||
| -rwxr-xr-x | tests/sheet_test.ml | 8 | ||||
| -rwxr-xr-x | tests/test.ml | 1 | ||||
| -rwxr-xr-x | tools.ml | 257 |
23 files changed, 1274 insertions, 256 deletions
@@ -3,3 +3,6 @@ _build/ *.native *.swp *.docdir +*.o +*.so +*.a @@ -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/* @@ -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
- );
@@ -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 @@ -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
@@ -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 =================== ===================================== @@ -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
@@ -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 - +*) @@ -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; @@ -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 |