From a6b5a6bdd138a5ccc6827bcc73580df1e9218820 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Fri, 24 Nov 2017 09:22:24 +0100 Subject: Moved all the code to src directory --- src/UTF8.ml | 54 +++++ src/UTF8.mli | 92 ++++++++ src/actionParser.mly | 45 ++++ src/actions.mli | 28 +++ src/catalog.ml | 125 +++++++++++ src/catalog.mli | 38 ++++ src/cell.ml | 70 ++++++ src/cell.mli | 20 ++ src/dataType.ml | 125 +++++++++++ src/dataType.mli | 99 +++++++++ src/date.ml | 120 ++++++++++ src/date.mli | 38 ++++ src/errors.ml | 14 ++ src/evaluator.ml | 373 +++++++++++++++++++++++++++++++ src/evaluator.mli | 66 ++++++ src/expression.ml | 114 ++++++++++ src/expression.mli | 29 +++ src/expressionLexer.mll | 84 +++++++ src/expressionParser.mly | 113 ++++++++++ src/functions.ml | 14 ++ src/main.ml | 241 ++++++++++++++++++++ src/odf/odf.ml | 346 +++++++++++++++++++++++++++++ src/odf/odf_ExpressionLexer.mll | 93 ++++++++ src/odf/odf_ExpressionParser.mly | 95 ++++++++ src/odf/odf_ns.ml | 96 ++++++++ src/scTypes.ml | 354 ++++++++++++++++++++++++++++++ src/scTypes.mli | 126 +++++++++++ src/screen.ml | 459 +++++++++++++++++++++++++++++++++++++++ src/screen.mli | 29 +++ src/selection.ml | 73 +++++++ src/selection.mli | 20 ++ src/sheet.ml | 334 ++++++++++++++++++++++++++++ src/sheet.mli | 75 +++++++ src/splay.ml | 142 ++++++++++++ src/splay.mli | 30 +++ src/tools.ml | 392 +++++++++++++++++++++++++++++++++ src/unicode.ml | 51 +++++ src/unicode.mli | 27 +++ 38 files changed, 4644 insertions(+) create mode 100755 src/UTF8.ml create mode 100755 src/UTF8.mli create mode 100755 src/actionParser.mly create mode 100755 src/actions.mli create mode 100755 src/catalog.ml create mode 100644 src/catalog.mli create mode 100755 src/cell.ml create mode 100755 src/cell.mli create mode 100755 src/dataType.ml create mode 100755 src/dataType.mli create mode 100644 src/date.ml create mode 100755 src/date.mli create mode 100755 src/errors.ml create mode 100755 src/evaluator.ml create mode 100755 src/evaluator.mli create mode 100755 src/expression.ml create mode 100755 src/expression.mli create mode 100755 src/expressionLexer.mll create mode 100755 src/expressionParser.mly create mode 100755 src/functions.ml create mode 100755 src/main.ml create mode 100755 src/odf/odf.ml create mode 100755 src/odf/odf_ExpressionLexer.mll create mode 100755 src/odf/odf_ExpressionParser.mly create mode 100755 src/odf/odf_ns.ml create mode 100755 src/scTypes.ml create mode 100755 src/scTypes.mli create mode 100755 src/screen.ml create mode 100755 src/screen.mli create mode 100755 src/selection.ml create mode 100755 src/selection.mli create mode 100755 src/sheet.ml create mode 100755 src/sheet.mli create mode 100644 src/splay.ml create mode 100755 src/splay.mli create mode 100755 src/tools.ml create mode 100755 src/unicode.ml create mode 100755 src/unicode.mli (limited to 'src') diff --git a/src/UTF8.ml b/src/UTF8.ml new file mode 100755 index 0000000..a955b1e --- /dev/null +++ b/src/UTF8.ml @@ -0,0 +1,54 @@ +include Text + +let empty = "" + +let decode x = Text.decode x + +let encode x = + try Some (Text.encode x) + with Text.Invalid (_, _) -> None + +let raw_encode x = Text.encode x + +let from_utf8string x = x + +let to_utf8string x = x + +let trim x = Text.strip x + +let split str ~sep = + match Text.split ~max:1 ~sep str with + | [] -> "" + | hd::tl -> hd + +let replace text patt repl = Text.replace text ~patt ~repl + +module Buffer = struct + + include Buffer + + type buffer = t + + let add_char b c = Uchar.of_char c + |> Uchar.to_int + |> Text.char + |> Buffer.add_string b +end + +module Printf = struct + + include Printf + +end + +module Format = struct + + include Format + + let bprintf buffer fformat = begin + let to_b = formatter_of_buffer buffer in + let x = fprintf to_b fformat in + x + end + +end diff --git a/src/UTF8.mli b/src/UTF8.mli new file mode 100755 index 0000000..a2e331e --- /dev/null +++ b/src/UTF8.mli @@ -0,0 +1,92 @@ +(** UTF8 is used internally for all strings + + The module is intentionaly opaque. + + *) + +(** An UTF8 encoded string *) +type t + +val empty: t + +(** Decode a string in the current locale *) +val decode: string -> t + +(** Use this to with a known UTF8 encoded string *) +val from_utf8string: string -> t + +(** Encode to the string to the user locale *) +val encode: t -> string option + +(** Encode the string. + This function may raise Text.Invalid if the string cannot be encoded in current locale +*) +val raw_encode: t -> string + +val to_utf8string: t -> string + +val trim: t -> t + +val length: t -> int + +val get: t -> int -> t + +val rev_explode : t -> t list + +val split: t -> sep:t -> t + +val fold : (t -> 'a -> 'a) -> t -> 'a -> 'a + +val implode : t list -> t + +val rev_implode : t list -> t + +val compare: t -> t -> int + +val replace: t -> t -> t -> t + +val upper: t -> t + +val lower: t -> t + +val code: t -> int + +val char: int -> t + +val repeat: int -> t -> t + +val get: t -> int -> t + +val lchop: t -> t + +val rchop: t -> t + +val sub: t -> int -> int -> t + +module Buffer : sig + + type buffer + + val create : int -> buffer + + val contents : buffer -> t + + val add_string : buffer -> t -> unit + + val add_char: buffer -> char -> unit + +end + +module Printf : sig + + val bprintf : Buffer.buffer -> ('a, Buffer.buffer, unit) format -> 'a + +end + +module Format: sig + + val formatter_of_buffer : Buffer.buffer -> Format.formatter + + val fprintf : Format.formatter -> ('a, Format.formatter, unit) format -> 'a + +end diff --git a/src/actionParser.mly b/src/actionParser.mly new file mode 100755 index 0000000..6318ca6 --- /dev/null +++ b/src/actionParser.mly @@ -0,0 +1,45 @@ +%{ + open Actions + +%} + +%token ESC +%token EOF +%token LEFT RIGHT UP DOWN +%token NPAGE PPAGE HOME END +%token RESIZE +%token DELETE +%token SEARCH +%token E U V Y P +%token EQUAL +%token I +%token BUTTON1_CLICKED +%token BUTTON1_RELEASED +%token COMMAND + +%start normal +%% + + +normal: + | ESC { Escape } + | LEFT { Move (Left 1) } + | RIGHT { Move (Right 1) } + | UP { Move (Up 1) } + | DOWN { Move (Down 1) } + | RESIZE { Resize } + | DELETE { Delete } + | E { Edit } + | U { Undo } + | V { Visual } + | Y { Yank } + | P { Paste } + | SEARCH { Search } + | EQUAL { InsertFormula } + | NPAGE { Move (Down 10)} + | PPAGE { Move (Up 10)} + | HOME { Move (Left 10)} + | END { Move (Right 10)} + | BUTTON1_CLICKED { Button1_clicked $1} + | BUTTON1_RELEASED{ Button1_released $1} + | COMMAND { Command } diff --git a/src/actions.mli b/src/actions.mli new file mode 100755 index 0000000..f955538 --- /dev/null +++ b/src/actions.mli @@ -0,0 +1,28 @@ +type direction = +| Up of int +| Down of int +| Left of int +| Right of int +| Absolute of int * int + +type modes = +| Normal +| Select +| Edit +| Command + +type actions = +| Move of direction +| Resize (* Resize event *) +| Escape +| Delete +| Yank +| Paste +| Search +| Undo +| Edit +| InsertFormula +| Visual +| Button1_clicked of (int * int) +| Button1_released of (int * int) +| Command diff --git a/src/catalog.ml b/src/catalog.ml new file mode 100755 index 0000000..e4cd34b --- /dev/null +++ b/src/catalog.ml @@ -0,0 +1,125 @@ +module T = Tools +module type DATA_SIG = sig + + type 'a typ + + type 'a returnType + + val compare_typ: 'a typ -> 'b typ -> ('a, 'b) T.cmp + + val repr: Format.formatter -> 'a typ -> unit + +end + +(** 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 + +(** Catalog for all functions *) +module Make(Data:DATA_SIG) = struct + + (** This is the way the function is store in the map. + We just the return type, and the function itself. *) + type _ t_function = + | Fn1: 'b Data.returnType * ('a -> 'b) -> 'a t_function + | Fn2: 'c Data.returnType * ('a -> 'b -> 'c) -> ('a * 'b) t_function + | Fn3: 'd Data.returnType * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function + + (** This is the key for storing functions in the map. *) + type _ sig_typ = + | T1: 'a Data.typ -> 'a t_function sig_typ + | T2: 'a Data.typ * 'b Data.typ -> ('a * 'b) t_function sig_typ + | T3: 'a Data.typ * 'b Data.typ * 'c Data.typ -> ('a * 'b * 'c) t_function sig_typ + + + let repr: type a. Format.formatter -> a sig_typ -> unit = fun formatter -> function + | T1 t -> Format.fprintf formatter "(%a)" Data.repr t + | T2 (t1, t2) -> Format.fprintf formatter "(%a,%a)" Data.repr t1 Data.repr t2 + | T3 (t1, t2, t3) -> Format.fprintf formatter "(%a,%a,%a)" Data.repr t1 Data.repr t2 Data.repr t3 + + module ComparableSignature = struct + + type 'a t = string * 'a sig_typ + + (* Type for pure equality *) + type (_, _) eq = Eq : ('a, 'a) eq + + (** Compare two signature *) + let comp: type a b. string * a sig_typ -> string * b sig_typ -> (a, b) T.cmp = begin fun (namea, a) (nameb, b) -> + + let cmp: type c d. c Data.typ -> d Data.typ -> ((c, d) eq -> (a, b) T.cmp) -> (a, b) T.cmp = + begin fun a b f -> match Data.compare_typ a b with + | T.Eq -> f Eq + | T.Lt -> T.Lt + | T.Gt -> T.Gt + end in + + if namea < nameb then + T.Lt + else if namea > nameb then + T.Gt + else match a, b with + + | T1(a), T1(b) -> cmp a b (fun Eq -> T.Eq) + | T1(_), _ -> T.Lt + | _, T1(_) -> T.Gt + + | T2(a, b), T2(c, d) -> + cmp a c (fun Eq -> + cmp b d (fun Eq -> T.Eq) + ) + | T2(_), _ -> T.Lt + | _, T2(_) -> T.Gt + + | T3(a, b, c), T3(d, e, f) -> + cmp a d (fun Eq -> + cmp b e (fun Eq -> + cmp c f (fun Eq -> T.Eq) + ) + ) + + end + + + let repr : type a. Format.formatter -> a t -> unit = begin fun formatter (str, typ) -> + Format.fprintf formatter "%s:%a" + str + repr typ + end + + end + + module Functions = Splay.Make(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. + *) + type t = Functions.t + + let empty = Functions.empty + + (** + Register a function in the catalog. If the function is already defined, + raise an exception. + *) + let register t name signature f = begin + + let name' = String.uppercase_ascii name in + if Functions.member (name', signature) t then + raise RegisteredFunction + else + Functions.add (name', signature) f t + end + + (** Look in the catalog for a function with the given name and signature *) + let find_function: + type a. t -> string -> a t_function sig_typ -> a t_function = + begin fun t name signature -> + Functions.find ((String.uppercase_ascii name), signature) t + end + + let repr = Functions.repr + +end diff --git a/src/catalog.mli b/src/catalog.mli new file mode 100644 index 0000000..e871378 --- /dev/null +++ b/src/catalog.mli @@ -0,0 +1,38 @@ +module type DATA_SIG = sig + + type 'a typ + + type 'a returnType + + val compare_typ: 'a typ -> 'b typ -> ('a, 'b) Tools.cmp + + val repr: Format.formatter -> 'a typ -> unit + +end + +module Make(D:DATA_SIG): sig + + type t + + type 'a t_function = + | Fn1: 'b D.returnType * ('a -> 'b) -> 'a t_function + | Fn2: 'c D.returnType * ('a -> 'b -> 'c) -> ('a * 'b) t_function + | Fn3: 'd D.returnType * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function + + type 'a sig_typ = + | T1: 'a D.typ -> 'a t_function sig_typ + | T2: 'a D.typ * 'b D.typ -> ('a * 'b) t_function sig_typ + | T3: 'a D.typ * 'b D.typ * 'c D.typ -> ('a * 'b * 'c) t_function sig_typ + + (** Empty catalog *) + val empty: t + + (** Register a new function in the catalog *) + val register : t -> string -> 'a t_function sig_typ -> 'a t_function -> t + + (** Find a function with the given name and signature *) + val find_function: t -> string -> 'a t_function sig_typ -> 'a t_function + + val repr: Format.formatter -> t -> unit + +end diff --git a/src/cell.ml b/src/cell.ml new file mode 100755 index 0000000..e6ccd63 --- /dev/null +++ b/src/cell.ml @@ -0,0 +1,70 @@ +type t = (int * int) * (bool * bool) + +let u = UTF8.from_utf8string + +let from_string (fixed_x, x_name) (fixed_y, y) = + + let x = ref 0 in + String.iter (function + | 'a'..'z' as c -> x:= (!x * 26) + ((int_of_char c) - 96) + | 'A'..'Z' as c -> x:= (!x * 26) + ((int_of_char c) - 64) + | _ -> () + ) x_name; + (!x, y), (fixed_x, fixed_y) + +let to_hname x = begin + let rec extract acc value = + if value > 0 then ( + let value' = value - 1 in + let rem = value' mod 26 in + let quot = (value' - rem) / 26 + in extract ((char_of_int (65 + rem))::acc) quot + ) else ( + acc + ) + in + let res = extract [] x + and buff = UTF8.Buffer.create 4 in + List.iter (fun c -> UTF8.Buffer.add_char buff c) res; + UTF8.Buffer.contents buff +end + +let to_string ((x, y), (fixed_x, fixed_y)) = + let buff = UTF8.Buffer.create 2 in + + if fixed_x then UTF8.Buffer.add_char buff '$'; + UTF8.Buffer.add_string buff (to_hname x); + if fixed_y then UTF8.Buffer.add_char buff '$'; + UTF8.Buffer.add_string buff @@ u @@ string_of_int y; + UTF8.Buffer.contents buff + +let to_buffer buff ((x, y), (fixed_x, fixed_y)) = begin + if fixed_x then UTF8.Buffer.add_char buff '$'; + UTF8.Buffer.add_string buff (to_hname x); + if fixed_y then UTF8.Buffer.add_char buff '$'; + UTF8.Buffer.add_string buff @@ u @@ string_of_int y +end + +let to_string t = + let buff = UTF8.Buffer.create 2 in + to_buffer buff t; + UTF8.Buffer.contents buff + +let to_pair = Pervasives.fst + +module Set = (struct + include Set.Make(struct + type t = (int * int) + let compare = Pervasives.compare + end) + + let show_int_tuple b t = Tools.Tuple2.printb + (fun b x -> UTF8.Buffer.add_string b @@u(string_of_int x)) + (fun b x -> UTF8.Buffer.add_string b @@u(string_of_int x)) + b t + + let printb buff = + iter (fun x -> to_buffer buff (x, (false,false)); UTF8.Buffer.add_char buff ' ') + +end) + diff --git a/src/cell.mli b/src/cell.mli new file mode 100755 index 0000000..8f225a5 --- /dev/null +++ b/src/cell.mli @@ -0,0 +1,20 @@ +type t = (int * int) * (bool * bool) + +module Set : sig + + include Set.S with type elt = (int * int) + + val printb: UTF8.Buffer.buffer -> t -> unit + +end + +val to_pair: t -> (int * int) + +val from_string: bool * string -> bool * int -> t + +val to_hname: int -> UTF8.t + +val to_string: t -> UTF8.t + +val to_buffer: UTF8.Buffer.buffer -> t -> unit + diff --git a/src/dataType.ml b/src/dataType.ml new file mode 100755 index 0000000..f30dd8c --- /dev/null +++ b/src/dataType.ml @@ -0,0 +1,125 @@ +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 + + let rnd () = + let value = Random.bits () in + Q.make (Z.of_int value) (Z.of_int (1 lsl 30)) + + include Q + + let is_integer t = (Q.den t) == Z.one + + let eq = Q.equal + + let neq a b = not (Q.equal a b) + + let mult = Q.mul + + let floor t = + let num = Q.num t + and den = Q.den t in + + if is_integer t then + Q.of_bigint num + else + Q.of_bigint @@ Z.fdiv num den + + let round_down t = + let num = Q.num t + and den = Q.den t in + + if is_integer t then + Q.of_bigint num + else + Q.of_bigint @@ Z.div num den + + let round t = + if is_integer t then + t + else + let t' = match Q.sign t with + | 1 -> Q.add t @@ Q.of_ints 1 2 + | -1 -> Q.add t @@ Q.of_ints (-1) 2 + | _ -> t in + let num = Q.num t' + and den = Q.den t' in + Q.of_bigint (Z.div num den) + + let ge = Q.geq + + let ge = Q.geq + + let le = Q.leq + + let pow t q_factor = begin + + if is_integer q_factor then + + let factor = Q.to_int q_factor + and num = Q.num t + and den = Q.den t in + + Q.make (Z.pow num factor) (Z.pow den factor) + + else + + let factor = Q.to_float q_factor + and num = Z.to_float @@ Q.num t + and den = Z.to_float @@ Q.den t in + + Q.div + (Q.of_float (num ** factor)) + (Q.of_float (den ** factor)) + + end + + let gcd t1 t2 = + Q.of_bigint @@ Z.gcd (Q.to_bigint t1) (Q.to_bigint t2) + + let lcm t1 t2 = + Q.of_bigint @@ Z.lcm (Q.to_bigint t1) (Q.to_bigint t2) + +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 + +module Date = Date.Make(Num) diff --git a/src/dataType.mli b/src/dataType.mli new file mode 100755 index 0000000..5c89c98 --- /dev/null +++ b/src/dataType.mli @@ -0,0 +1,99 @@ +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 one: t + val zero: t + + val of_int: int -> t + val to_int: t -> int + + val to_float: t -> float + val of_float: float -> t + + val neg: t -> 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 + + 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 + + val round: t -> t + val floor: t -> t + val round_down: t -> t + + val gcd: t -> t -> t + val lcm: t -> t -> t + + val is_integer: t -> bool + +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 + +module Date: sig + + (** Create a date from a year month day *) + val get_julian_day : int -> int -> int -> Num.t + + (** Return the year, month and day from a date *) + val date_from_julian_day : Num.t -> int * int * int + + val time_from_julian_day : Num.t -> int * int * Num.t + + val from_string: string -> Num.t + + (** Print out the date *) + val to_string: Num.t -> string +end diff --git a/src/date.ml b/src/date.ml new file mode 100644 index 0000000..92cb9f6 --- /dev/null +++ b/src/date.ml @@ -0,0 +1,120 @@ +module type CALCULABLE = sig + + type t + + val add: t -> t -> t + + val sub: t -> t -> t + + val mult: t -> t -> t + + val div: t -> t -> t + + val floor: t -> t + + val of_int: int -> t + + val to_int: t -> int + + val to_float: t -> float + +end + + +module Make(C : CALCULABLE) = struct + + let get_julian_day year month day = begin + 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 *) + |> C.of_int + + end + + let date_from_julian_day day = begin + + let shift_day = C.add (C.floor day) (C.of_int 2415019) in + + let z = C.to_int shift_day in + let f = + if z >= 2299161 then + (* We use the Num module here to prevent overflow *) + let product = C.mult (C.of_int 4) shift_day in + let shifted = C.add product (C.of_int 274277) in + let div = C.div shifted (C.of_int 146097) in + let day' = C.to_int @@ C.floor div 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 + + let day = C.floor j in + let time = C.sub j day in + + let h = C.floor @@ C.mult time (C.of_int 24) in + let h_24 = C.div h (C.of_int 24) in + let m = C.floor @@ C.mult (C.of_int 1440) (C.sub time h_24) in + let s = C.mult (C.of_int 86400) (C.sub (C.sub time h_24) (C.div m (C.of_int 1440))) in + (C.to_int h, C.to_int m, s) + end + + (** Compute the julian for a given date. + + Integer return number of days since November 24, 4714 BC. + Fractionnal part return the time since midnight. + *) + let from_string str = begin + let n = C.of_int in + let date_regex = Str.regexp "[0-9]+-[0-9]+-[0-9]+" + and time_regex = Str.regexp "[0-9]+-[0-9]+-[0-9]+T[0-9]+:[0-9]+:[0-9]" in + if Str.string_match time_regex str 0 then + Scanf.sscanf str "%d-%d-%dT%d:%d:%d" (fun year month day hour min sec -> + let nhour = C.div (n hour) (n 24) + and nmin = C.div (n min) (n 1440) + and nsec = C.div (n sec) (n 86400) in + C.add (C.add (C.add (get_julian_day year month day) nhour) nmin) nsec + ) else if Str.string_match date_regex str 0 then + Scanf.sscanf str "%d-%d-%d" get_julian_day + else ( + C.of_int 0 + ) + end + + let to_string date = begin + let y, m, d = date_from_julian_day date + and h, n, s = time_from_julian_day date in + + Printf.sprintf "%d-%02d-%02dT%02d:%02d:%02g" + y m d + + h n (C.to_float s) + + end + +end diff --git a/src/date.mli b/src/date.mli new file mode 100755 index 0000000..dd24124 --- /dev/null +++ b/src/date.mli @@ -0,0 +1,38 @@ +module type CALCULABLE = sig + + type t + + val add: t -> t -> t + + val sub: t -> t -> t + + val mult: t -> t -> t + + val div: t -> t -> t + + val floor: t -> t + + val of_int: int -> t + + val to_int: t -> int + + val to_float: t -> float + +end + +module Make(C:CALCULABLE): sig + + (** Create a date from a year month day *) + val get_julian_day : int -> int -> int -> C.t + + (** Return the year, month and day from a date *) + val date_from_julian_day : C.t -> int * int * int + + val time_from_julian_day : C.t -> int * int * C.t + + val from_string: string -> C.t + + (** Print out the date *) + val to_string: C.t -> string + +end diff --git a/src/errors.ml b/src/errors.ml new file mode 100755 index 0000000..3751a60 --- /dev/null +++ b/src/errors.ml @@ -0,0 +1,14 @@ + +(** The function is undefined *) +exception Undefined of UTF8.t * string list + +exception TypeError + +exception Cycle + +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/src/evaluator.ml b/src/evaluator.ml new file mode 100755 index 0000000..f718e1f --- /dev/null +++ b/src/evaluator.ml @@ -0,0 +1,373 @@ +module D = DataType +module T = Tools + +module Data = struct + +(** Data format *) + +type 'a dataFormat = 'a ScTypes.dataFormat + +(*** 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 typ_of_format: type a. a ScTypes.dataFormat -> a typ = function + | ScTypes.Date -> Num + | ScTypes.Number -> Num + | ScTypes.String -> String + | ScTypes.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 repr: +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]" + repr t + +type 'a returnType = 'a ScTypes.returnType + +(*** Values definitions *) + +type 'a value = + | Bool: D.Bool.t -> D.Bool.t value + | Num: D.Num.t ScTypes.dataFormat * D.Num.t -> D.Num.t value + | String: UTF8.t -> UTF8.t value + | List: 'a ScTypes.dataFormat * 'a list -> 'a list value + | Matrix: 'a ScTypes.dataFormat * 'a list list -> 'a list list value + +(** 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 + | Matrix (t, l) -> l + +(* 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) + | Matrix (t, l) -> List (List (typ_of_format t)) + +end + +module C = Catalog.Make(Data) + + +type t = C.t + +let catalog = ref C.empty + +let get_catalog () = !catalog + +let repr = C.repr + +type existencialResult = + | Result : 'a Data.value -> existencialResult [@@unboxed] + +let inject: +type a. a Data.dataFormat -> a -> existencialResult = fun resultFormat res -> + begin match resultFormat with + | ScTypes.Bool -> Result (Data.Bool res) + | ScTypes.String -> Result (Data.String res) + | ScTypes.Number -> Result (Data.Num (resultFormat, res)) + | ScTypes.Date -> Result (Data.Num (resultFormat, res)) + end + + +(** Extract the format from a list of results *) +let build_format_list ll () = + + List.map (fun (Result x) -> + begin match x with + | Data.Bool _ -> ScTypes.DataFormat.F (ScTypes.Bool) + | Data.Num (x, _) -> ScTypes.DataFormat.F x + | Data.String _ -> ScTypes.DataFormat.F (ScTypes.String) + | Data.List (f, _) -> ScTypes.DataFormat.F f + | Data.Matrix (f, _) -> ScTypes.DataFormat.F f + end + ) ll + + +let register0 name returnType f = + catalog := C.register !catalog name (C.T1(Data.Unit)) (C.Fn1 (returnType, f)) + +let register1 name typ1 returnType f = + catalog := C.register !catalog name (C.T1(typ1)) (C.Fn1 (returnType, f)) + +let register2 name (typ1, typ2) result f = + catalog := C.register !catalog name (C.T2(typ1, typ2)) (C.Fn2 (result, f)) + +let register3 name (typ1, typ2, typ3) result f = + catalog := C.register !catalog 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 !catalog name' (C.T1 Data.Unit) in + let returnType = ScTypes.DataFormat.guess_format_result ret (fun () -> raise Errors.TypeError) in + inject returnType (f ()) + + | (Result p1)::[] -> + let C.Fn1(ret, f) = + C.find_function !catalog name' (C.T1 (Data.type_of_value p1)) in + let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in + inject returnType (f (Data.get_value_content p1)) + + | (Result p1)::(Result p2)::[] -> + let C.Fn2(ret, f) = + C.find_function !catalog name' (C.T2 (Data.type_of_value p1, Data.type_of_value p2)) in + let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in + inject returnType (f (Data.get_value_content p1) (Data.get_value_content p2)) + + | (Result p1)::(Result p2)::(Result p3)::[] -> + let C.Fn3(ret, f) = + C.find_function !catalog name' (C.T3 (Data.type_of_value p1, Data.type_of_value p2, Data.type_of_value p3)) in + let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in + inject returnType (f (Data.get_value_content p1) (Data.get_value_content p2) (Data.get_value_content p3)) + + | _ -> raise Not_found + with Not_found -> + let signature = List.map (fun (Result x) -> + let formatter = Format.str_formatter in + Data.repr formatter (Data.type_of_value x); + Format.flush_str_formatter ()) args in + + raise (Errors.Undefined (name, signature)) + end +end + +let eval mapper value = begin + + (** Extract the value from a raw type. + If the value is Undefined, raise an exception. + *) + let extract_value : ScTypes.result -> existencialResult = begin function + | ScTypes.Result (ScTypes.Num (f, n)) -> Result (Data.Num (f, n)) + | ScTypes.Result (ScTypes.Bool b) -> Result (Data.Bool b) + | ScTypes.Result (ScTypes.Str s) -> Result (Data.String s) + | ScTypes.Error x -> raise x + end in + + (** Extract the value from an expression. + [extract 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 -> ScTypes.Refs.( + begin match ScTypes.Refs.get_content @@ mapper r with + | C (Value (format, f)) -> begin match format with + | ScTypes.Date -> Result (Data.Num (format, f)) + | ScTypes.Number -> Result (Data.Num (format, f)) + | ScTypes.String -> Result (Data.String f) + | ScTypes.Bool -> Result (Data.Bool f) + end + | C (List (format, l)) -> Result (Data.List (format, l)) + | C (Matrix (format, l)) -> Result (Data.Matrix (format, l)) + end) + + (* Evaluate the expression *) + | ScTypes.Expression e -> extract e + | ScTypes.Value v -> extract_value (ScTypes.Result v) + | ScTypes.Call (name, args) -> + let args' = List.map extract args in + call name args' + end + in + let Result r = ((extract[@tailrec]) value) in + begin match r with + | Data.Bool b -> ScTypes.Result (ScTypes.boolean b) + | Data.String s -> ScTypes.Result (ScTypes.string s) + | Data.Num (format, n) -> begin match ScTypes.get_numeric_type format with + | ScTypes.Date -> ScTypes.Result (ScTypes.date n) + | ScTypes.Number -> ScTypes.Result (ScTypes.number n) + end + | _ -> raise Errors.TypeError + end +end + +let wrap f = + let old_catalog = !catalog in + Tools.try_finally + (fun () -> catalog := C.empty; f ()) + (fun () -> catalog := old_catalog) + + +(* Register the standard functions *) +type 'a returnType = 'a ScTypes.returnType + +let f_num = ScTypes.f_num +let f_date = ScTypes.f_date +let f_number = ScTypes.f_number +let f_string = ScTypes.f_string +let f_bool = ScTypes.f_bool + +module Make_Compare(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 + +type 'a typ = 'a Data.typ +let t_bool: DataType.Bool.t typ = Data.Bool +let t_int: DataType.Num.t typ = Data.Num +let t_string: UTF8.t typ = Data.String +let t_list (t: 'a typ): 'a list typ = Data.List t + +(* 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 if_: type a. bool -> a -> a -> a = fun a b c -> if a then b else c + + +let () = begin + + (* Build a date *) + register3 "date" (t_int, t_int, t_int) f_date ( + fun year month day -> + D.Date.get_julian_day + (D.Num.to_int year) + (D.Num.to_int month) + (D.Num.to_int day) + ); + + let module CompareNum = Make_Compare(D.Num) in + Data.( + CompareNum.register t_int; + register0 "rand" f_number D.Num.rnd; + + register0 "pi" f_number (fun () -> D.Num.of_float (4. *. atan 1.)); + register1 "sin" t_int f_number (fun x -> D.Num.of_float (sin @@ D.Num.to_float x)); + register1 "cos" t_int f_number (fun x -> D.Num.of_float (cos @@ D.Num.to_float x)); + register1 "tan" t_int f_number (fun x -> D.Num.of_float (tan @@ D.Num.to_float x)); + register1 "atan" t_int f_number (fun x -> D.Num.of_float (atan @@ D.Num.to_float x)); + register1 "asin" t_int f_number (fun x -> D.Num.of_float (asin @@ D.Num.to_float x)); + register1 "acos" t_int f_number (fun x -> D.Num.of_float (acos @@ D.Num.to_float x)); + register1 "sinh" t_int f_number (fun x -> D.Num.of_float (sinh @@ D.Num.to_float x)); + register1 "cosh" t_int f_number (fun x -> D.Num.of_float (cosh @@ D.Num.to_float x)); + register1 "tanh" t_int f_number (fun x -> D.Num.of_float (tanh @@ D.Num.to_float x)); + register2 "atan2" (t_int, t_int)f_number (fun x y -> + D.Num.of_float (atan2 (D.Num.to_float x) (D.Num.to_float y)) + ); + + register1 "sqrt" t_int f_number (fun x -> D.Num.of_float (sqrt @@ D.Num.to_float x)); + register1 "exp" t_int f_number (fun x -> D.Num.of_float (exp @@ D.Num.to_float x)); + register1 "ln" t_int f_number (fun x -> D.Num.of_float (log @@ D.Num.to_float x)); + + register3 "if" (t_bool, t_int, t_int) f_number if_; + register3 "if" (t_bool, t_bool, t_bool) f_bool if_; + register3 "if" (t_bool, t_string, t_string) f_string if_; + + register1 "abs" t_int f_number D.Num.abs; + register1 "int" t_int f_number D.Num.floor; + register1 "rounddown" t_int f_number D.Num.round_down; + register1 "round" t_int f_number D.Num.round; + + register1 "trim" t_string f_string UTF8.trim; + register1 "right" t_string f_string (fun x -> UTF8.get x (-1)); + register2 "right" (t_string, t_int) f_string ( + fun t n -> + let n' = D.Num.to_int n in + UTF8.sub t (-(n')) n' + ); + register1 "left" t_string f_string (fun x -> UTF8.get x 0); + register2 "left" (t_string, t_int) f_string ( + fun t n -> + let n' = D.Num.to_int n in + UTF8.sub t 0 n' + ); + register1 "len" t_string f_number (fun x -> D.Num.of_int @@ UTF8.length x); + register1 "lenb" t_string f_number (fun x -> D.Num.of_int @@ String.length @@ UTF8.to_utf8string x); + register1 "lower" t_string f_string UTF8.lower; + register1 "unicode" t_string f_number (fun x -> D.Num.of_int @@ UTF8.code x); + register1 "unichar" t_int f_string (fun x -> UTF8.char @@ D.Num.to_int x); + register1 "upper" t_string f_string UTF8.upper; + register3 "substitute" (t_string, t_string, t_string) f_string UTF8.replace; + register2 "rept" (t_string, t_int) f_string (fun t n -> UTF8.repeat (D.Num.to_int n) t); + + let module CompareBool = Make_Compare(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_; +(* fold "and" t_bool f_bool D.Bool.and_ (D.Bool.true_); *) + register2 "or" (t_bool, t_bool) f_bool D.Bool.or_; +(* fold "or" t_bool f_bool D.Bool.or_ (D.Bool.false_); *) + register2 "xor" (t_bool, t_bool) f_bool D.Bool.neq; +(* fold "xor" t_bool f_bool D.Bool.neq (D.Bool.false_); *) + + let module CompareString = Make_Compare(D.String) in + CompareString.register t_string; + + 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 *) + + fold "sum" t_int f_number D.Num.add (D.Num.zero); + fold "product" t_int f_number D.Num.mult (D.Num.one); + + register2 "^" (t_int, t_int) f_number D.Num.pow; + register2 "power" (t_int, t_int) f_number D.Num.pow; + + register2 "gcd"(t_int, t_int) f_number D.Num.gcd; + register2 "lcm"(t_int, t_int) f_number D.Num.lcm; + register1 "+" t_int f_num (fun x -> x); + register1 "-" t_int f_num D.Num.neg; (* Unary negation *) + 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; + + ) + +end + diff --git a/src/evaluator.mli b/src/evaluator.mli new file mode 100755 index 0000000..b296b90 --- /dev/null +++ b/src/evaluator.mli @@ -0,0 +1,66 @@ +type t + +val eval: (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.expression -> ScTypes.result + +val repr: Format.formatter -> t -> unit + +val get_catalog: unit -> t + +(** 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 returnType + +(** Numeric (any format) *) +val f_num: DataType.Num.t returnType + +(** Date *) +val f_date: DataType.Num.t returnType + +(** Number *) +val f_number: DataType.Num.t returnType + +(** Boolean result *) +val f_bool: DataType.Bool.t returnType + +(** String *) +val f_string: DataType.String.t returnType + +(** Catalog *) + +val register0: + string -> (* The function name *) + 'a returnType -> (* The return type *) + (unit -> 'a) (* The function to call *) + -> unit + +val register1: + string -> (* The function name *) + 'a typ -> (* The signature *) + 'b returnType -> (* The return type *) + ('a -> 'b) (* The function to call *) + -> unit + +val register2: + string -> (* The function name *) + ('a typ * 'b typ) ->(* The signature *) + 'c returnType -> (* 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 returnType -> (* 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/src/expression.ml b/src/expression.ml new file mode 100755 index 0000000..20227ad --- /dev/null +++ b/src/expression.ml @@ -0,0 +1,114 @@ +module Tuple2 = Tools.Tuple2 + +let u = UTF8.from_utf8string + +type t = + | Basic: 'a ScTypes.types -> t (** A direct type *) + | Formula: formula -> t (** A formula *) + | Undefined: t (** The content is not defined *) + +and formula = + | Expression of ScTypes.expression (** A valid expression *) + | Error of int * UTF8.t (** When the expression cannot be parsed *) + + +let is_defined = function + | Undefined -> false + | _ -> true + +let load content = begin + let content = UTF8.to_utf8string content in + if String.length content > 0 then ( + if content.[0] = '=' then ( + (* If the string start with a '=', load it as a formula *) + Formula ( + try + Expression ( + Lexing.from_string content + |> ExpressionParser.value ExpressionLexer.read) + with _ -> Error (1, UTF8.from_utf8string content) + ) + ) else ( + (* First try to load the data with basic types, and fallback with string *) + let content' = + try String.sub content 0 (String.index content '\000') + with Not_found -> content in + try + let ScTypes.Result r = + ExpressionParser.content ExpressionLexer.read + @@ Lexing.from_string content' in + Basic r + with _ -> Basic (ScTypes.string (UTF8.from_utf8string content')) + ) + ) else ( + (* If the string in empty, build an undefined value *) + Undefined + ) +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 eval_exp f = Evaluator.eval sources f in + + begin try match expr with + | Basic value -> ScTypes.Result value + | Formula (Expression f) -> eval_exp f + | Formula (Error (i, s)) -> ScTypes.Error ScTypes.Error + | Undefined -> ScTypes.Error Not_found + with ex -> ScTypes.Error ex + end + +end + +let collect_sources expr = begin + let rec collect refs = function + | ScTypes.Ref r -> + begin match ScTypes.Refs.collect r with + | ScTypes.Refs.Single r -> Cell.Set.add r refs + | ScTypes.Refs.Array1 a1 -> + List.fold_left (fun set elt -> Cell.Set.add elt set) refs a1 + | ScTypes.Refs.Array2 a2 -> + List.fold_left (List.fold_left (fun set elt -> Cell.Set.add elt set)) refs a2 + end + | ScTypes.Call (ident, params) -> List.fold_left collect refs params + | ScTypes.Expression f -> collect refs f + | _ -> refs + in match expr with + | Formula (Expression f) -> collect Cell.Set.empty f + | _ -> Cell.Set.empty +end + +let show e = + let buffer = UTF8.Buffer.create 16 in + begin match e with + | Formula (Expression f) -> + UTF8.Buffer.add_char buffer '='; + ScTypes.show_expr buffer f + | Basic b -> ScTypes.Type.show_full buffer b + | Formula (Error (i,s)) -> UTF8.Buffer.add_string buffer s + | Undefined -> () + end; + UTF8.Buffer.contents buffer + +let shift vector = + + let rec shift_exp: ScTypes.expression -> ScTypes.expression = function + | ScTypes.Value v -> ScTypes.Value v + | ScTypes.Call (ident, params) -> ScTypes.Call (ident, List.map shift_exp params) + | ScTypes.Ref r -> ScTypes.Ref (ScTypes.Refs.shift vector r) + | ScTypes.Expression expr -> ScTypes.Expression (shift_exp expr) + + in function + | Formula (Expression f) -> Formula (Expression (shift_exp f)) + | other -> other + +let (=) t1 t2 = match t1, t2 with + | Basic b1, Basic b2 -> ScTypes.Type.(=) b1 b2 + | o1, o2 -> Pervasives.(=) o1 o2 diff --git a/src/expression.mli b/src/expression.mli new file mode 100755 index 0000000..8cab479 --- /dev/null +++ b/src/expression.mli @@ -0,0 +1,29 @@ +type t = + | Basic: 'a ScTypes.types -> t (** A direct type *) + | Formula: formula -> t (** A formula *) + | Undefined: t (** The content is not defined *) + +and formula = + | Expression of ScTypes.expression (** A valid expression *) + | Error of int * UTF8.t (** When the expression cannot be parsed *) + + +(** Load an expression *) +val load: UTF8.t -> t + +val load_expr: t -> t + +val is_defined: t -> bool + +(** Evaluate the expression *) +val eval: t -> (ScTypes.refs -> ScTypes.result option ScTypes.Refs.range) -> ScTypes.result + +(** Collect all the cell referenced in the expression *) +val collect_sources: t -> Cell.Set.t + +(** Represent an expression *) +val show: t -> UTF8.t + +val shift: (int * int) -> t -> t + +val (=): t -> t -> bool diff --git a/src/expressionLexer.mll b/src/expressionLexer.mll new file mode 100755 index 0000000..2d2f87e --- /dev/null +++ b/src/expressionLexer.mll @@ -0,0 +1,84 @@ +{ + open ExpressionParser + open Lexing + + exception SyntaxError of string +} + +let digit = ['0'-'9'] +let real = digit+ '.'? | digit* '.' digit+ + + +let newline = "\r\n" | '\n' | '\r' +let space = ['\t' ' '] | newline + +let letters = ['A'-'Z' 'a'-'z'] + +let text = letters | digit + +let cell = letters+ digit+ + +rule read = parse + | space+ { read lexbuf } + + | digit+ as _1 { NUM _1} + | real as _1 { REAL(Tools.String.filter_float _1)} + | '$' { DOLLAR } + + | '=' { EQ } + | "<>" { NEQ } + | '<' { LT } + | "<=" { LE } + | '>' { GT } + | ">=" { GE } + | '*' { TIMES } + | '+' { PLUS } + | '-' { MINUS } + | '/' { DIVIDE } + | '"' { read_string (Buffer.create 17) lexbuf } + | ';' { SEMICOLON } + | ':' { COLON } + | '(' { LPAREN } + | ')' { RPAREN } + | '^' { POW } + + | letters+ as _1 { LETTERS _1} + + | '\000' { EOF } + | eof { EOF } + +and read_string buf = parse + | '"' { STR (Buffer.contents buf) } + | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } + | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } + | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } + | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } + | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } + | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } + | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } + | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf } + | [^ '"' '\\' '\000']+ + { Buffer.add_string buf (Lexing.lexeme lexbuf); + read_string buf lexbuf + } + | '\000' { STR (Buffer.contents buf) } + | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } + | eof { STR ( Buffer.contents buf) } + +and quoteless_string buf = parse + | '\\' '/' { Buffer.add_char buf '/'; quoteless_string buf lexbuf } + | '\\' '\\' { Buffer.add_char buf '\\'; quoteless_string buf lexbuf } + | '\\' 'b' { Buffer.add_char buf '\b'; quoteless_string buf lexbuf } + | '\\' 'f' { Buffer.add_char buf '\012'; quoteless_string buf lexbuf } + | '\\' 'n' { Buffer.add_char buf '\n'; quoteless_string buf lexbuf } + | '\\' 'r' { Buffer.add_char buf '\r'; quoteless_string buf lexbuf } + | '\\' 't' { Buffer.add_char buf '\t'; quoteless_string buf lexbuf } + | '\\' '"' { Buffer.add_char buf '"'; quoteless_string buf lexbuf } + | [^ '\\' '\000']+ + { Buffer.add_string buf (Lexing.lexeme lexbuf); + quoteless_string buf lexbuf + } + | '\000' { STR (Buffer.contents buf) } + | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } + | eof { STR (Buffer.contents buf) } + diff --git a/src/expressionParser.mly b/src/expressionParser.mly new file mode 100755 index 0000000..b7f77ae --- /dev/null +++ b/src/expressionParser.mly @@ -0,0 +1,113 @@ +%{ + open ScTypes + module F = Functions + + let u = UTF8.from_utf8string + + let extractColumnNameFromNum (fixed, (str, value)) = (fixed, value) + +%} + +%token REAL +%token NUM +%token STR + +%token LETTERS + +%token DOLLAR + +%token LPAREN +%token RPAREN +%token PLUS +%token TIMES +%token DIVIDE +%token MINUS +%token EQ NEQ +%token LT LE GT GE +%token EOF +%token SEMICOLON +%token COLON +%token POW + +%nonassoc EQ NEQ LT LE GT GE +%left PLUS MINUS +%left TIMES DIVIDE +%left POW + +%start value +%start content + +%% + +value: + | EQ expr EOF {$2} + +content: + | basic EOF {$1} + +basic: + | PLUS num {Result (number $2)} + | MINUS num {Result (number (DataType.Num.neg $2))} + | num {Result (number $1)} + | NUM DIVIDE NUM DIVIDE NUM {Result ( + date ( + DataType.Date.get_julian_day + (int_of_string $1) + (int_of_string $3) + (int_of_string $5) + ))} + | NUM COLON NUM COLON NUM {Result ( + date ( + let nhour = DataType.Num.div (DataType.Num.of_int @@ int_of_string $1) (DataType.Num.of_int 24) + and nmin = DataType.Num.div (DataType.Num.of_int @@ int_of_string $3) (DataType.Num.of_int 1440) + and nsec = DataType.Num.div (DataType.Num.of_int @@ int_of_string $5) (DataType.Num.of_int 86400) + in DataType.Num.add (DataType.Num.add nhour nmin) nsec + ) + )} + +expr: + | num {Value (number ($1))} + | MINUS expr {Call (F.sub, [$2])} + | PLUS expr {Call (F.add, [$2])} + + | LETTERS ident LPAREN separated_list(SEMICOLON, expr) RPAREN { Call (u($1 ^ $2), $4) } + + + | cell {Ref (Cell $1)} + | cell COLON cell {Ref (Range ($1, $3))} + + + | LPAREN expr RPAREN {Expression $2} + | STR {Value (string (u $1))} + + (* Mathematical operators *) + | expr MINUS expr {Call (F.sub, [$1; $3])} + | expr DIVIDE expr {Call (F.div, [$1; $3])} + | expr TIMES expr {Call (F.mul, [$1; $3])} + | expr PLUS expr {Call (F.add, [$1; $3])} + | expr POW expr {Call (F.pow, [$1; $3])} + + (* Comparaison *) + | expr EQ expr {Call (F.eq, [$1; $3])} + | expr NEQ expr {Call (F.neq, [$1; $3])} + | expr LT expr {Call (F.lt, [$1; $3])} + | expr GT expr {Call (F.gt, [$1; $3])} + | expr LE expr {Call (F.le, [$1; $3])} + | expr GE expr {Call (F.ge, [$1; $3])} + +%inline cell: + | LETTERS NUM { Cell.from_string (false, $1) (false, int_of_string $2) } + | DOLLAR LETTERS NUM { Cell.from_string (true, $2) (false, int_of_string $3) } + | LETTERS DOLLAR NUM { Cell.from_string (false, $1) (true, int_of_string $3) } + | DOLLAR LETTERS DOLLAR NUM { Cell.from_string (true, $2) (true, int_of_string $4) } + +num: + | REAL {DataType.Num.of_float @@ float_of_string $1} + | NUM {DataType.Num.of_int @@ int_of_string $1} + +ident: + | text* { String.concat "" $1 } + +text: + | LETTERS { $1 } + | NUM { $1 } diff --git a/src/functions.ml b/src/functions.ml new file mode 100755 index 0000000..56d7530 --- /dev/null +++ b/src/functions.ml @@ -0,0 +1,14 @@ +let u = UTF8.from_utf8string + +let eq = u"=" +let neq = u"<>" +let lt = u"<" +let le = u"<=" +let gt = u">" +let ge = u">=" + +let add = u"+" +let mul = u"*" +let pow = u"^" +let div = u"/" +let sub = u"-" diff --git a/src/main.ml b/src/main.ml new file mode 100755 index 0000000..3b83e85 --- /dev/null +++ b/src/main.ml @@ -0,0 +1,241 @@ +let u = UTF8.from_utf8string + +let redraw t screen = + let screen' = + Screen.draw t screen + |> Screen.draw_input t in + t, screen' + +let action f msg (t, screen) = begin + let t', count = f t in + let t', screen' = redraw t' screen in + Screen.status screen' @@ UTF8.from_utf8string (Printf.sprintf msg count); + t', screen' +end + +let f screen = ActionParser.( + begin match Screen.read_key screen with + | "\027" -> ESC + | "\001\002" -> DOWN + | "\001\003" -> UP + | "\001\004" -> LEFT + | "\001\005" -> RIGHT + | "\001\006" -> HOME + | "\001\104" -> END + + | "\001R" -> NPAGE + | "\001S" -> PPAGE + + (* See http://www.ibb.net/~anne/keyboard.html for thoses keycode. *) + | "\001\074"|"\127" -> DELETE + + | "e" -> E + | "u" -> U + | "v" -> V + | "y" -> Y + | "p" -> P + | "=" -> EQUAL + | "/" -> SEARCH + | ":" -> COMMAND + + | "\001\154" -> RESIZE + | "\001\153" -> + begin match Tools.NCurses.get_mouse_event () with + | None -> raise Not_found + | Some (id, ev, (x, y, z)) -> + if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_CLICKED ev then + BUTTON1_CLICKED(x, y) + else if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_PRESSED ev then + BUTTON1_CLICKED(x, y) + else if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_RELEASED ev then + BUTTON1_RELEASED(x, y) + else + raise Not_found + end + | _ -> raise Not_found +end) + +let parser screen = begin + let get_value () = f screen, Lexing.dummy_pos, Lexing.dummy_pos in + MenhirLib.Convert.Simplified.traditional2revised ActionParser.normal get_value +end + +let rec normal_mode (t, screen) = begin + match (parser screen) with + | exception x -> normal_mode (t, screen) + + | Actions.Visual -> + Screen.status screen @@ u"-- Selection --"; + selection_mode (t, screen) + + | Actions.Move direction -> + begin match Sheet.move direction t with + | Some t' -> normal_mode @@ redraw t' screen + | None -> normal_mode (t, screen) + end + + | Actions.Resize -> normal_mode (t, Screen.resize t screen) + + | Actions.Delete -> + let yank_before_delete = fun x -> Sheet.delete (fst (Sheet.yank x)) in + normal_mode @@ action yank_before_delete "Deleted %d cells" (t, screen) + + | Actions.Yank -> + normal_mode @@ action Sheet.yank "Yanked %d cells" (t, screen) + + | Actions.Paste -> + normal_mode @@ action Sheet.paste "Pasted %d cells" (t, screen) + + | Actions.Undo -> + begin match Sheet.undo t with + | Some t' -> normal_mode @@ redraw t' screen + | None -> normal_mode (t, screen) + end + + (* Edit a content *) + | Actions.Edit -> + 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 ~prefix:(u"-> ") ~init:expr screen with + | None -> + (* Restore the previous value *) + Screen.status screen expr; + normal_mode (t, screen) + | Some content -> + let expr' = Expression.load content in + let _, t' = Sheet.add expr' t in + normal_mode @@ redraw t' screen + end + + (* Insert a new formula, the actual value will be erased *) + | Actions.InsertFormula -> + let position = Selection.extract t.Sheet.selected in + begin match Screen.editor ~position ~init:(u"=") screen with + | None -> + (* Restore the previous value *) + let expr = Sheet.Raw.get_expr position t.Sheet.data + |> Expression.show in + Screen.status screen expr; + normal_mode (t, screen) + | Some content -> + let expr = Expression.load content in + let _, t' = Sheet.add expr t in + normal_mode @@ redraw t' screen + end + + | Actions.Search -> + let expr = Screen.search screen + |> Expression.load in + let pattern = Expression.eval expr (fun _ -> ScTypes.Refs.Single None) in + begin match Sheet.search (`Pattern (Some pattern)) t with + | Some t' -> normal_mode @@ redraw t' screen + | None -> normal_mode (t, screen) + end + + | Actions.Button1_clicked coord -> + begin match Screen.get_cell screen coord with + | None -> normal_mode (t, screen) + | Some (x,y) -> begin match Sheet.move (Actions.Absolute (x,y)) t with + | Some t' -> normal_mode @@ redraw t' screen + | None -> normal_mode (t, screen) + end + end + + | Actions.Button1_released coord -> + begin match Screen.get_cell screen coord with + | Some (x,y) when (x,y) <> (Selection.extract t.Sheet.selected) -> + Screen.status screen @@ u"-- Selection -- "; + let t' = { t with + Sheet.selected = Selection.extends (Actions.Absolute (x,y)) t.Sheet.selected + } in + let screen' = Screen.draw t' screen in + selection_mode (t', screen') + | _ -> normal_mode (t, screen) + end + + | Actions.Command -> + begin match Screen.editor ~prefix:(u":") screen with + | None -> + normal_mode (t, screen) + | Some content -> + let args = try + UTF8.to_utf8string content + |> Tools.String.split ~by:' ' + with Not_found -> + (UTF8.to_utf8string content, "") in + command (t, screen) args + end + + | _ -> normal_mode (t, screen) + +end + +and selection_mode (t, screen) = begin + match (parser screen) with + | exception x -> selection_mode (t, screen) + + | Actions.Resize -> selection_mode (t, Screen.resize t screen) + + | Actions.Delete -> + let yank_before_delete = fun x -> Sheet.delete (fst (Sheet.yank x)) in + normal_mode @@ action yank_before_delete "Deleted %d cells" (t, screen) + + | Actions.Yank -> + normal_mode @@ action Sheet.yank "Yanked %d cells" (t, screen) + + | Actions.Escape -> + let t' = { t with Sheet.selected = Selection.create (Selection.extract t.Sheet.selected) } in + let screen' = Screen.draw t' screen + |> Screen.draw_input t' in + Screen.status screen UTF8.empty; + normal_mode (t', screen') + + | Actions.Move m -> + let t' = { t with Sheet.selected = Selection.extends m t.Sheet.selected } in + let screen' = Screen.draw t' screen in + selection_mode (t', screen') + + | Actions.Button1_clicked coord -> + begin match Screen.get_cell screen coord with + | None -> normal_mode (t, screen) + | Some (x,y) -> begin match Sheet.move (Actions.Absolute (x,y)) t with + | Some t' -> + Screen.status screen UTF8.empty; + normal_mode @@ redraw t' screen + | None -> normal_mode (t, screen) + end + end + + | _ -> selection_mode (t, screen) +end + +and command (t, screen) action = begin + match action with + | ("w", file) -> (* Save the file *) + Odf.save t.Sheet.data file; + normal_mode @@ redraw t screen + | ("repr", file) -> (* Save the file *) + let out_gv = open_out_bin file in + let form = Format.formatter_of_out_channel out_gv in + Evaluator.repr form (Evaluator.get_catalog ()); + close_out out_gv; + normal_mode @@ redraw t screen + | ("enew", _) -> (* Start a new spreadsheet *) + normal_mode @@ redraw (Sheet.create Sheet.Raw.empty) screen + | ("q", _) -> (* Quit *) + t + | _ -> normal_mode @@ redraw t screen +end + +let () = begin + + let sheet = + if Array.length Sys.argv = 1 then + Sheet.Raw.empty + else + Odf.load Sys.argv.(1) in + + Screen.run (fun window -> + ignore @@ normal_mode @@ redraw (Sheet.create sheet) window) +end diff --git a/src/odf/odf.ml b/src/odf/odf.ml new file mode 100755 index 0000000..ae120d9 --- /dev/null +++ b/src/odf/odf.ml @@ -0,0 +1,346 @@ +module Xml = Ezxmlm +module T = Tools +module NS = Odf_ns + +let u = UTF8.from_utf8string + +type t + +(** Map for storing all the attributes *) +module AttributesMap = Map.Make (struct + type t = string * string + let compare = Pervasives.compare +end) + +let get_attr map key = begin + try Some (AttributesMap.find key map) with + Not_found -> None +end + +let load_formula formula = + let lineBuffer = Lexing.from_string formula in + try + Expression.Formula ( + Expression.Expression ( + Odf_ExpressionParser.value Odf_ExpressionLexer.read lineBuffer)) + with e -> + print_endline formula; + raise e + + +let load_content content = begin function + | "float" -> Expression.Basic ( + ScTypes.number ( + DataType.Num.of_float (float_of_string content) + )) + | "date" -> Expression.Basic ( + ScTypes.date ( + DataType.Num.of_float (float_of_string content) + )) + | _ -> Expression.Basic ( + ScTypes.string ( + UTF8.from_utf8string content)) +end + +(** Load the content from a cell *) +let load_cell sheet cell_num row_num changed (attrs, cell) = begin + + (* Load all the attributes from the xml element *) + let add_attr map (key, value) = AttributesMap.add key value map in + let attributes = List.fold_left add_attr AttributesMap.empty attrs in + + (* Check if the content is repeated *) + let repetition = match get_attr attributes NS.number_columns_repeat_attr with + | None -> 1 + | Some x -> int_of_string x + + (* cell width *) + and cell_width = match get_attr attributes NS.number_columns_spanned_attr with + | None -> 1 + | Some x -> int_of_string x in + + let vtype = + try List.assoc NS.ovalue_type_attr attrs + with Not_found -> "" in + + let formula = get_attr attributes NS.formula_attr + and value = get_attr attributes NS.value_attr in + + let expression, update = begin match formula, value with + | Some x, _ -> load_formula x, true + | _, Some x -> + (load_content x vtype) , true + | _ -> + begin try + Xml.member "p" cell + |> Xml.data_to_string + |> fun x -> (load_content x vtype, true) + with Xml.Tag_not_found _ -> Expression.Undefined, false + end + end in + + if update then ( + for i = 1 to repetition do + cell_num := !cell_num + cell_width; + sheet := snd @@ Sheet.Raw.add (!cell_num, !row_num) (Expression.load_expr expression) !sheet + done + ) else ( + cell_num := !cell_num + (repetition * cell_width ) + ); + changed || update +end + +let load_row sheet row_num (attrs, row) = begin + + let repetition = + try int_of_string @@ List.assoc (NS.table, "number-rows-repeated") attrs + with Not_found -> 1 in + + let cells = Xml.members_with_attr "table-cell" row in + + try + for i = 1 to repetition do + incr row_num; + let cell_num = ref 0 in + if not (List.fold_left (load_cell sheet cell_num row_num) false cells) then + (* No changes on the whole row. Do not repeat, and break the loop *) + raise Not_found + done + with Not_found -> row_num := !row_num + repetition - 1 +end + +let load_xml input = begin + + let sheet = ref Sheet.Raw.empty in + let row_num = ref 0 in + + let xml = + Xmlm.make_input ~enc:(Some `UTF_8) (`Channel input) + |> Xml.from_input + |> snd in + let rows = Xml.member "document-content" (xml::[]) + |> Xml.member "body" + |> Xml.member "spreadsheet" + |> Xml.member "table" + |> Xml.members_with_attr "table-row" in + List.iter (fun x -> (load_row sheet row_num) x) rows; + !sheet +end + + +let load file = + let tmp_file = Filename.temp_file "content" ".xml" in + Unix.unlink tmp_file; + + let zip = Zip.open_in file in + let content = Zip.find_entry zip "content.xml" in + Zip.copy_entry_to_file zip content tmp_file; + + let input = open_in_bin tmp_file in + Tools.try_finally + (fun () -> load_xml input) + (fun () -> + close_in input; + Unix.unlink tmp_file; + Zip.close_in zip + ) + + +let write_type ovalue_type cvalue_type attrs output value = begin + let attrs = + (NS.ovalue_type_attr, ovalue_type):: + (NS.cvalue_type_attr, cvalue_type):: + attrs in + + Xmlm.output output (`El_start (NS.table_cell_node, attrs)); + Xmlm.output output (`El_start (NS.text_node, [])); + Xmlm.output output (`Data value); + Xmlm.output output `El_end; + Xmlm.output output `El_end; +end + +(* Writers for differents types *) +let write_num = write_type "float" "float" +let write_str = write_type "string" "string" +let write_bool = write_type "bool" "bool" +let write_error = write_type "string" "error" +let write_date = write_type "date" "date" + +let write_basic: type a. 'b list -> Xmlm.output -> a ScTypes.types -> unit = fun attrs output types -> begin match types with + | ScTypes.Str s -> write_str attrs output (UTF8.to_utf8string s) + | ScTypes.Bool b -> write_bool attrs output (string_of_bool b) + | ScTypes.Num (data_type, d) -> + begin match ScTypes.get_numeric_type data_type with + | ScTypes.Number -> + let f = DataType.Num.to_float d in + let value = string_of_float f in + write_num ((NS.value_attr, value)::attrs) output value + | ScTypes.Date -> + let value = DataType.Date.to_string d in + write_date ((NS.date_value_attr, value)::attrs) output value + end +end + +let write_formula output attrs f = begin function + | ScTypes.Result x -> write_basic attrs output x + | ScTypes.Error exn -> write_str attrs output "#NAME?" +end + +let print_ref buffer c = + UTF8.Buffer.add_string buffer @@ u"[."; + begin match c with + | ScTypes.Cell c -> UTF8.Buffer.add_string buffer @@ Cell.to_string c; + | ScTypes.Range (c1, c2) -> + UTF8.Buffer.add_string buffer @@ Cell.to_string c1; + UTF8.Buffer.add_string buffer @@ u":."; + UTF8.Buffer.add_string buffer @@ Cell.to_string c2; + end; + UTF8.Buffer.add_string buffer @@ u"]" + +let rec print_expr : UTF8.Buffer.buffer -> ScTypes.expression -> unit = fun buffer -> begin function + | ScTypes.Value (ScTypes.Str s) -> + UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string s) + | ScTypes.Value (ScTypes.Bool b) -> + u(string_of_bool b) + |> UTF8.Buffer.add_string buffer + | ScTypes.Value (ScTypes.Num (data_type, d)) -> + begin match ScTypes.get_numeric_type data_type with + | ScTypes.Number -> + let f = DataType.Num.to_float d in + UTF8.Buffer.add_string buffer @@ u(string_of_float f) + | ScTypes.Date -> + DataType.Date.to_string d + |> u + |> UTF8.Buffer.add_string buffer + end + | ScTypes.Ref r -> print_ref buffer r + | ScTypes.Expression x -> + UTF8.Buffer.add_char buffer '('; + print_expr buffer x; + UTF8.Buffer.add_char buffer ')'; + | ScTypes.Call (ident, params) -> + begin match (UTF8.to_utf8string ident) with + | "+" | "*" | "-" | "/" | "^" | "=" + | "<>" | "<=" | ">=" | "<" | ">" -> begin match params with + | v1::[] -> + UTF8.Printf.bprintf buffer "%s%a" + (UTF8.to_utf8string ident) + print_expr v1 + | v1::v2::[] -> + UTF8.Printf.bprintf buffer "%a%s%a" + print_expr v1 + (UTF8.to_utf8string ident) + print_expr v2 + | _ -> + UTF8.Buffer.add_string buffer ident; + Tools.List.printb ~sep:(u";") print_expr buffer params + end + | _ -> + UTF8.Buffer.add_string buffer ident; + Tools.List.printb ~sep:(u";") print_expr buffer params + end +end + +let write_cell output value = begin function + | Expression.Undefined -> () + | Expression.Basic b -> write_basic [] output b + | Expression.Formula (Expression.Expression f) -> + let buffer = UTF8.Buffer.create 10 in + print_expr buffer f; + let formula = UTF8.Buffer.contents buffer + |> UTF8.to_utf8string in + write_formula output [(NS.formula_attr, ("of:=" ^formula))] f value + | Expression.Formula (Expression.Error (i, s)) -> + write_error [(NS.formula_attr, ("of:" ^ (UTF8.to_utf8string s)))] output (UTF8.to_utf8string s) +end + +(** Jump to the wanted position *) +let goto output (from_x, from_y) (to_x, to_y) :unit = begin + + (** Insert as many rows than required *) + let insert_rows count = begin + (* Close the previous openend rows *) + Xmlm.output output `El_end; + + if (count > 1) then ( + Xmlm.output output ( + `El_start ( + NS.table_row_node, [(NS.table_row_repeat_attr, string_of_int (count-1))])); + Xmlm.output output (`El_start (NS.table_cell_node, [])); + Xmlm.output output `El_end; + Xmlm.output output `El_end; + ); + Xmlm.output output (`El_start (NS.table_row_node, [])); + 1 + end + + (** Insert as many cells as required *) + and insert_cells count = begin + Xmlm.output output ( + `El_start ( + NS.table_cell_node, [(NS.number_columns_repeat_attr, string_of_int count)])); + Xmlm.output output `El_end; + end in + + (* Insert empty rows or columns until the desired position *) + let jump_row = to_y - from_y in + let from_x' = + if jump_row > 0 then + insert_rows jump_row + else + from_x in + let jump_cell = to_x - from_x' in + if jump_cell > 0 then + insert_cells jump_cell +end + +(** Write the cell content and return the updated position *) +let f output cursor position (expr, value) = begin + + goto output cursor position; + + (* Write the value *) + write_cell output value expr; + + (* Return the update position *) + Tools.Tuple2.map1 ((+) 1) position +end + +let save sheet file = begin + let tmp_file = Filename.temp_file "content" ".xml" in + Unix.unlink tmp_file; + let out_channel = open_out_bin tmp_file in + let zip = Zip.open_out file in + + let manifest = "\ +\ +\ + +" in + + Tools.try_finally (fun () -> + + let output = Xmlm.make_output (`Channel out_channel) in + Xmlm.output output (`Dtd None); + Xmlm.output output (`El_start (NS.document_content_node, NS.name_spaces())); + Xmlm.output output (`El_start (NS.body_node, [])); + Xmlm.output output (`El_start (NS.spreadsheet_node, [])); + Xmlm.output output (`El_start (NS.table_node, [])); + + Xmlm.output output (`El_start (NS.table_row_node, [])); + ignore (Sheet.Raw.fold (f output) (1,1) sheet); + Xmlm.output output `El_end; + + Xmlm.output output `El_end; + Xmlm.output output `El_end; + Xmlm.output output `El_end; + Xmlm.output output `El_end; + + close_out out_channel; + Zip.copy_file_to_entry tmp_file zip "content.xml"; + Zip.add_entry manifest zip "META-INF/manifest.xml" + ) (fun () -> + Zip.close_out zip; + Unix.unlink tmp_file + ) +end diff --git a/src/odf/odf_ExpressionLexer.mll b/src/odf/odf_ExpressionLexer.mll new file mode 100755 index 0000000..7f6a55b --- /dev/null +++ b/src/odf/odf_ExpressionLexer.mll @@ -0,0 +1,93 @@ +{ + open Odf_ExpressionParser + open Lexing + + exception SyntaxError of string +} + +let digit = ['0'-'9'] +let real = digit+ | digit* '.' digit+ | digit+ '.' digit* + + +let newline = "\r\n" | '\n' | '\r' +let space = ['\t' ' '] | newline + +let letters = ['A'-'Z' 'a'-'z'] + +(* Function identifier. + Valid identifiers are : + ORG.OPENOFFICE.DAYSINMONTH + it cannot end with a digit. + *) +let identifier = letters (letters | digit | ['-' '_' '.'])* letters+ + +let cell = letters+ digit+ + +rule read = parse + | space+ { read lexbuf } + + | digit+ as _1 { NUM _1} + | real as _1 { REAL (Tools.String.filter_float _1)} + | '$' { DOLLAR } + + | '=' { EQ } + | "<>" { NEQ } + | '<' { LT } + | "<=" { LE } + | '>' { GT } + | ">=" { GE } + | '*' { TIMES } + | '+' { PLUS } + | '-' { MINUS } + | '/' { DIVIDE } + | '"' { read_string (Buffer.create 16) lexbuf } + | ';' { SEMICOLON } + | ':' { COLON } + | '[' { L_SQ_BRACKET } + | ']' { R_SQ_BRACKET } + | '(' { LPAREN } + | ')' { RPAREN } + | '^' { POW } + | '.' { DOT } + + | letters+ as _1 { LETTERS _1} + | identifier as _1 { IDENT _1} + + | '\000' { EOF } + | eof { EOF } + +and read_string buf = parse + | '"' { STR (Buffer.contents buf) } + | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } + | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } + | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } + | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } + | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } + | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } + | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } + | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf } + | [^ '"' '\\' '\000']+ + { Buffer.add_string buf (Lexing.lexeme lexbuf); + read_string buf lexbuf + } + | '\000' { STR (Buffer.contents buf) } + | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } + | eof { STR ( Buffer.contents buf) } + +and quoteless_string buf = parse + | '\\' '/' { Buffer.add_char buf '/'; quoteless_string buf lexbuf } + | '\\' '\\' { Buffer.add_char buf '\\'; quoteless_string buf lexbuf } + | '\\' 'b' { Buffer.add_char buf '\b'; quoteless_string buf lexbuf } + | '\\' 'f' { Buffer.add_char buf '\012'; quoteless_string buf lexbuf } + | '\\' 'n' { Buffer.add_char buf '\n'; quoteless_string buf lexbuf } + | '\\' 'r' { Buffer.add_char buf '\r'; quoteless_string buf lexbuf } + | '\\' 't' { Buffer.add_char buf '\t'; quoteless_string buf lexbuf } + | '\\' '"' { Buffer.add_char buf '"'; quoteless_string buf lexbuf } + | [^ '\\' '\000']+ + { Buffer.add_string buf (Lexing.lexeme lexbuf); + quoteless_string buf lexbuf + } + | '\000' { STR (Buffer.contents buf) } + | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } + | eof { STR (Buffer.contents buf) } + diff --git a/src/odf/odf_ExpressionParser.mly b/src/odf/odf_ExpressionParser.mly new file mode 100755 index 0000000..6b571a9 --- /dev/null +++ b/src/odf/odf_ExpressionParser.mly @@ -0,0 +1,95 @@ +%{ + open ScTypes + module F = Functions + + let u = UTF8.from_utf8string + + let extractColumnNameFromNum (fixed, str) = (fixed, int_of_string str) + +%} + +%token REAL +%token NUM +%token STR + +%token LETTERS +%token IDENT + +%token DOLLAR +%token DOT + +%token LPAREN RPAREN +%token L_SQ_BRACKET R_SQ_BRACKET +%token PLUS +%token TIMES +%token DIVIDE +%token MINUS +%token EQ NEQ +%token LT LE GT GE +%token EOF +%token COLON SEMICOLON +%token POW + +%nonassoc EQ NEQ LT LE GT GE +%left PLUS MINUS +%left TIMES DIVIDE +%left POW + +%start value + +%% + +value: + | LETTERS COLON EQ expr EOF {$4} + +expr: + | num {Value (number ($1))} + | MINUS expr {Call (F.sub, [$2])} + | PLUS expr {Call (F.add, [$2])} + + + | L_SQ_BRACKET ref R_SQ_BRACKET {$2} + + | LPAREN expr RPAREN {Expression $2} + | STR {Value (string (u $1))} + + (* Mathematical operators *) + | expr MINUS expr {Call (F.sub, [$1; $3])} + | expr DIVIDE expr {Call (F.div, [$1; $3])} + | expr TIMES expr {Call (F.mul, [$1; $3])} + | expr PLUS expr {Call (F.add, [$1; $3])} + | expr POW expr {Call (F.pow, [$1; $3])} + + (* Comparaison *) + | expr EQ expr {Call (F.eq, [$1; $3])} + | expr NEQ expr {Call (F.neq, [$1; $3])} + | expr LT expr {Call (F.lt, [$1; $3])} + | expr GT expr {Call (F.gt, [$1; $3])} + | expr LE expr {Call (F.le, [$1; $3])} + | expr GE expr {Call (F.ge, [$1; $3])} + + | ident LPAREN separated_list(SEMICOLON, expr) RPAREN { Call (u $1, $3) } + + +ref: + | cell {Ref (Cell $1)} + | cell COLON cell {Ref (Range ($1, $3))} + +cell: + | DOT fixed(LETTERS) fixed(NUM){Cell.from_string $2 (extractColumnNameFromNum $3)} + +fixed(X): + | DOLLAR X {true, $2} + | X {false, $1} + +num: + | REAL {DataType.Num.of_float @@ float_of_string $1} + | NUM {DataType.Num.of_int @@ int_of_string $1} + +ident: + | IDENT { $1 } + | text+ { String.concat "" $1 } + +text: + | LETTERS { $1 } + | NUM { $1 } diff --git a/src/odf/odf_ns.ml b/src/odf/odf_ns.ml new file mode 100755 index 0000000..5a501da --- /dev/null +++ b/src/odf/odf_ns.ml @@ -0,0 +1,96 @@ +let ooo = "http://openoffice.org/2004/office" +let ooow = "http://openoffice.org/2004/writer" +let oooc = "http://openoffice.org/2004/calc" +let rpt = "http://openoffice.org/2005/report" +let tableooo = "http://openoffice.org/2009/table" +let drawooo = "http://openoffice.org/2010/draw" + +let dc = "http://purl.org/dc/elements/1.1/" + +let xhtml = "http://www.w3.org/1999/xhtml" +let grddl = "http://www.w3.org/2003/g/data-view#" +let css3t = "http://www.w3.org/TR/css3-text/" +let xlink = "http://www.w3.org/1999/xlink" +let dom = "http://www.w3.org/2001/xml-events" +let xforms = "http://www.w3.org/2002/xforms" +let xsd = "http://www.w3.org/2001/XMLSchema" +let xsi = "http://www.w3.org/2001/XMLSchema-instance" +let math = "http://www.w3.org/1998/Math/MathML" + +let office = "urn:oasis:names:tc:opendocument:xmlns:office:1.0" +let style = "urn:oasis:names:tc:opendocument:xmlns:style:1.0" +let text = "urn:oasis:names:tc:opendocument:xmlns:text:1.0" +let table = "urn:oasis:names:tc:opendocument:xmlns:table:1.0" +let draw = "urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" +let fo = "urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" +let meta = "urn:oasis:names:tc:opendocument:xmlns:meta:1.0" +let number = "urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" +let presentation= "urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" +let svg = "urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" +let chart = "urn:oasis:names:tc:opendocument:xmlns:chart:1.0" +let dr3d = "urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" +let form = "urn:oasis:names:tc:opendocument:xmlns:form:1.0" +let script = "urn:oasis:names:tc:opendocument:xmlns:script:1.0" +let oof = "urn:oasis:names:tc:opendocument:xmlns:of:1.2" + +let calcext = "urn:org:documentfoundation:names:experimental:calc:xmlns:calcext:1.0" +let loext = "urn:org:documentfoundation:names:experimental:office:xmlns:loext:1.0" + +let field = "urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0" +let formx = "urn:openoffice:names:experimental:ooxml-odf-interop:xmlns:form:1.0" + +let document_content_node = (office, "document-content") +let body_node = (office, "body") +let spreadsheet_node = (office, "spreadsheet") +let table_node = (table, "table") +let table_row_node = (table, "table-row") + let table_row_repeat_attr = (table, "number-rows-repeated") + +let table_cell_node = (table, "table-cell") + let number_columns_repeat_attr = (table, "number-columns-repeated") + let cvalue_type_attr = (calcext, "value-type") + let ovalue_type_attr = (office, "value-type") + let value_attr = (office, "value") + let formula_attr = (table, "formula") + let date_value_attr = (office, "date-value") + let number_columns_spanned_attr = (table, "number-columns-spanned") + +let text_node = (text, "p") + +let name_spaces () = [ + (Xmlm.ns_xmlns, "office"), office; + (Xmlm.ns_xmlns, "style"), style; + (Xmlm.ns_xmlns, "text"), text; + (Xmlm.ns_xmlns, "table"), table; + (Xmlm.ns_xmlns, "draw"), draw; + (Xmlm.ns_xmlns, "fo"), fo; + (Xmlm.ns_xmlns, "xlink"), xlink; + (Xmlm.ns_xmlns, "dc"), dc; + (Xmlm.ns_xmlns, "meta"), meta; + (Xmlm.ns_xmlns, "number"), number; + (Xmlm.ns_xmlns, "presentation"),presentation; + (Xmlm.ns_xmlns, "svg"), svg; + (Xmlm.ns_xmlns, "chart"), chart; + (Xmlm.ns_xmlns, "dr3d"), dr3d; + (Xmlm.ns_xmlns, "math"), math; + (Xmlm.ns_xmlns, "form"), form; + (Xmlm.ns_xmlns, "script"), script; + (Xmlm.ns_xmlns, "ooo"), ooo; + (Xmlm.ns_xmlns, "ooow"), ooow; + (Xmlm.ns_xmlns, "oooc"), oooc; + (Xmlm.ns_xmlns, "dom"), dom; + (Xmlm.ns_xmlns, "xforms"), xforms; + (Xmlm.ns_xmlns, "xsd"), xsd; + (Xmlm.ns_xmlns, "xsi"), xsi; + (Xmlm.ns_xmlns, "rpt"), rpt; + (Xmlm.ns_xmlns, "of"), oof; + (Xmlm.ns_xmlns, "xhtml"), xhtml; + (Xmlm.ns_xmlns, "grddl"), grddl; + (Xmlm.ns_xmlns, "tableooo"), tableooo; + (Xmlm.ns_xmlns, "drawooo"), drawooo; + (Xmlm.ns_xmlns, "calcext"), calcext; + (Xmlm.ns_xmlns, "loext"), loext; + (Xmlm.ns_xmlns, "field"), field; + (Xmlm.ns_xmlns, "formx"), formx; + (Xmlm.ns_xmlns, "css3t"), css3t; +] diff --git a/src/scTypes.ml b/src/scTypes.ml new file mode 100755 index 0000000..48e4d3c --- /dev/null +++ b/src/scTypes.ml @@ -0,0 +1,354 @@ +(** All the types used in the spreadsheet. *) + +let u = UTF8.from_utf8string + +exception Error + +type cell = Cell.t + +type ident = UTF8.t + +type _ dataFormat = + | Date: DataType.Num.t dataFormat (* Date *) + | Number: DataType.Num.t dataFormat (* Number *) + | String: DataType.String.t dataFormat(* String *) + | Bool: DataType.Bool.t dataFormat (* Boolean *) + +type numericType = + | Date + | Number + +let get_numeric_type: DataType.Num.t dataFormat -> numericType = function + | Date -> Date + | Number -> Number + +type 'a types = + | Num : DataType.Num.t dataFormat * DataType.Num.t -> DataType.Num.t types (** A number *) + | Str : DataType.String.t -> DataType.String.t types (** A string *) + | Bool : DataType.Bool.t -> DataType.Bool.t types (** A boolean *) + +let number n = Num (Number, n) +let string s = Str s +let date d = Num (Date, d) +let boolean b = Bool b + + +type 'a returnType = + | Num : DataType.Num.t dataFormat option -> DataType.Num.t returnType (** A number *) + | Str : DataType.String.t returnType (** A string *) + | Bool : DataType.Bool.t returnType (** A boolean *) + + +let f_num: DataType.Num.t returnType = Num None +let f_date: DataType.Num.t returnType = Num (Some Date) +let f_number: DataType.Num.t returnType = Num (Some Number) +let f_string: DataType.String.t returnType = Str +let f_bool: DataType.Bool.t returnType = Bool + +type refs = + | Cell of cell (** A cell *) + | Range of cell * cell (** An area of cells *) + +type expression = + | Value : 'a types -> expression (** A direct value *) + | Ref : refs -> expression (** A reference to another cell *) + | Call : ident * expression list -> expression (** A call to a function *) + | Expression : expression -> expression (** An expression *) + +(** Result from a computation *) +type result = + | Result : 'a types -> result + | Error : exn -> result + +module DataFormat = struct + + type formats = F : 'a dataFormat -> formats [@@unboxed] + + let priority: type a. a dataFormat -> int = function + | Date -> 1 + | Number -> 0 + | String -> 0 + | Bool -> 0 + + let collect_format: DataType.Num.t dataFormat -> formats -> DataType.Num.t dataFormat = begin + fun dataFormat -> function + | F Date -> Date + | _ -> dataFormat + end + + let guess_format_result: type a. a returnType -> (unit -> formats list) -> a dataFormat = + fun return params -> begin match return with + | Str -> String + | Bool -> Bool + | Num (Some x) -> x + | Num None -> List.fold_left collect_format Number (params ()) + end + + let default_value_for: type a. a dataFormat -> a = function + | Date -> DataType.Num.zero + | Number -> DataType.Num.zero + | Bool -> false + | String -> UTF8.empty + + type ('a, 'b) equality = Eq : ('a, 'a) equality + + let compare_format: type a b. a dataFormat -> b dataFormat -> (a, b) equality = + fun a b -> begin match a, b with + | Date, Date -> Eq + | String, String -> Eq + | Number, Number -> Eq + | Date, Number -> Eq + | Number, Date -> Eq + | Bool, Bool -> Eq + | _, _ -> raise Errors.TypeError + end + +end + +module Type = struct + + let (=) : type a b. a types -> b types -> bool = fun t1 t2 -> + match t1, t2 with + | Num (_, n1), Num (_, n2) -> DataType.Num.eq n1 n2 + | Bool b1, Bool b2 -> b1 = b2 + | Str s1, Str s2 -> s1 = s2 + | _, _ -> false + + (** Show a list of elements + *) + let rec show_list printer buffer = begin function + | [] -> () + | hd::[] -> + UTF8.Printf.bprintf buffer "%a" + printer hd + | hd::tl -> + UTF8.Printf.bprintf buffer "%a, " + printer hd; + show_list printer buffer tl + end + + let show: type a. UTF8.Buffer.buffer -> a types -> unit = fun buffer -> begin function + | Str x -> UTF8.Buffer.add_string buffer x + | Bool b -> UTF8.Printf.bprintf buffer "%B" b + | Num (Number, n) -> + if DataType.Num.is_integer n then + DataType.Num.to_int n + |> string_of_int + |> UTF8.from_utf8string + |> UTF8.Buffer.add_string buffer + else + let f = DataType.Num.to_float n + and to_b = UTF8.Format.formatter_of_buffer buffer in + ignore @@ UTF8.Format.fprintf to_b "%.2f" f; + Format.pp_print_flush to_b () + | Num (Date, n) -> + let y, m, d = DataType.Date.date_from_julian_day n in + UTF8.Printf.bprintf buffer "%d/%d/%d" y m d + end + + let show_full: type a. UTF8.Buffer.buffer -> a types -> unit = fun buffer -> begin function + | Str x -> UTF8.Buffer.add_string buffer x + | Bool b -> UTF8.Printf.bprintf buffer "%B" b + | Num (Number, n) -> + if DataType.Num.is_integer n then + DataType.Num.to_int n + |> string_of_int + |> UTF8.from_utf8string + |> UTF8.Buffer.add_string buffer + else + let f = DataType.Num.to_float n + and to_b = UTF8.Format.formatter_of_buffer buffer in + ignore @@ UTF8.Format.fprintf to_b "%f" f; + Format.pp_print_flush to_b () + | Num (Date, n) -> + let y, m, d = DataType.Date.date_from_julian_day n in + UTF8.Printf.bprintf buffer "%d/%d/%d" y m d + end + + type t = + | Value: 'a dataFormat * 'a -> t + + let get_content : type a. a types -> t = begin function + | Num (format, data) -> Value (format, data) + | Str s -> Value (String, s) + | Bool b -> Value (Bool, b) + end + +end + +module Refs = struct + + type 'a range = + | Single of 'a + | Array1 of 'a list + | Array2 of 'a list list + + let collect = function + | Cell x -> Single (Pervasives.fst x) + | Range (fst, snd) -> + let (x1, y1) = Pervasives.fst fst + and (x2, y2) = Pervasives.fst snd in + let min_x = min x1 x2 + and max_x = max x1 x2 + and min_y = min y1 y2 + and max_y = max y1 y2 in + if (min_x = max_x) || (min_y = max_y) then ( + (* There is only a one dimension array *) + let elms = ref [] in + for x = min_x to max_x do + for y = min_y to max_y do + elms := (x, y)::!elms + done + done; + Array1 (!elms) + ) else ( + (* This a two-dimension array *) + let elmx = ref [] in + for x = min_x to max_x do + let elmy = ref [] in + for y = min_y to max_y do + elmy := (x, y)::!elmy + done; + elmx := !elmy::!elmx + done; + Array2 (!elmx) + ) + + let map f = function + | Single coord -> Single (f coord) + | Array1 values -> Array1 (List.map f values) + | Array2 values -> Array2 (List.map (List.map f) values) + + let shift (vector_x, vector_y) ref = + let _shift ((x, y), (fixed_x, fixed_y)) = + let x' = if fixed_x then x else x + vector_x + and y' = if fixed_y then y else y + vector_y in + (x', y'), (fixed_x, fixed_y) + in match ref with + | Cell x -> Cell (_shift x) + | Range (fst, snd) -> Range (_shift fst, _shift snd) + + let show buffer = begin function + | Cell r -> UTF8.Buffer.add_string buffer @@ Cell.to_string r + | Range (f,t) -> + Tools.Tuple2.printb ~first:"" ~last:"" ~sep:":" Cell.to_buffer Cell.to_buffer buffer (f,t) + end + + type 'a content = + | Value: 'a dataFormat * 'a -> 'a content + | List: 'a dataFormat * 'a list -> 'a list content + | Matrix: 'a dataFormat * 'a list list -> 'a list list content + + type refContent = + | C: 'a content -> refContent [@@unboxed] + + (** Add one element in a typed list. + + The function will raise Error.TypeError if the elements does not match + with the list type. + *) + let add_elem: type a b. a dataFormat * a list -> result option -> a dataFormat * a list = + fun (format, elements) result -> + begin match result with + | None -> format, (DataFormat.default_value_for format)::elements + | Some (Error x) -> raise x + | Some (Result r) -> + let Type.Value (format', element) = Type.get_content r in + let DataFormat.Eq = DataFormat.compare_format format format' in + let new_format = if (DataFormat.priority format) > (DataFormat.priority format') then + format + else + format' in + new_format, element::elements + end + + let get_content = begin function + | Single None -> raise Errors.TypeError + | Single (Some (Error x)) -> raise x + | Single (Some (Result r)) -> + let Type.Value (format, c) = Type.get_content r in C (Value (format, c)) + | Array1 l -> + (* Get the first element in the list in order to get the format *) + let Type.Value (format, _) = + begin match (Tools.List.find_map (fun x -> x) l) with + | Error x -> raise x + | Result r -> Type.get_content r + end in + (* Then build an unified list (if we can) *) + let format, values = List.fold_left add_elem (format, []) l in + C (List(format, List.rev values)) + | Array2 l -> + (* Get the first element in the list *) + let Type.Value (format, _) = + begin match (Tools.List.find_map2 (fun x -> x) l) with + | Error x -> raise x + | Result r -> Type.get_content r + end in + (* Then build an unified list *) + let format, values = List.fold_left (fun (format, result) elems -> + let format, elems = List.fold_left add_elem (format, []) elems in + (format, List.rev (elems::result)) + )(format, []) l in + C (Matrix(format, List.rev values)) + end + +end + +module Result = struct + let (=) t1 t2 = + match t1, t2 with + | Result v1, Result v2 -> Type.(=) v1 v2 + | _, _ -> t1 = t2 + + let show = begin function + | 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; + UTF8.Buffer.contents buffer + end + +end + +(** Represent an expression. + *) +let rec show_expr buffer : expression -> unit = begin function + | Value (Str x) -> + (** Print the value with quotes *) + UTF8.Printf.bprintf buffer "\"%s\"" (UTF8.to_utf8string x) + | Value v -> Type.show buffer v + | Ref r -> Refs.show buffer r + | Call (ident, params) -> + let utf8ident = UTF8.to_utf8string ident in + begin match utf8ident with + | "+" | "*" | "-" | "/" | "^" | "=" + | "<>" | "<=" | ">=" | "<" | ">" -> begin match params with + | v1::[] -> + UTF8.Printf.bprintf buffer "%s%a" + utf8ident + show_expr v1 + | v1::v2::[] -> + UTF8.Printf.bprintf buffer "%a%s%a" + show_expr v1 + utf8ident + show_expr v2 + | _ -> + UTF8.Buffer.add_string buffer ident; + Tools.List.printb ~sep:(u";") show_expr buffer params + end + | _ -> + UTF8.Buffer.add_string buffer ident; + Tools.List.printb ~sep:(u";") show_expr buffer params + end + | Expression expr -> + UTF8.Printf.bprintf buffer "(%a)" show_expr expr +end + diff --git a/src/scTypes.mli b/src/scTypes.mli new file mode 100755 index 0000000..348f4fe --- /dev/null +++ b/src/scTypes.mli @@ -0,0 +1,126 @@ +(** All the types used in the spreadsheet. *) + +exception Error + +type cell = (int * int) * (bool * bool) + +type ident = UTF8.t + +type 'a dataFormat = + | Date: DataType.Num.t dataFormat (* A date in julian day *) + | Number: DataType.Num.t dataFormat (* Number *) + | String: DataType.String.t dataFormat (* String *) + | Bool: DataType.Bool.t dataFormat (* Boolean *) + +type 'a returnType = + | Num : DataType.Num.t dataFormat option -> DataType.Num.t returnType (** A number *) + | Str : DataType.String.t returnType (** A string *) + | Bool : DataType.Bool.t returnType (** A boolean *) + +type numericType = + | Date + | Number + +val get_numeric_type: DataType.Num.t dataFormat -> numericType + +type 'a types = private + | Num : DataType.Num.t dataFormat * DataType.Num.t -> DataType.Num.t types (** A number *) + | Str : DataType.String.t -> DataType.String.t types (** A string *) + | Bool : DataType.Bool.t -> DataType.Bool.t types (** A boolean *) + +val number: DataType.Num.t -> DataType.Num.t types +val string: DataType.String.t -> DataType.String.t types +val boolean: DataType.Bool.t -> DataType.Bool.t types +val date: DataType.Num.t -> DataType.Num.t types + + +(** Numeric (any format) *) +val f_num: DataType.Num.t returnType + +(** Date *) +val f_date: DataType.Num.t returnType + +(** Number *) +val f_number: DataType.Num.t returnType + +(** Boolean result *) +val f_bool: DataType.Bool.t returnType + +(** String *) +val f_string: DataType.String.t returnType + +type refs = + | Cell of cell (** A cell *) + | Range of cell * cell (** An area of cells *) + +(** This is the cell content *) +type expression = + | Value : 'a types -> expression (** A direct value *) + | Ref : refs -> expression (** A reference to another cell *) + | Call : ident * expression list -> expression (** A call to a function *) + | Expression : expression -> expression (** An expression *) + +(** Result from a computation *) +type result = + | Result : 'a types -> result + | Error : exn -> result + +module DataFormat : sig + + type formats = F : 'a dataFormat -> formats [@@unboxed] + + val guess_format_result: 'a returnType -> (unit -> formats list) -> 'a dataFormat + +end + +module Type : sig + + type t = Value: 'a dataFormat * 'a -> t + + val (=) : 'a types -> 'b types -> bool + + val show: UTF8.Buffer.buffer -> 'a types -> unit + + val show_full: UTF8.Buffer.buffer -> 'a types -> unit + +end + +module Refs : sig + + 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 + + type 'a content = + | Value: 'a dataFormat * 'a -> 'a content + | List: 'a dataFormat * 'a list -> 'a list content + | Matrix: 'a dataFormat * 'a list list -> 'a list list content + + type refContent = + | C: 'a content -> refContent [@@unboxed] + + (** extract the content from a range. + + May raise Errors.TypeError if the range cannot be unified. + *) + val get_content : result option range -> refContent + +end + +val show_expr: UTF8.Buffer.buffer -> expression -> unit + +module Result : sig + + val (=) : result -> result -> bool + + val show: result -> UTF8.t + +end + diff --git a/src/screen.ml b/src/screen.ml new file mode 100755 index 0000000..c61efea --- /dev/null +++ b/src/screen.ml @@ -0,0 +1,459 @@ +(** Curses submodules *) +module Attrs = Curses.A +module Color = Curses.Color + +module T2 = Tools.Tuple2 + +module Option = Tools.Option + +let cell_size = 10 + +let u = UTF8.from_utf8string + +type t = { + window: Curses.window; (* the main window *) + sheet: Curses.window; (* the spreadsheet *) + input: Curses.window; (* the input window *) + status: Curses.window; (* status bar *) + start: (int * int); (* Left corner *) + left_margin: int; (* Reserved margin for rows name *) + + mutable size: int * int; (* Terminal size *) +} + +let get_cell screen (x, y) = begin + + let x' = (fst screen.start) + (x - screen.left_margin) / cell_size + and y' = (snd screen.start) + y - 3 in + + if (x' < 1 || y' < 1) then + None + else + Some (x', y') +end + +let center data screen height width = begin + let height' = height - 3 + and width' = (width - screen.left_margin) / cell_size in + let end_x = (fst screen.start) + width' -1 in + let end_y = (snd screen.start) + height' -2 in + + let selected = Selection.extract data.Sheet.selected in + + let center_axis f replace max_limit shift screen = begin + let selected_axis = f selected in + match (selected_axis >= f screen.start), (selected_axis > max_limit) with + | true, false -> screen + | _ -> { screen with start = replace (max 1 (selected_axis - shift)) screen.start } + end in + center_axis T2.fst T2.replace1 end_x (width' / 2) screen + |> center_axis T2.snd T2.replace2 end_y (height' / 2) +end + +let status screen msg = begin + let height, width = screen.size in + UTF8.encode msg |> Option.iter (fun encoded -> + let status = Bytes.make (width -1) ' ' in + String.blit encoded 0 status 0 (String.length encoded); + Curses.werase screen.status; + if not ( + Curses.mvwaddstr screen.status 0 0 encoded + && Curses.wrefresh screen.status + ) then + raise (Failure "Status update") + ) +end + +(** Draw the spreadsheet *) +let draw data screen = begin + + let selected = Selection.extract data.Sheet.selected in + + let referenced = + Sheet.Raw.get_expr selected data.Sheet.data + |> Expression.collect_sources + + and sink = Sheet.Raw.get_sink selected data.Sheet.data in + + let height, width = screen.size in + let screen = center data screen height width in + + for y = 1 to (height-2) do + let pos_y = (y + (snd screen.start) - 1) in + if (Curses.has_colors ()) then begin + if Selection.is_selected (Selection.Vertical pos_y) data.Sheet.selected then + Curses.wattrset screen.sheet (Attrs.color_pair 2 ) + else + Curses.wattrset screen.sheet (Attrs.color_pair 1 ) + end; + ignore + @@ Curses.mvwaddstr screen.sheet y 0 + @@ Printf.sprintf "%-*d" screen.left_margin pos_y + done; + Curses.wattrset screen.sheet Attrs.normal; + + for x = 0 to ((width - cell_size - screen.left_margin) / cell_size) do + let pos_x = x + (fst screen.start) in + if (Curses.has_colors ()) then begin + if Selection.is_selected (Selection.Horizontal pos_x) data.Sheet.selected then + Curses.wattrset screen.sheet (Attrs.color_pair 2 ) + else + Curses.wattrset screen.sheet (Attrs.color_pair 1 ) + end; + + ignore + @@ Curses.mvwaddstr screen.sheet 0 (x * cell_size + screen.left_margin) + @@ Printf.sprintf "%-*s" cell_size (UTF8.raw_encode @@ Cell.to_hname pos_x); + + Curses.wattrset screen.sheet Attrs.normal; + + for y = 1 to (height-2) do + + let pos_y = y + (snd screen.start) - 1 in + + if (Curses.has_colors ()) then begin + if Selection.is_selected (Selection.Cell (pos_x, pos_y)) data.Sheet.selected then + Curses.wattrset screen.sheet (Attrs.color_pair 3 ) + else if Cell.Set.mem (pos_x, pos_y) referenced then + Curses.wattrset screen.sheet (Attrs.color_pair 4 ) + else if Cell.Set.mem (pos_x, pos_y) sink then + Curses.wattrset screen.sheet (Attrs.color_pair 5 ) + else + Curses.wattrset screen.sheet Attrs.normal; + end; + + + (* Get the content from the cell *) + let content = Sheet.Raw.get_value (pos_x, pos_y) data.Sheet.data + |> Option.map (fun x -> UTF8.split ~sep:(u"\n") (ScTypes.Result.show x)) + |> Option.default UTF8.empty in + + (* If the content is defined, try to encode it and print it*) + UTF8.encode content |> Tools.Option.iter (fun value -> + let length = UTF8.length content in + let strlength = String.length value in + let blank = cell_size - length in + let padding = if blank > 0 + then String.make blank ' ' + else "" in + ignore + @@ Curses.mvwaddnstr screen.sheet y (x * cell_size + screen.left_margin) + (Printf.sprintf "%s%s" value padding) + 0 (blank + strlength) + ) + done + done; + ignore @@ Curses.wrefresh screen.sheet; + screen + +end + +let init () = begin + (* Do not set delay after ESC keycode *) + begin try ignore @@ Unix.getenv "ESCDELAY" with + | Not_found -> Unix.putenv "ESCDELAY" "25" end; + + let window = Curses.initscr () in + let height, width = Curses.getmaxyx window in + + Tools.NCurses.set_mouse_event (Tools.NCurses.BUTTON1_CLICKED::[]); + + let init = Curses.keypad window true + && Curses.noecho () + && Curses.start_color () + && Curses.use_default_colors () + + (* Build the color map *) + && Curses.init_pair 1 Color.white Color.blue (* Titles *) + && Curses.init_pair 2 Color.blue Color.white (* Selected titles *) + && 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 in + + if not init then + raise (Failure "Initialisation") + else + { + window = window; + input = Curses.subwin window 2 width 0 0; + sheet = Curses.subwin window (height - 3) width 2 0; + status = Curses.subwin window 1 width (height - 1) 0; + start = 1, 1; + left_margin = 4; + size = height, width; + } +end + +let close {window} = begin + ignore @@ (Curses.keypad window false && Curses.echo ()); + Curses.endwin() +end + +let draw_input t screen = begin + + let height, width = screen.size in + + let expr = Sheet.Raw.get_expr (Selection.extract t.Sheet.selected) t.Sheet.data + |> Expression.show in + + let result = Sheet.Raw.get_value (Selection.extract t.Sheet.selected) t.Sheet.data + |> Option.map ScTypes.Result.show + |> Option.default UTF8.empty in + + UTF8.encode result |> Option.iter (fun encoded_result -> + (* 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_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 + + && Curses.wrefresh screen.input) + ); + status screen expr; + screen +end + +(** Wait for an event and return the key pressed + If the key code contains more than one char, they are both returned + *) +let read_key {window} = begin + let buff = Buffer.create 2 in + let int_val = Curses.wgetch window in + if int_val > 255 then + Buffer.add_string buff @@ Tools.String.string_of_ints int_val + else + Buffer.add_char buff @@ char_of_int int_val; + (** Check for a second key code *) + ignore @@ Curses.nodelay window true; + begin match Curses.wgetch window with + | -1 -> () + | x -> Buffer.add_char buff @@ char_of_int x; + end; + ignore @@ Curses.nodelay window false; + Buffer.contents buff +end + +let resize data t = begin + let size = Curses.getmaxyx t.window in + if (size <> t.size) then ( + let height, width = size in + t.size <- size; + ignore ( + Curses.wresize t.input 2 width + + && Curses.wresize t.sheet (height - 3) width + + (* The status window *) + && Curses.wresize t.status 1 width + && Curses.mvwin t.status (height - 1) 0); + Curses.wclear t.status; + ignore @@ Curses.wrefresh t.status; + draw data t + ) else t +end + +let editor ?position ?(prefix=UTF8.empty) ?(init=UTF8.empty) t = begin + let encodedPrefix = UTF8.raw_encode prefix + and encodedInit = UTF8.raw_encode init in + let with_refs, position = match position with + | None -> false, (1, 1) + | Some x -> true, x in + Curses.werase t.status; + ignore @@ Curses.mvwaddstr t.status 0 0 (encodedPrefix^encodedInit); + ignore @@ Curses.wrefresh t.status; + + (** Rewrite all the text after the cursor *) + let rewrite_after = begin function + | [] -> () + | elems -> ( (* Rewrite each char after the cursor *) + let y, x = Curses.getyx t.status in + List.iter (fun x -> ignore @@ Curses.waddstr t.status (UTF8.raw_encode x)) elems; + ignore @@ Curses.wmove t.status y x ) + end + + (** Delete the previous text (or block of text) *) + and delete_previous hd = begin + let y, x = Curses.getyx t.status in + let length = UTF8.length hd in + ignore @@ Curses.wmove t.status y (x - length); + for position = 1 to length do + ignore @@ Curses.wdelch t.status + done; + end in + + (* 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 *) + + (* We concatenate all the characters. This can create an invalid string in + * the current locale (if there are copy/paste, or other events). + *) + Some (UTF8.implode @@ (UTF8.rev_implode before)::after) + + | "\001\004" -> (* Left *) + begin match before with + | [] -> _edit before after @@ read_key t + | hd::tl -> + let y, x = Curses.getyx t.status + and length = UTF8.length hd in + ignore @@ Curses.wmove t.status y (x - length); + ignore @@ Curses.wrefresh t.status; + _edit tl (hd::after) @@ read_key t + end + + | "\001\005" -> (* Right *) + begin match after with + | [] -> _edit before after @@ read_key t + | hd::tl -> + let y, x = Curses.getyx t.status + and length = UTF8.length hd in + ignore @@ Curses.wmove t.status y (x + length); + ignore @@ Curses.wrefresh t.status; + _edit (hd::before) tl @@ read_key t + end + + | "\001\007" -> (* Backspace *) + begin match before with + | [] -> _edit before after @@ read_key t + | hd::tl -> + delete_previous hd; + ignore @@ Curses.wrefresh t.status; + _edit tl after @@ read_key t + end + + | "\001\006" -> (* Home *) + begin match before with + | [] -> _edit before after @@ read_key t + | elems -> + let to_left (size, after) elem = begin + let size' = size + UTF8.length elem in + size', elem::after + end in + let chars, after' = List.fold_left to_left (0, after) elems in + let y, x = Curses.getyx t.status in + ignore @@ Curses.wmove t.status y (x - chars); + ignore @@ Curses.wrefresh t.status; + _edit [] after' @@ read_key t + end + + | "\001\104" -> (* End *) + begin match after with + | [] -> _edit before after @@ read_key t + | elems -> + let to_rigth (size, before) elem = begin + let size' = size + UTF8.length elem in + size', elem::before + end in + let chars, before' = List.fold_left to_rigth (0, before) elems in + let y, x = Curses.getyx t.status in + ignore @@ Curses.wmove t.status y (x + chars); + ignore @@ Curses.wrefresh t.status; + _edit before' [] @@ read_key t + end + | "\001\074" + | "\127" -> (* Del *) + begin match after with + | [] -> _edit before after @@ read_key t + | hd::tl -> + let y, x = Curses.getyx t.status in + ignore @@ Curses.wmove t.status y (x + 1); + delete_previous hd; + ignore @@ Curses.wrefresh t.status; + _edit before tl @@ read_key t + end + + | ("\001\002" as key) (* Down *) + | ("\001\003" as key) (* Up *) + | ("\001\153" as key) -> (* click *) + if with_refs then + select_content position (UTF8.empty) before after key + else + _edit before after @@ read_key t + + | any -> + ignore @@ Curses.waddstr t.status any; + rewrite_after after; + ignore @@ Curses.wrefresh t.status; + _edit (UTF8.decode any::before) after @@ read_key t + end + + (* Selection mode, Left and Right keys allow to select a cell, and not to + move inside the edition *) + and select_content (x, y) name before after = begin + function + | "\001\002" -> (* Down *) insert_cell_name (x, y + 1) name before after + | "\001\005" -> (* Right *) insert_cell_name (x + 1, y) name before after + + | "\001\003" -> (* Up *) + if y > 1 then + insert_cell_name (x, y - 1) name before after + else select_content (x, y) name before after @@ read_key t + + | "\001\004" -> (* Left *) + if x > 1 then + insert_cell_name (x - 1, y) name before after + else select_content (x, y) name before after @@ read_key t + + | "\001\153" -> (* click *) + let position = + begin match Tools.NCurses.get_mouse_event () with + | None -> None + | Some (id, ev, (x, y, z)) -> + if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_CLICKED ev + || Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_PRESSED ev then + get_cell t (x,y) + else + None + end in + begin match position with + | None -> select_content (x, y) name before after @@ read_key t + | Some (x, y) -> insert_cell_name (x, y) name before after + end + + | key -> + _edit (UTF8.fold List.cons name before) after key + end + + and insert_cell_name position name before after = begin + let cell_name = Cell.to_string @@ (position, (false, false)) in + ignore @@ delete_previous name; + ignore @@ Curses.waddstr t.status (UTF8.raw_encode cell_name); + rewrite_after after; + ignore @@ Curses.wrefresh t.status; + select_content position cell_name before after @@ read_key t + end + in + + 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 + +let search screen = begin + let result = editor ~prefix:(u"/") screen in + begin match result with + | Some content -> content + | None -> UTF8.empty + end +end + +let run f = + let window = init () in + Tools.try_finally + (fun () -> f window) + (fun () -> ignore @@ close window ) diff --git a/src/screen.mli b/src/screen.mli new file mode 100755 index 0000000..b5f74b2 --- /dev/null +++ b/src/screen.mli @@ -0,0 +1,29 @@ +(** Represent the {!module:Sheet} *) + +type t + +(** Run the screen *) +val run: (t -> 'a) -> 'a + +(** {2 Screen updates} *) + +val draw: Sheet.t -> t -> t + +val draw_input: Sheet.t -> t -> t + +val resize: Sheet.t -> t -> t + +(** Display a message in the status bar. *) +val status: t -> UTF8.t -> unit + +(** {2 User inputs} *) + +(** Wait for a keycode *) +val read_key : t -> string +(** The keycode is always NULL terminated *) + +val search: t -> UTF8.t + +val get_cell: t -> int * int -> (int * int) option + +val editor: ?position: int * int -> ?prefix:UTF8.t -> ?init:UTF8.t -> t -> UTF8.t option diff --git a/src/selection.ml b/src/selection.ml new file mode 100755 index 0000000..2bf41ce --- /dev/null +++ b/src/selection.ml @@ -0,0 +1,73 @@ +module T2 = Tools.Tuple2 + +type t = + | Single of (int * int) + | Multiple of (int * int) * (int * int) + +let create c = Single c + +type axe = + | Horizontal of int + | Vertical of int + | Cell of (int * int) + +let is_selected sel_type t = match sel_type, t with + | Horizontal h , Single (x, y) -> h = x + | Vertical v , Single (x, y) -> v = y + | Cell c, Single x -> c = x + | Horizontal h, Multiple ((x1, _), (x2, _)) -> + let min_x = min x1 x2 + and max_x = max x1 x2 in + min_x <= h && h <= max_x + | Vertical v, Multiple ((_, y1), (_, y2)) -> + let min_y = min y1 y2 + and max_y = max y1 y2 in + min_y <= v && v <= max_y + | Cell (x, y), Multiple ((x1, y1), (x2, y2)) -> + let min_x = min x1 x2 + and max_x = max x1 x2 in + let min_y = min y1 y2 + and max_y = max y1 y2 in + min_x <= x && x <= max_x && min_y <= y && y <= max_y + +let extract = function + | Single x -> x + | Multiple (x,y) -> y + +let fold (f:('a -> int * int -> 'a)) (init:'a): t -> 'a = function + | Single x -> f init x + | Multiple ((x1, y1), (x2, y2)) -> + 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 res = ref init in + for x = min_x to max_x do + for y = min_y to max_y do + res := f !res (x, y) + done + done; + !res + +(** Extends the selection in one direction *) +let extends direction t = begin + let extends position = match direction with + | Actions.Left amount -> T2.map1 (fun v -> max 1 @@ v - amount) position + | Actions.Right amount -> T2.map1 ((+) amount) position + | Actions.Up amount -> T2.map2 (fun v -> max 1 @@ v - amount) position + | Actions.Down amount -> T2.map2 ((+) amount) position + | Actions.Absolute (x, y) -> x, y in + + let start_pos, end_pos = match t with + | Single x -> x, (extends x) + | Multiple (x, y) -> x, (extends y) in + + if start_pos = end_pos then + Single start_pos + else + Multiple (start_pos, end_pos) +end + +let shift = function + | Single (start_x, start_y) -> fun (x, y) -> (x - start_x, y - start_y) + | Multiple ((start_x, start_y), _) -> fun (x, y) -> (x - start_x, y - start_y) diff --git a/src/selection.mli b/src/selection.mli new file mode 100755 index 0000000..fb207e4 --- /dev/null +++ b/src/selection.mli @@ -0,0 +1,20 @@ +type t + +type axe = + | Horizontal of int + | Vertical of int + | Cell of (int * int) + +(** Create a new selection from a cell *) +val create: (int * int) -> t + +val is_selected: axe -> t -> bool + +(** Get the selection origin *) +val extract: t -> (int * int) + +val shift: t -> (int * int) -> (int * int) + +val fold: ('a -> int * int -> 'a) -> 'a -> t -> 'a + +val extends: Actions.direction -> t -> t diff --git a/src/sheet.ml b/src/sheet.ml new file mode 100755 index 0000000..67b1ee1 --- /dev/null +++ b/src/sheet.ml @@ -0,0 +1,334 @@ +module Option = Tools.Option + +type cell = int * int + +type search = [ + | `Pattern of ScTypes.result option + | `Next + | `Previous +] + +module Raw = struct + + module Map = Map.Make(struct + type t = cell + let compare (x1, y1) (x2, y2) = Pervasives.compare (y1, x1) (y2, x2) + end) + + type content = { + expr : Expression.t; (** The expression *) + value : ScTypes.result option; (** The content evaluated *) + 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 *) + let empty_cell = { + expr = Expression.Undefined; + value = None; + sink = Cell.Set.empty; + } + + let empty = Map.empty + + let get_value id t = begin + try (Map.find id t).value + with Not_found -> None + end + + let get_expr id t = begin + try (Map.find id t).expr + with Not_found -> empty_cell.expr + end + + (** Extract a value from a reference. + This function is given to the evaluator for getting the values from a reference. + *) + let get_ref from t ref : ScTypes.result option ScTypes.Refs.range = begin + + ScTypes.Refs.collect ref + |> ScTypes.Refs.map (fun coord -> get_value coord t) + + end + + (** Update the value for the given cell. + Evaluate the new expression and compare it with the previous value. + @return Some map if the map has been updated + *) + let update cell content t = begin + let new_val = Expression.eval content.expr (get_ref cell t) in + match content.value with + | None -> + (* If the previous value wasn't defined, update the map *) + Some (Map.add cell { content with value = Some new_val } t) + | Some old_value -> + (* If the previous value was defined, update only if result differs *) + if not (ScTypes.Result.(=) new_val old_value) then + Some (Map.add cell { content with value = Some new_val } t) + else + (* If there is no changes, do not update the map *) + None + end + + (** Parse all the successors from an element, apply a function to each of + them, and return them *) + let rec traverse (f:(cell -> content -> t -> t option)) source (init, t) = begin + + let exception Cycle of Cell.Set.t * t in + + let rec successors parents element (succ, t) = begin + + let content = Map.find element t in + + if Cell.Set.mem element parents then ( + + (* if the cell has already been visited, mark it in error, and all the + descendant *) + let cycle_error = Some (ScTypes.Error Errors.Cycle) in + + if content.value = cycle_error then ( + (* The content has already been updated, do not process it again *) + (succ, t) + ) else ( + let t = Map.add element { content with value = cycle_error } t + and set_error cell content t = + if content.value = cycle_error then + None + else + Some (Map.add cell { content with value = cycle_error } t) in + let succ, t = traverse set_error source (init, t) in + raise (Cycle (succ, t)) + ) + ) else ( + begin match f element content t with + | None -> + (* The content does not change, we do not update the successors *) + (succ, t) + | Some t' -> + let parents' = Cell.Set.add element parents + and succ' = Cell.Set.add element succ in + if (Cell.Set.is_empty content.sink) then + (succ', t') + else + Cell.Set.fold (successors parents') content.sink (succ', t') + end + ) + end in + try Cell.Set.fold (successors init) source.sink (init, t) + with Cycle (succ, t) -> (succ, t) + end + + (** Remove the cell from the sheet *) + let remove_element (id:cell) t : t * content option = begin + + (** Remove the references from each sources. + If the sources is not referenced anywhere, and is Undefined, remove it + *) + let remove_ref cell t = begin + try let c = Map.find cell t in + + (* Remove all the refs which points to the removed cell *) + let sink' = Cell.Set.filter ((<>) id) c.sink in + if Cell.Set.is_empty sink' && not (Expression.is_defined c.expr) then ( + Map.remove cell t ) + else + Map.add cell {c with sink = sink'} t + with Not_found -> t + end in + + begin try + let c = Map.find id t in + let t' = + (** Remove the references from each sources *) + let sources = Expression.collect_sources c.expr in + Cell.Set.fold remove_ref sources t in + + (** If there is no references on the cell, remove it *) + if Cell.Set.is_empty c.sink then ( + Map.remove id t', None) + else ( + let c = { empty_cell with sink = c.sink } in + Map.add id c t', (Some c) + ) + with Not_found -> t, None + end + end + + let remove id t = begin + match remove_element id t with + | t, None -> Cell.Set.empty, t + | t, Some content -> + (** Update all the successors *) + traverse update content (Cell.Set.singleton id, t) + end + + let add_element id f t = begin + + (** Add the references in each sources. + If the sources does not exists, create it. + *) + let add_ref cell t = begin + let c = + try Map.find cell t + with Not_found -> empty_cell in + let c' = { c with sink = Cell.Set.add id c.sink} in + Map.add cell c' t + end in + + let t', cell = remove_element id t in + let cell' = match cell with + | None -> empty_cell + | Some x -> x in + + let content = f cell' t' in + + let sources = Expression.collect_sources content.expr in + let updated = Map.add id content t' + |> Cell.Set.fold add_ref sources + in + + (** Update the value for each sink already evaluated *) + traverse update content (Cell.Set.singleton id, updated) + end + + let add id expression t = begin + if not (Expression.is_defined expression) then + (Cell.Set.empty, t) + else + let f cell t = { cell with + expr = expression ; + value = Some (Expression.eval expression (get_ref id t)) + } in + 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 = + { cell with + expr = expr ; + value = Some (Expression.eval expr (get_ref id t)) + } in + add_element id f t + end + + let search pattern t = begin + let exception Found of (int * int) in + + let _search key content = if content.value = pattern then raise (Found key) in + try + Map.iter _search t; + None + with Found key -> Some key + end + + let get_sink id t = + try (Map.find id t).sink + with Not_found -> Cell.Set.empty + + (** Fold over each defined value *) + let fold f a t = begin + Map.fold (fun key content a -> + match content.value with + | None -> a + | Some x -> + f a key (content.expr, x) + ) t a + end + +end + +type yank = cell * Raw.content + +type t = { + selected: Selection.t; (* The selected cell *) + data: Raw.t; + history: t list; (* Unlimited history *) + yank: (cell * Raw.content) list +} + +let undo t = begin match t.history with + | [] -> None + | hd::tl -> Some { hd with selected = t.selected } +end + +let move direction t = + let position = Selection.extract t.selected in + let position' = begin match direction with + | Actions.Left quant -> Tools.Tuple2.replace1 (max 1 ((fst position) - quant)) position + | Actions.Right quant -> Tools.Tuple2.replace1 ((fst position) + quant) position + | Actions.Up quant -> Tools.Tuple2.replace2 (max 1 ((snd position) - quant)) position + | Actions.Down quant -> Tools.Tuple2.replace2 ((snd position) + quant) position + | Actions.Absolute (x, y)-> (x, y) + end in + if position = position' then + None + else + Some {t with selected = Selection.create position'} + +let delete t = begin + let count, data' = Selection.fold (fun (count, c) t -> + (count + 1, snd @@ Raw.remove t c)) (0, t.data) t.selected in + let t' = { t with + data = data'; + history = t::t.history + } in + t', count +end + +let yank t = begin + + let shift = Selection.shift t.selected in + let origin = shift (0, 0) in + let _yank (count, extracted) cell = begin + let content = + try let content = (Raw.Map.find cell t.data) in + { content with Raw.expr = Expression.shift origin content.Raw.expr } + with Not_found -> Raw.empty_cell in + + count + 1, (shift cell,content)::extracted + end in + + let count, yanked = Selection.fold _yank (0, []) t.selected in + let t' = { t with yank = List.rev yanked; } in + t', count +end + +let paste t = begin + (* Origin of first cell *) + let (shift_x, shift_y) as shift = Selection.extract t.selected in + + let _paste (count, t) ((x, y), content) = begin + count + 1, snd @@ Raw.paste (shift_x + x, shift_y + y) shift content t + end in + + let count, data' = List.fold_left _paste (0, t.data) t.yank in + let t' = { t with data = data'; history = t::t.history } in + t', count +end + +let add expression t = begin + let id = Selection.extract t.selected in + let cells, data' = Raw.add id expression t.data in + cells, { t with data = data'; history = t::t.history} +end + +let search action t = begin match action with + | `Pattern pattern -> + begin match Raw.search pattern t.data with + | None -> None + | Some x -> Some {t with selected = Selection.create x} + end + | _ -> None +end + +let create data = { + data = data; + selected = Selection.create (1, 1); + history = []; + yank = []; +} diff --git a/src/sheet.mli b/src/sheet.mli new file mode 100755 index 0000000..11881cc --- /dev/null +++ b/src/sheet.mli @@ -0,0 +1,75 @@ +(** This module represent a sheet *) + +type cell = int * int + +module Raw: sig + + type t + + (** An empty sheet *) + val empty: t + + (** Add a new value in the sheet. The previous value is replaced + @return All the successors to update and the new sheet. + *) + val add: cell -> Expression.t -> t -> Cell.Set.t * t + + val remove: cell -> t -> Cell.Set.t * t + + (** Get the value content. + @return None if the cell is not defined + *) + val get_value: cell -> t -> ScTypes.result option + + val get_expr: cell -> t -> Expression.t + + val get_sink: cell -> t -> Cell.Set.t + + (** Fold over all the defined values *) + val fold: ('a -> cell -> (Expression.t * ScTypes.result ) -> 'a) -> 'a -> t -> 'a + +end + +type yank + +type t = { + selected: Selection.t; (* The selected cell *) + data: Raw.t; + history: t list; (* Unlimited history *) + yank: yank list (* All the selected cells *) +} + +type search = [ + | `Pattern of ScTypes.result option + | `Next + | `Previous +] + +(** Undo the last action and return the previous state, if any *) +val undo: t -> t option + +(** Move the cursor in one direction, return the state updated if the move is + allowed *) +val move: Actions.direction -> t -> t option + +(** Delete the content of selected cells. + @return The sheet and the number of cells deleted +*) +val delete: t -> t * int + +(** Copy the selected cells + @return The sheet and the number of cells deleted +*) +val yank: t -> t * int + +(** Search for a pattern on the sheet + @return The state updated if the pattern has been found. *) +val search: search -> t -> t option + +val paste: t -> t * int + +val add: Expression.t -> t -> Cell.Set.t * t + +(** Create an empty sheet *) +val create: Raw.t -> t + diff --git a/src/splay.ml b/src/splay.ml new file mode 100644 index 0000000..ec5750c --- /dev/null +++ b/src/splay.ml @@ -0,0 +1,142 @@ +module type KEY = sig + + type 'a t + + val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp + + val repr: Format.formatter -> 'a t -> unit + +end + +module Make (El : KEY) = struct + + type 'a elem = 'a El.t + + type leaf (** Fantom type for typing the tree *) + type node (** Fantom type for typing the tree *) + + type 'a treeVal = + | Leaf : leaf treeVal + | Node : _ treeVal * ('a elem * 'a) * _ treeVal -> node treeVal + + type t = T : 'a treeVal ref -> t [@@unboxed] + + let empty = T (ref Leaf) + + let isEmpty (T tree) = match !tree with + | Leaf -> true + | _ -> false + + let rec splay : type a. a elem -> node treeVal -> node treeVal = fun x t -> begin + let Node (l, y, r) = t in + begin match El.comp x (fst y) with + | Tools.Eq -> t + | Tools.Lt -> + begin match l with + | Leaf -> t + | Node (ll, z, rr) -> + begin match El.comp x (fst z) with + | Tools.Eq -> Node (ll, z, Node (rr, y, r)) + | Tools.Lt -> + begin match ll with + | Leaf -> Node (ll, z, Node (rr, y, r)) + | Node _ as ll -> + let Node (newL, newV, newR) = splay x ll + in Node (newL, newV, Node (newR, z, Node (rr, y, r))) + end + | Tools.Gt -> + begin match rr with + | Leaf -> Node (ll, z, Node (rr, y, r)) + | Node _ as rr -> + let Node (newL, newV, newR) = splay x rr + in Node (Node (ll, z, newL), newV, Node (newR, y, r)) + end + end + end + | Tools.Gt -> + begin match r with + | Leaf -> t + | Node (ll, z, rr) -> + begin match El.comp x (fst z) with + | Tools.Eq -> Node (Node (l, y, ll), z, rr) + | Tools.Lt -> + begin match ll with + | Leaf -> Node (Node (l, y, ll), z, rr) + | Node _ as ll -> + let Node (newL, newV, newR) = splay x ll + in Node (Node (l, y, newL), newV, Node (newR, z, rr)) + end + | Tools.Gt -> + begin match rr with + | Leaf -> Node (Node (l, y, ll), z, rr) + | Node _ as rr -> + let Node (newL, newV, newR) = splay x rr + in Node (Node (Node(l, y, ll), z, newL), newV, newR) + end + end + end + end + end + + let member: type a. a elem -> t -> bool = fun x (T t) -> match !t with + | Leaf -> false + | Node _ as root -> + let root' = splay x root in + t := root'; + let Node (_, c', _) = root' in + begin match El.comp (fst c') x with + | Tools.Eq -> true + | _ -> false + end + + let find: type a. a elem -> t -> a = fun x (T t) -> match !t with + | Leaf -> raise Not_found + | Node _ as root -> + let root' = splay x root in + t := root'; + let Node (_, c', _) = root' in + begin match El.comp (fst c') x with + | Tools.Eq -> snd c' + | _ -> raise Not_found + end + + let add: type a. a elem -> a -> t -> t = fun key value (T t) -> match !t with + | Leaf -> T (ref (Node (Leaf, (key, value), Leaf))) + | Node _ as root -> + let root' = splay key root in + let Node (l, y, r) = root' in + begin match El.comp key (fst y) with + | Tools.Eq -> T (ref root') + | Tools.Lt -> T (ref (Node (l, (key, value), Node (Leaf, y, r)))) + | Tools.Gt -> T (ref (Node (Node (l, y, Leaf), (key, value), r))) + end + + let repr formatter (T t) = begin + + let repr_edge from formatter dest = begin + Format.fprintf formatter "\"%a\" -> \"%a\"\n" + El.repr from + El.repr dest + end in + + let rec repr': type a b. a El.t -> Format.formatter -> b treeVal -> unit = fun parent formatter -> function + | Leaf -> () + | Node (l, c, r) -> + let key = fst c in + Format.fprintf formatter "%a%a%a" + (repr_edge parent) key + (repr' key) l + (repr' key) r in + + begin match !t with + | Leaf -> Format.fprintf formatter "digraph G {}" + | Node (l, c, r) -> + let key = fst c in + Format.fprintf formatter "digraph G {\n%a%a}" + (repr' key) l + (repr' key) r + end + + end + +end diff --git a/src/splay.mli b/src/splay.mli new file mode 100755 index 0000000..41c1a5a --- /dev/null +++ b/src/splay.mli @@ -0,0 +1,30 @@ +module type KEY = sig + + type 'a t + + val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp + + val repr: Format.formatter -> 'a t -> unit + +end + +module Make (El : KEY) : sig + + type t + + (** Create an empty tree *) + val empty: t + + (** Return the element in the tree with the given key *) + val find: 'a El.t -> t -> 'a + + (** Add one element in the tree *) + val add: 'a El.t -> 'a -> t -> t + + (** Check if the key exists *) + val member: 'a El.t -> t -> bool + + (** Represent the content in dot syntax *) + val repr: Format.formatter -> t -> unit + +end diff --git a/src/tools.ml b/src/tools.ml new file mode 100755 index 0000000..6dfe564 --- /dev/null +++ b/src/tools.ml @@ -0,0 +1,392 @@ +let u = UTF8.from_utf8string + +module Option = struct + + let map f = function + | Some x -> Some (f x) + | None -> None + + let iter f = function + | Some x -> f x + | None -> () + + let bind f = function + | None -> None + | Some x -> f x + + let default v = function + | None -> v + | Some x -> x + + +end + +module String = struct + + include String + + let split str ~by:sep = begin + let p = String.index str sep in + let slen = String.length str in + String.sub str 0 p, String.sub str (p + 1) (slen - p - 1) + end + + let cut str ~by:sep = begin + try String.sub str 0 @@ String.index str sep with + | Not_found -> str + end + + let string_of_ints v = begin + let buff = Buffer.create 1 in + let rec convert value = begin + Buffer.add_char buff @@ char_of_int @@ value land 0xFF; + let rem = value lsr 8 in + match rem with + | 0 -> Buffer.contents buff + | x -> convert x + end in + let res = convert v in + let buff' = Buffer.create @@ String.length res in + for i = ((String.length res) - 1) downto 0 do + Buffer.add_char buff' @@ String.get res i + done; + Buffer.contents buff' + end + + let print_buffer f t = begin + let buff = UTF8.Buffer.create 16 in + f buff t; + UTF8.Buffer.contents buff + end + + let filter_float str = begin + let l = String.length str in + if l > 0 && String.get str (l - 1) = '.' then + String.sub str 0 (l - 1) + else + str + end + +end + +module List = struct + + (** fold_left over only the first element *) + let fst f init = function + | hd::tl -> f init hd + | [] -> init + + let printb ?(first=(u"(")) ?(last=(u")")) ?(sep=(u",")) f buffer elems = begin + + let rec print = begin function + | [] -> () + | hd::[] -> + f buffer hd; + | hd::tl -> + f buffer hd; + UTF8.Buffer.add_string buffer sep; + print tl + end in + + UTF8.Buffer.add_string buffer first; + print elems; + UTF8.Buffer.add_string buffer last + end + + let rec find_map f = begin function + | [] -> raise Not_found + | hd::tl -> begin match f hd with + | Some x -> x + | None -> (find_map[@tailrec]) f tl + end + end + + let rec findOpt p = begin function + | [] -> None + | x::l -> + if p x then + Some(x) + else + findOpt p l + end + + and find_map2 p = begin function + | [] -> raise Not_found + | x::l -> + begin try find_map p x with + Not_found -> find_map2 p l + 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 + + let linearize elems = begin + let rec _linearize acc (elems:'a list list) : 'a list = begin + let split (hds, tls) = function + | hd::tl -> hd::hds, tl::tls + | [] -> hds, tls + in + match elems with + | [] -> acc + | elems -> + let acc, tls = List.fold_left split (acc, []) elems in + _linearize acc tls + end in + List.rev @@ _linearize [] elems + end + +end + +module Tuple2 = struct + + let fst = Pervasives.fst + + let snd = Pervasives.snd + + let map1 f (a, b) = (f a, b) + + let map2 f (a, b) = (a, f b) + + let replace1 v (a, b) = (v, b) + + let replace2 v (a, b) = (a, v) + + let printb ?(first="(") ?(last=")") ?(sep=",") format1 format2 out (a, b) = begin + UTF8.Printf.bprintf out "%s%a%s%a%s" + first + format1 a + sep + format2 b + last + end + +end + +module Tuple3 = struct + + let fst (a, b, c) = a + + let snd (a, b, c) = b + + let thd (a, b, c) = c + + let map f (a, b, c) = (f a, f b, f c) + + let map1 f (a, b, c) = (f a, b, c) + + let map2 f (a, b, c) = (a, f b, c) + + let map3 f (a, b, c) = (a, b, f c) + + let replace1 v (a, b, c) = (v, b, c) + + let replace2 v (a, b, c) = (a, v, c) + + let replace3 v (a, b, c) = (a, b, v) +end + +module NCurses = struct + + type mouse_event = + | BUTTON1_PRESSED + | BUTTON1_RELEASED + | BUTTON1_CLICKED + | BUTTON1_DOUBLE_CLICKED + | BUTTON1_TRIPLE_CLICKED + | BUTTON2_PRESSED + | BUTTON2_RELEASED + | BUTTON2_CLICKED + | BUTTON2_DOUBLE_CLICKED + | BUTTON2_TRIPLE_CLICKED + | BUTTON3_PRESSED + | BUTTON3_RELEASED + | BUTTON3_CLICKED + | BUTTON3_DOUBLE_CLICKED + | BUTTON3_TRIPLE_CLICKED + | BUTTON4_PRESSED + | BUTTON4_RELEASED + | BUTTON4_CLICKED + | BUTTON4_DOUBLE_CLICKED + | BUTTON4_TRIPLE_CLICKED + | BUTTON_SHIFT + | BUTTON_CTRL + | BUTTON_ALT + | ALL_MOUSE_EVENTS + | REPORT_MOUSE_POSITION + + type event_type + + external set_mouse_event: mouse_event list -> unit = "c_set_mouse_event" + + external get_mouse_event: unit -> (int * event_type * (int * int * int)) option = "c_get_mouse_event" + + external is_event_of_type: mouse_event -> event_type -> bool = "c_is_event_of_type" + +end + +let try_finally f except = + try let res = f () in + except (); + res + 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 comp: '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.comp 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.comp 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 wrapper = Ex: 'a key * 'a -> wrapper + + type t = + | Empty : t + | Node : t * 'a key * 'a * t * int -> t + + let singleton x d = Node(Empty, x, d, Empty, 1) + + let empty = Empty + + let is_empty = function + | Empty -> true + | _ -> false + + let height = function + | Empty -> 0 + | Node(_,_,_,_,h) -> h + + let create l x d r = + let hl = height l and hr = height r in + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + + let bal l x d r = + let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Map.bal" + | Node(ll, lv, ld, lr, _) -> + if height ll >= height lr then + create ll lv ld (create lr x d r) + else begin + match lr with + Empty -> invalid_arg "Map.bal" + | Node(lrl, lrv, lrd, lrr, _)-> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Map.bal" + | Node(rl, rv, rd, rr, _) -> + if height rr >= height rl then + create (create l x d rl) rv rd rr + else begin + match rl with + Empty -> invalid_arg "Map.bal" + | Node(rll, rlv, rld, rlr, _) -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + end + end else + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + + + let rec add: type a. a key -> a -> t -> t = begin fun x data t -> match t with + | Empty -> Node(Empty, x, data, Empty, 1) + | Node(l, v, d, r, h) -> + match Ord.comp x v with + | Eq -> Node(l, x, data, r, h) + | Lt -> bal (add x data l) v d r + | Gt -> bal l v d (add x data r) + end + + let rec find: type a. a key -> t -> a = begin fun x t -> match t with + | Empty -> raise Not_found + | Node(l, k, v, r, _) -> + match Ord.comp x k with + | Eq -> v + | Lt -> find x l + | Gt -> find x r + end + + let rec mem: type a. a key -> t -> bool = begin fun x t -> match t with + | Empty -> false + | Node(l, k, v, r, _) -> + match Ord.comp x k with + | Eq -> true + | Lt -> mem x l + | Gt -> mem x r + end + + (* + let rec fold: ('a -> wrapper -> 'a) -> 'a -> t -> 'a = + begin fun f init t -> match t with + | Empty -> init + | Node(l, k, v, r, _) -> + let res_left = fold f init l in + let result = f res_left @@ Ex (k, v) in + fold f result r + end + *) +end diff --git a/src/unicode.ml b/src/unicode.ml new file mode 100755 index 0000000..cc8c087 --- /dev/null +++ b/src/unicode.ml @@ -0,0 +1,51 @@ +type t = Uchar.t array + +type decoder_encoding = Uutf.decoder_encoding + +let array_from_rev_list l = begin + let length = (List.length l) - 1 in + let arr = Array.make (length + 1) (Obj.magic 0) in + List.iteri (fun i elem -> Array.set arr (length - i) elem) l; + arr +end + + +let decode ?encoding str = begin + let decoder = Uutf.decoder ?encoding (`String str) in + let rec loop buf = begin match Uutf.decode decoder with + | `Uchar u -> loop (u::buf) + | `Malformed _ -> loop (Uutf.u_rep::buf) + | `Await -> assert false + | `End -> ( + array_from_rev_list buf + ) + end in + loop [] +end + +let to_utf8 (t:t) = begin + let buf = Buffer.create 512 in + Array.iter (Uutf.Buffer.add_utf_8 buf) t; + Buffer.contents buf +end + +let length = Array.length + +let get t i = Uchar.of_int @@ Array.get t i + +let make i v = Array.make i @@ Uchar.to_int v + +let init s f = Array.init s (fun x -> Uchar.to_int @@ f x) + +let sub = Array.sub + +let blit = Array.blit + +let concat = Array.concat + +let iter f t = Array.iter (fun x -> f @@ Uchar.of_int x) t + + +let to_list t = + Array.map Uchar.of_int t + |> Array.to_list diff --git a/src/unicode.mli b/src/unicode.mli new file mode 100755 index 0000000..9a48807 --- /dev/null +++ b/src/unicode.mli @@ -0,0 +1,27 @@ +type t + +type decoder_encoding = [ `ISO_8859_1 | `US_ASCII | `UTF_16 | `UTF_16BE | `UTF_16LE | `UTF_8 ] + +val decode : ?encoding:[< decoder_encoding ] -> string -> t + +val to_utf8: t -> string + +(** String functions *) + +val length : t -> int + +val get : t -> int -> Uchar.t + +val make : int -> Uchar.t -> t + +val init : int -> (int -> Uchar.t) -> t + +val sub : t -> int -> int -> t + +val blit : t -> int -> t -> int -> int -> unit + +val concat : t list -> t + +val iter : (Uchar.t -> unit) -> t -> unit + +val to_list : t -> Uchar.t list -- cgit v1.2.3