From ef312564ca84a2b49fc291434d8fb2f8501bb618 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Tue, 15 Nov 2016 13:00:01 +0100 Subject: Initial commit --- .gitignore | 5 + .merlin | 7 + Makefile | 44 ++++ UTF8.ml | 36 ++++ UTF8.mli | 61 ++++++ actionParser.mly | 47 +++++ actions.mli | 28 +++ catalog.ml | 21 ++ catalog.mli | 4 + cell.ml | 70 +++++++ cell.mli | 20 ++ expression.ml | 109 ++++++++++ expression.mli | 28 +++ expressionLexer.mll | 84 ++++++++ expressionParser.mly | 102 ++++++++++ functions.ml | 114 +++++++++++ main.ml | 241 ++++++++++++++++++++++ odf/odf.ml | 311 ++++++++++++++++++++++++++++ odf/odf_ExpressionLexer.mll | 88 ++++++++ odf/odf_ExpressionParser.mly | 92 +++++++++ odf/odf_ns.ml | 95 +++++++++ readme.rst | 203 ++++++++++++++++++ scTypes.ml | 168 +++++++++++++++ scTypes.mli | 58 ++++++ screen.ml | 452 +++++++++++++++++++++++++++++++++++++++++ screen.mli | 31 +++ selection.ml | 73 +++++++ selection.mli | 20 ++ sheet.ml | 300 +++++++++++++++++++++++++++ sheet.mli | 73 +++++++ stub/Makefile | 22 ++ stub/curses.c | 111 ++++++++++ stub/locale.c | 45 ++++ stub/ocaml.c | 38 ++++ stub/ocaml.h | 28 +++ tests/expressionParser_test.ml | 83 ++++++++ tests/expression_test.ml | 113 +++++++++++ tests/sheet_test.ml | 136 +++++++++++++ tests/test.ml | 10 + tests/tools_test.ml | 220 ++++++++++++++++++++ tests/unicode_test.ml | 39 ++++ tools.ml | 288 ++++++++++++++++++++++++++ unicode.ml | 51 +++++ unicode.mli | 27 +++ 44 files changed, 4196 insertions(+) create mode 100755 .gitignore create mode 100755 .merlin create mode 100755 Makefile create mode 100755 UTF8.ml create mode 100755 UTF8.mli create mode 100755 actionParser.mly create mode 100755 actions.mli create mode 100755 catalog.ml create mode 100755 catalog.mli create mode 100755 cell.ml create mode 100755 cell.mli create mode 100755 expression.ml create mode 100755 expression.mli create mode 100755 expressionLexer.mll create mode 100755 expressionParser.mly create mode 100755 functions.ml create mode 100755 main.ml create mode 100755 odf/odf.ml create mode 100755 odf/odf_ExpressionLexer.mll create mode 100755 odf/odf_ExpressionParser.mly create mode 100755 odf/odf_ns.ml create mode 100755 readme.rst create mode 100755 scTypes.ml create mode 100755 scTypes.mli create mode 100755 screen.ml create mode 100755 screen.mli create mode 100755 selection.ml create mode 100755 selection.mli create mode 100755 sheet.ml create mode 100755 sheet.mli create mode 100755 stub/Makefile create mode 100755 stub/curses.c create mode 100755 stub/locale.c create mode 100755 stub/ocaml.c create mode 100755 stub/ocaml.h create mode 100755 tests/expressionParser_test.ml create mode 100755 tests/expression_test.ml create mode 100755 tests/sheet_test.ml create mode 100755 tests/test.ml create mode 100755 tests/tools_test.ml create mode 100755 tests/unicode_test.ml create mode 100755 tools.ml create mode 100755 unicode.ml create mode 100755 unicode.mli diff --git a/.gitignore b/.gitignore new file mode 100755 index 0000000..31cdc19 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +_build/ +*.byte +*.native +*.swp +*.docdir diff --git a/.merlin b/.merlin new file mode 100755 index 0000000..a3f38e6 --- /dev/null +++ b/.merlin @@ -0,0 +1,7 @@ +PKG num curses camlzip ezxmlm uutf text calendar oUnit menhirLib +S . +S odf/* +S tests/* +B _build/ +B _build/* + diff --git a/Makefile b/Makefile new file mode 100755 index 0000000..a792dd6 --- /dev/null +++ b/Makefile @@ -0,0 +1,44 @@ +OCAMLBUILD ?= ocamlbuild +PACKAGES=num,curses,camlzip,ezxmlm,text,calendar,menhirLib +PATHS=.,odf + +MENHIR=-use-menhir + +LIB = licht +LIB_STUB = $(LIB)_stub + +STUB_OPTIONS=-lflags -ccopt,-L.,-cclib,-l$(LIB_STUB) +BYTE_STUB_OPTIONS=$(STUB_OPTIONS)#,-dllib,-l$(LIB_STUB) + +.PHONY: stub + +all: native + +stub: + $(MAKE) -C stub LIB=$(LIB) + +deps: + opam install ocamlbuild curses camlzip ezxmlm ounit text menhir calendar + +byte: stub + $(OCAMLBUILD) -pkgs $(PACKAGES) $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS) main.byte + +native: stub + $(OCAMLBUILD) -pkgs $(PACKAGES) $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS) main.native + +doc: + $(OCAMLBUILD) -pkgs $(PACKAGES) -menhir -Is $(PATHS) licht.docdir/index.html + +test: stub + $(OCAMLBUILD) -pkgs $(PACKAGES),oUnit -cflag -g -lflag -g $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS),tests test.byte -- + +relink: stub + rm -f _build/main.native + rm -f _build/main.byte + rm -f _build/tests.byte + make + +clean: + make -C stub clean + $(OCAMLBUILD) -clean + diff --git a/UTF8.ml b/UTF8.ml new file mode 100755 index 0000000..33df5b4 --- /dev/null +++ b/UTF8.ml @@ -0,0 +1,36 @@ +include Text + +let empty = "" + +let decode x = Text.decode x + +let 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 + +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 diff --git a/UTF8.mli b/UTF8.mli new file mode 100755 index 0000000..c1fa400 --- /dev/null +++ b/UTF8.mli @@ -0,0 +1,61 @@ +(** 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 + +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 + +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 + + val sprintf : ('a, unit, string) format -> 'a + +end diff --git a/actionParser.mly b/actionParser.mly new file mode 100755 index 0000000..809a9ad --- /dev/null +++ b/actionParser.mly @@ -0,0 +1,47 @@ +%{ + 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 + +%token Num + +%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/actions.mli b/actions.mli new file mode 100755 index 0000000..f955538 --- /dev/null +++ b/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/catalog.ml b/catalog.ml new file mode 100755 index 0000000..ee74a5a --- /dev/null +++ b/catalog.ml @@ -0,0 +1,21 @@ +(** Catalog for all function *) +module C = Map.Make( + struct + type t = UTF8.t + let compare a b = Pervasives.compare + (String.uppercase_ascii @@ UTF8.to_utf8string a) + (String.uppercase_ascii @@ UTF8.to_utf8string b) + end +) + +let catalog = ref C.empty + +let register name f = + catalog := C.add name f !catalog + +let eval name params = + + let func = C.find name !catalog in + func params + + diff --git a/catalog.mli b/catalog.mli new file mode 100755 index 0000000..583db14 --- /dev/null +++ b/catalog.mli @@ -0,0 +1,4 @@ + +val register: UTF8.t -> (ScTypes.types list -> ScTypes.types) -> unit + +val eval: UTF8.t -> ScTypes.types list -> ScTypes.types diff --git a/cell.ml b/cell.ml new file mode 100755 index 0000000..c4aa9c3 --- /dev/null +++ b/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, Num.int_of_num 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/cell.mli b/cell.mli new file mode 100755 index 0000000..621fc3b --- /dev/null +++ b/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 * Num.num -> t + +val to_hname: int -> UTF8.t + +val to_string: t -> UTF8.t + +val to_buffer: UTF8.Buffer.buffer -> t -> unit + diff --git a/expression.ml b/expression.ml new file mode 100755 index 0000000..f516463 --- /dev/null +++ b/expression.ml @@ -0,0 +1,109 @@ +module C = Catalog + +module Calendar = CalendarLib.Calendar.Precise + +let u = UTF8.from_utf8string + +type t = + | Basic of ScTypes.types (** A direct type *) + | Formula of formula (** A formula *) + +and formula = + | Expression of ScTypes.expression (** A valid expression *) + | Error of int * UTF8.t (** When the expression cannot be parsed *) + + +let is_defined = function + | Basic ScTypes.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 + Basic ( + (*try ScTypes.Num (Tools.Num.of_float_string content')*) + try Lexing.from_string content' + |> ExpressionParser.content ExpressionLexer.read + with _ -> ScTypes.Str (UTF8.from_utf8string content') + ) + ) + ) else ( + (* If the string in empty, build an undefined value *) + Basic ScTypes.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 rec eval_exp: ScTypes.expression -> ScTypes.types = function + | ScTypes.Value v -> v + | ScTypes.Call (ident, params) -> C.eval ident (List.map eval_exp params) + | ScTypes.Ref r -> sources r + | ScTypes.Expression expr -> eval_exp expr + in + + begin try match expr with + | Basic value -> ScTypes.Result value + | Formula (Expression f) -> ScTypes.Result (eval_exp f) + | Formula (Error (i, s)) -> ScTypes.Error ScTypes.Error + with ex -> ScTypes.Error ex + end + +end + +let collect_sources expr = begin + let rec collect refs = function + | ScTypes.Ref r -> Cell.Set.union refs (Cell.Set.of_list @@ ScTypes.Refs.collect r) + | ScTypes.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 buffer b + | Formula (Error (i,s)) -> UTF8.Buffer.add_string buffer s + 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/expression.mli b/expression.mli new file mode 100755 index 0000000..9888ece --- /dev/null +++ b/expression.mli @@ -0,0 +1,28 @@ +type t = + | Basic of ScTypes.types (** A direct type *) + | Formula of formula (** A formula *) + +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.types) -> 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/expressionLexer.mll b/expressionLexer.mll new file mode 100755 index 0000000..57ef26a --- /dev/null +++ b/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, Num.num_of_string _1)} + | real as _1 { REAL(Tools.String.filter_float _1, Tools.Num.of_float_string _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/expressionParser.mly b/expressionParser.mly new file mode 100755 index 0000000..a4d0716 --- /dev/null +++ b/expressionParser.mly @@ -0,0 +1,102 @@ +%{ + 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: + | num {Num ((snd $1), Some (u(fst $1)))} + | MINUS num {Num (Num.minus_num (snd $2), Some (u("-" ^(fst $2)) ))} + | NUM DIVIDE NUM DIVIDE NUM { + Date (Tools.Date.get_julian_day + (Num.int_of_num @@ snd $1) + (Num.int_of_num @@ snd $3) + (Num.int_of_num @@ snd $5) + )} + +expr: + | num {Value (Num ((snd $1), Some (u(fst $1))))} + | MINUS num {Value (Num (Num.minus_num (snd $2), Some (u("-" ^(fst $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 (Str (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, snd $2) } + | DOLLAR LETTERS NUM { Cell.from_string (true, $2) (false, snd $3) } + | LETTERS DOLLAR NUM { Cell.from_string (false, $1) (true, snd $3) } + | DOLLAR LETTERS DOLLAR NUM { Cell.from_string (true, $2) (true, snd $4) } + +num: + | REAL {$1} + | NUM {$1} + +ident: + | text* { String.concat "" $1 } + +text: + | LETTERS { $1 } + | NUM { fst $1 } diff --git a/functions.ml b/functions.ml new file mode 100755 index 0000000..2014d2e --- /dev/null +++ b/functions.ml @@ -0,0 +1,114 @@ +open Catalog + +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"-" + +let sum = u"sum" + +let () = + + (** Comparaison *) + let compare = function + | ScTypes.Num (n1,_)::ScTypes.Num (n2,_)::[] -> Num.compare_num n1 n2 + | ScTypes.Date n1::ScTypes.Date n2::[] -> Num.compare_num n1 n2 + | ScTypes.Str s1::ScTypes.Str s2::[] -> UTF8.compare s1 s2 + | ScTypes.Bool b1::ScTypes.Bool b2::[] -> Pervasives.compare b1 b2 + | ScTypes.List l1::ScTypes.List l2::[] -> Pervasives.compare l1 l2 + | t1::t2::[] -> Pervasives.compare t1 t2 + | _ -> raise ScTypes.Error + in + register eq (fun args -> ScTypes.Bool ((compare args) = 0)); + register neq (fun args -> ScTypes.Bool ((compare args) != 0)); + register lt (fun args -> ScTypes.Bool ((compare args) < 0)); + register le (fun args -> ScTypes.Bool ((compare args) <= 0)); + register gt (fun args -> ScTypes.Bool ((compare args) > 0)); + register ge (fun args -> ScTypes.Bool ((compare args) >= 0)); + + (** Basic *) + + register sum (fun args -> + + let rec sum value = function + | ScTypes.Undefined -> value + | ScTypes.Num (n,_) -> Num.add_num value n + | ScTypes.Date n -> Num.add_num value n + | ScTypes.List l -> List.fold_left sum value l + | _ -> raise ScTypes.Error in + + ScTypes.Num (List.fold_left sum (Num.num_of_int 0) args, None) + ); + + let rec operation f = begin function + | ScTypes.Undefined , x -> operation f (ScTypes.Num (Num.num_of_int 0, None), x) + | x, ScTypes.Undefined -> operation f (x, ScTypes.Num (Num.num_of_int 0, None)) + | ScTypes.Num (n1,_), ScTypes.Num (n2,_) -> ScTypes.Num (f n1 n2, None) + | ScTypes.Date n1, ScTypes.Date n2 -> ScTypes.Date (f n1 n2) + | ScTypes.Date n1, ScTypes.Num (n2,_) -> ScTypes.Date (f n1 n2) + | ScTypes.Num (n1,_), ScTypes.Date n2 -> ScTypes.Date (f n1 n2) + | _ -> raise ScTypes.Error + end + in + + register add (function + | t1::t2::[] -> (operation Num.add_num) (t1, t2) + | _ -> raise ScTypes.Error + ); + + register mul (function + | t1::t2::[] -> (operation Num.mult_num) (t1, t2) + | _ -> raise ScTypes.Error + ); + + register div (function + | t1::t2::[] -> (operation Num.div_num) (t1, t2) + | _ -> raise ScTypes.Error + ); + + register sub (function + | t1::t2::[] -> (operation Num.sub_num) (t1, t2) + | _ -> raise ScTypes.Error + ); + + register pow (function + | t1::t2::[] -> (operation Num.power_num) (t1, t2) + | _ -> raise ScTypes.Error + ); + + (** Binary *) + + register (u"true") (function + | [] -> ScTypes.Bool true + | _ -> raise ScTypes.Error + ); + + register (u"false") (function + | [] -> ScTypes.Bool false + | _ -> raise ScTypes.Error + ); + + register (u"not") (function + | (ScTypes.Bool x):: [] -> ScTypes.Bool (not x) + | _ -> raise ScTypes.Error + ); + + register (u"date") (function + | (ScTypes.Num (x,_)):: [] -> ScTypes.Date x + | _ -> raise ScTypes.Error + ); + + register (u"num") (function + | (ScTypes.Date x):: [] -> ScTypes.Num (x, None) + | _ -> raise ScTypes.Error + ); diff --git a/main.ml b/main.ml new file mode 100755 index 0000000..58cbea5 --- /dev/null +++ b/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 ~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.Undefined) in + begin match Sheet.search (`Pattern 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 ~init:(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 + | (":enew", _) -> (* Start a new spreadsheet *) + let sheet = Sheet.Raw.create in + normal_mode @@ redraw (Sheet.create sheet) screen + | (":q", _) -> (* Quit *) + t + | _ -> normal_mode @@ redraw t screen +end + +let () = begin + + let sheet = + if Array.length Sys.argv = 1 then + Sheet.Raw.create + else + Odf.load Sys.argv.(1) in + + let window = Screen.init () in + begin Tools.try_finally + (fun () -> + ignore @@ normal_mode @@ redraw (Sheet.create sheet) window) + (fun () -> + ignore @@ Screen.close window; ) + end +end diff --git a/odf/odf.ml b/odf/odf.ml new file mode 100755 index 0000000..cfbd964 --- /dev/null +++ b/odf/odf.ml @@ -0,0 +1,311 @@ +module Xml = Ezxmlm +module T = Tools +module NS = Odf_ns + +let u = UTF8.from_utf8string + +type t + +let load_attrs attrs = + + let _load t = function + | (("urn:oasis:names:tc:opendocument:xmlns:table:1.0", "formula"), x) -> + T.Tuple3.replace1 (Some x) t + | (("urn:oasis:names:tc:opendocument:xmlns:office:1.0", "value"), x) -> + T.Tuple3.replace2 (Some x) t + | (("urn:oasis:names:tc:opendocument:xmlns:office:1.0", "date-value"), x) -> + T.Tuple3.replace2 (Some x) t + | (("urn:oasis:names:tc:opendocument:xmlns:table:1.0", "number-columns-repeated"), x) -> + T.Tuple3.replace3 (Some x) t + | _ -> t + in List.fold_left _load (None, None, None) attrs + +let load_formula formula = + let lineBuffer = Lexing.from_string formula in + Expression.Formula ( + Expression.Expression ( + Odf_ExpressionParser.value Odf_ExpressionLexer.read lineBuffer)) + +let load_content content = begin function + | "float" -> Expression.Basic ( + ScTypes.Num ( + (Tools.Num.of_float_string content), Some (u @@ Tools.String.filter_float content))) + | "date" -> Expression.Basic ( + ScTypes.Date ( + Tools.Date.from_string content)) + | _ -> Expression.Basic ( + ScTypes.Str ( + UTF8.from_utf8string content)) +end + +let load_cell sheet cell_num row_num changed (attrs, cell) = begin + + let attributes = load_attrs attrs in + let repetition = match T.Tuple3.thd attributes 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 expression, new_change = begin match attributes 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.Basic ScTypes.Undefined, false + end + end in + + if new_change then ( + for i = 1 to repetition do + incr cell_num; + sheet := snd @@ Sheet.Raw.add (!cell_num, !row_num) (Expression.load_expr expression) !sheet + done + ) else ( + cell_num := !cell_num + repetition + ); + changed || new_change +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.create 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 attrs output = begin function + | ScTypes.Num (n,_) -> + let value = (string_of_float @@ Num.float_of_num n) in + write_num ((NS.value_attr, value)::attrs) output value + | ScTypes.Str s -> write_str attrs output (UTF8.to_utf8string s) + | ScTypes.Bool b -> write_bool attrs output (string_of_bool b) + | ScTypes.List l -> write_error attrs output "" + | ScTypes.Date d -> + let value = Tools.Date.to_string d in + write_date ((NS.date_value_attr, value)::attrs) output value + | _ -> () +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 buffer = begin function + | ScTypes.Value (ScTypes.Num (n, _)) -> + UTF8.Buffer.add_string buffer @@ u(string_of_float @@ Num.float_of_num n) + | ScTypes.Value (ScTypes.Str s) -> + UTF8.Buffer.add_string buffer @@ u"\""; + UTF8.Buffer.add_string buffer s; + UTF8.Buffer.add_string buffer @@ u"\"" + | ScTypes.Value (ScTypes.Bool b) -> UTF8.Buffer.add_string buffer @@ u(string_of_bool b) + | ScTypes.Value x -> () + | 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::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.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) = begin + + 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 + + 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 + +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 = + 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 + ) diff --git a/odf/odf_ExpressionLexer.mll b/odf/odf_ExpressionLexer.mll new file mode 100755 index 0000000..28fce22 --- /dev/null +++ b/odf/odf_ExpressionLexer.mll @@ -0,0 +1,88 @@ +{ + 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'] +let identifier = letters (letters | digit | ['-' '_' '.'])* (letters | digit)+ + +let text = letters | digit + +let cell = letters+ digit+ + +rule read = parse + | space+ { read lexbuf } + + | digit+ as _1 { NUM (_1, Num.num_of_string _1)} + | real as _1 { REAL (Tools.String.filter_float _1, Tools.Num.of_float_string _1)} + | '$' { DOLLAR } + + | '=' { EQ } + | "<>" { NEQ } + | '<' { LT } + | "<=" { LE } + | '>' { GT } + | ">=" { GE } + | '*' { TIMES } + | '+' { PLUS } + | '-' { MINUS } + | '/' { DIVIDE } + | '"' { read_string (Buffer.create 17) lexbuf } + | ';' { SEMICOLON } + | ':' { COLON } + | '[' { L_SQ_BRACKET } + | ']' { R_SQ_BRACKET } + | '(' { LPAREN } + | ')' { RPAREN } + | '^' { POW } + | '.' { DOT } + + | 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/odf/odf_ExpressionParser.mly b/odf/odf_ExpressionParser.mly new file mode 100755 index 0000000..6c34c1d --- /dev/null +++ b/odf/odf_ExpressionParser.mly @@ -0,0 +1,92 @@ +%{ + 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 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 (Num ((snd $1), Some (u(fst $1))))} + | MINUS num {Value (Num (Num.minus_num (snd $2), Some (u("-" ^(fst $2)) )))} + + + | L_SQ_BRACKET ref R_SQ_BRACKET {$2} + + | LPAREN expr RPAREN {Expression $2} + | STR {Value (Str (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 {$1} + | NUM {$1} + +ident: + | text+ { String.concat "" $1 } + +text: + | LETTERS { $1 } + | NUM { fst $1 } diff --git a/odf/odf_ns.ml b/odf/odf_ns.ml new file mode 100755 index 0000000..c22ae7e --- /dev/null +++ b/odf/odf_ns.ml @@ -0,0 +1,95 @@ +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 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/readme.rst b/readme.rst new file mode 100755 index 0000000..a41c0c0 --- /dev/null +++ b/readme.rst @@ -0,0 +1,203 @@ +.. -*- mode: rst -*- +.. -*- coding: utf-8 -*- + +.. default-role:: code + +.. contents:: + +=========== +Compilation +=========== + +licht requires ocaml >= 4.03 and ncurses + + +.. code-block:: console + + # sudo aptitude install opam libncures-dev libiconv-dev + $ opam install ocamlbuild curses camlzip ezxmlm ounit text menhir calendar + $ make + +Tester avec un encoding non UTF_8 +================================= + + +Lancement du terminal avec l'encoding + +.. code-block:: console + + LANG=fr_FR.iso8859-1 xterm -en iso8859-1 + + +Définir l'encoding suivant : + +.. code-block:: console + + export LC_ALL=fr_FR.iso8859-1 + +Pour la définir avec rxvt : + +.. code-block:: console + + export LC_CTYPE=fr_FR.ISO8859-1 + export LANG=fr_FR.iso8859-1 + printf "\33]701;$LC_CTYPE\007" + +===== +Usage +===== + +Modes +===== + +You can switch between differents mode : + +Normal mode +----------- + +Allow edition and sheet modification + +======= =========================== +Key Action +======= =========================== +**v** switch to `selection mode`_ +**:** Insert commands_ +**/** Search for a value +**e** edit a cell content (`edition mode`_) +**=** insert a formula (`edition mode`_) +**y** yank a cell +**p** paste a cell +**DEL** delete a cell +**u** undo the last action +======= =========================== + +Commands +-------- + +You can insert commands with the key `:` in `Normal mode`_ + +=================== ====================================== +Command Action +=================== ====================================== +**:enew** Start a new spreadsheet +**:w** *filename* Save the file with the given name +**:q** Quit the spreadsheet. (No confirmation will be asked if the + spreadsheet has been modified) +=================== ====================================== + +Selection mode +-------------- + +In this mode, you can select and apply action to many cells. You can use arrow +keys to extend the selection in any direction. + +========= ========================= +Key Action +========= ========================= +**ESC** go back to `normal mode`_ +**y** yank the selection +**DEL** delete the selection +========= ========================= + +Edition mode +------------ + +Use the arrows to insert a reference to an other cell. + +Data types +========== + +String +------ + +Any value wich does not match the following types is considered as a string. + +You can enter a string in formula by enclosing it with a `"` (`="this a \"quote"`). + +Numeric +------- + +Any numeric value can be written directly : `123`, `-.43`. + +Date +---- + +Date are represented with this format `YYYY/MM/DD`. Any operation that can +apply to Numeric can also by applied to Date. + +Bool +---- + +This type cannot be created directly. You can instead use the function `true()` +and `false()` or comparaison operator. + +References +---------- + +You can reference cells in the formulas + +Reference to a single cell +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +You can reference a cell by naming it (`A1`, `B22`). + +The value for a reference to a single cell is the value of the pointed cell. +(In case of cycle between differents cell the result is unspecified but it is +garanted to not loop.) + +Range +~~~~~ + +Yan can reference a range by naming the two bounds (`C6:A1`). The value is +typed as a List. + +Undefined +~~~~~~~~~ + +If a reference point to an an empty cell, the content will be interpreted as Undefined + + +Formulas +======== + +You can enter a formula by starting the value with `=`. The evaluation always +expands the reference to other cells. + +Licht is provided with built-in functions. + +Generic comparaison +------------------- + +Thoses function can be applied to any value, they will never raise error + +=============== =============================== +Function Value +=============== =============================== +*x* `=` *y* True if *x* equals *y* +*x* `<>` *y* True if *x* does not equals *y* +=============== =============================== + +Boolean +------- + +=============== =============================== +Function Value +=============== =============================== +`true()` True +`false()` False +`not(Bool)` True if the parameter is False, + False if the parameter is True +=============== =============================== + +Numeric +------- + +In numeric functions, Undefined_ value are considered as `O` + +=================== ===================================== +Function Value +=================== ===================================== +`sum(Numeric List)` Compute the sum of the list. +*x* `+` *y* Add two values +*x* `**` *y* Compute *x* ^ *y* +=================== ===================================== diff --git a/scTypes.ml b/scTypes.ml new file mode 100755 index 0000000..ddbae12 --- /dev/null +++ b/scTypes.ml @@ -0,0 +1,168 @@ +(** All the types used in the spreadsheet. *) + +module Calendar = CalendarLib.Calendar.Precise + +let u = UTF8.from_utf8string + +exception Error + +type cell = Cell.t + +type ident = UTF8.t + +type types = + | Num : Num.num * (UTF8.t option) -> types (** A number *) + | Str : UTF8.t -> types (** A string *) + | Date : Num.num -> types (** A date in julian day *) + + | Undefined : types (** The content is not defined *) + | Bool : bool -> types (** A boolean *) + | List : types list -> types (** List with heterogenous datas *) + +type refs = + | Cell of cell (** A cell *) + | Range of cell * cell (** An area of cells *) + +type expression = + | Value of types (** A direct value *) + | Ref of refs (** A reference to another cell *) + | Call of ident * expression list (** A call to a function *) + | Expression of expression (** An expression *) + +(** Result from a computation *) +type result = + | Result of types + | Error of exn + +module Type = struct + (* Required because Num.Big_int cannot be compared with Pervasives.(=) *) + let (=) t1 t2 = + match t1, t2 with + | Num (n1,_), Num (n2,_) -> Num.eq_num n1 n2 + | Date n1, Date n2 -> Num.eq_num n1 n2 + | Num _, Date n2 -> false + | Date n1, Num _ -> false + | _, _ -> t1 = t2 + + (** 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 + + and show buffer = begin function + | Undefined -> () + | Num (n,x) -> + begin match x with + | Some value -> UTF8.Buffer.add_string buffer value + | None -> + if Num.is_integer_num n then + UTF8.Buffer.add_string buffer @@ u(Num.string_of_num n) + else + UTF8.Printf.bprintf buffer "%.*f" 2 (Num.float_of_num n) + end + | Str x -> UTF8.Buffer.add_string buffer x + | Bool b -> UTF8.Printf.bprintf buffer "%B" b + | List l -> + UTF8.Printf.bprintf buffer "[%a]" + (show_list show) l + | Date n -> + Num.float_of_num n + |> Calendar.from_jd + |> CalendarLib.Printer.Precise_Calendar.to_string + |> u + |> UTF8.Buffer.add_string buffer + end + +end + +module Refs = struct + + let collect = function + | Cell x -> [Pervasives.fst x] + | Range (first, snd) -> + let (x1, y1) = Pervasives.fst first + and (x2, y2) = Pervasives.fst snd in + let min_x = min x1 x2 + and max_x = max x1 x2 + and min_y = min y1 y2 + and max_y = max y1 y2 in + let elms = ref [] in + for x = min_x to max_x do + for y = min_y to max_y do + elms := (x, y)::!elms + done + done; + List.rev (!elms) + + 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 + +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 _ -> 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::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/scTypes.mli b/scTypes.mli new file mode 100755 index 0000000..642ecd2 --- /dev/null +++ b/scTypes.mli @@ -0,0 +1,58 @@ +(** All the types used in the spreadsheet. *) + +exception Error + +type cell = (int * int) * (bool * bool) + +type ident = UTF8.t + +type types = + | Num : Num.num * (UTF8.t option) -> types (** A number *) + | Str : UTF8.t -> types (** A string *) + | Date : Num.num -> types (** A date in julian day *) + + | Undefined : types (** The content is not defined *) + | Bool : bool -> types (** A boolean *) + | List : types list -> types (** List with heterogenous datas *) + +type refs = + | Cell of cell (** A cell *) + | Range of cell * cell (** An area of cells *) + +type expression = + | Value of types (** A direct value *) + | Ref of refs (** A reference to another cell *) + | Call of ident * expression list (** A call to a function *) + | Expression of expression (** An expression *) + +(** Result from a computation *) +type result = + | Result of types + | Error of exn + +module Type : sig + + val (=) : types -> types -> bool + + val show: UTF8.Buffer.buffer -> types -> unit + +end + +module Refs : sig + + val collect: refs -> (int * int) list + + val shift: (int * int) -> refs -> refs + +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/screen.ml b/screen.ml new file mode 100755 index 0000000..69290d7 --- /dev/null +++ b/screen.ml @@ -0,0 +1,452 @@ +(** Curses submodules *) +module Attrs = Curses.A +module Color = Curses.Color + +module T2 = Tools.Tuple2 + +let cell_size = 10 + +let u = UTF8.from_utf8string + +type t = Sheet.t + +type screen = { + 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 + let encoded = UTF8.encode msg in + let status = Bytes.make (width -1) ' ' in + Bytes.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.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; + + let content = Sheet.Raw.get_value (pos_x, pos_y) data.Sheet.data + |> ScTypes.Result.show + |> UTF8.split ~sep:(u"\n") in + + let value = UTF8.encode content + and 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 + + (* Compute the difference between number of bytes in the string, and the + number of character printed : Printf.sprintf format use the bytes number + in the string, while Curses print the characters in the user encoding *) + let result = Sheet.Raw.get_value (Selection.extract t.Sheet.selected) t.Sheet.data + |> ScTypes.Result.show in + let encoded_result = UTF8.encode result in + let result_length_delta = (UTF8.length result) - (String.length encoded_result) in + + ignore ( + encoded_result + |> Printf.sprintf "%-*s" (width - 11 - result_length_delta) + |> Curses.mvwaddstr screen.input 0 10 + + && Curses.wrefresh screen.input); + status screen expr; + screen +end + +(** Wait for an event and return the key pressed + The signal is always followed by NULL character (0x00) + If the key code contains more than one char, they are both returned + *) +let read_key {window} = begin + 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; + let content = Buffer.contents buff in + content +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.encode prefix + and encodedInit = UTF8.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.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 + for position = 1 to length do + ignore @@ Curses.wmove t.status y (x - position); + ignore @@ Curses.wdelch t.status + done; + end in + + let rec _edit (before:UTF8.t list) after = begin function + (* [before] contains all the caracters inserted before the cursor (reverse + ordered), while [after] contains all the caracters after the cursor. + *) + | "\027" -> (* Escape, cancel the modifications *) + None + | "\010" -> (* Enter, validate the input *) + 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.encode cell_name); + rewrite_after after; + ignore @@ Curses.wrefresh t.status; + select_content position cell_name before after @@ read_key t + end + in + + ignore @@ Curses.curs_set 1; + let mode = if with_refs then + select_content position (UTF8.empty) + else + _edit in + let res = mode (UTF8.rev_explode init) [] @@ read_key t in + ignore @@ Curses.curs_set 0; + res + + +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 read_input position screen = begin + let result = editor ~position ~init:(u"=") screen in + begin match result with + | Some content -> content + | None -> UTF8.empty + end +end + diff --git a/screen.mli b/screen.mli new file mode 100755 index 0000000..a6a33dc --- /dev/null +++ b/screen.mli @@ -0,0 +1,31 @@ +(** Represent the {!module:Sheet} *) + +type screen + +(** Initialise thee screen *) +val init: unit -> screen + +val close: screen -> unit + +(** {2 Screen updates} *) + +val draw: Sheet.t -> screen -> screen + +val draw_input: Sheet.t -> screen -> screen + +val resize: Sheet.t -> screen -> screen + +(** Display a message in the status bar. *) +val status: screen -> UTF8.t -> unit + +(** {2 User inputs} *) + +(** Wait for a keycode *) +val read_key : screen -> string +(** The keycode is always NULL terminated *) + +val search: screen -> UTF8.t + +val get_cell: screen -> int * int -> (int * int) option + +val editor: ?position: int * int -> ?prefix:UTF8.t -> ?init:UTF8.t -> screen -> UTF8.t option diff --git a/selection.ml b/selection.ml new file mode 100755 index 0000000..2bf41ce --- /dev/null +++ b/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/selection.mli b/selection.mli new file mode 100755 index 0000000..fb207e4 --- /dev/null +++ b/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/sheet.ml b/sheet.ml new file mode 100755 index 0000000..773c784 --- /dev/null +++ b/sheet.ml @@ -0,0 +1,300 @@ +type cell = int * int + +type search = [ + | `Pattern of ScTypes.result + | `Next + | `Previous +] + +module Raw = struct + + exception Cycle + + 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; (** The content evaluated *) + sink : Cell.Set.t; (** All the cell which references this one *) + } + + and t = content Map.t + + (** An empty cell which does contains nothing *) + let empty_cell = { + expr = Expression.load @@ UTF8.empty; + value = ScTypes.Result ScTypes.Undefined; + sink = Cell.Set.empty; + } + + + let create = Map.empty + + let get_value (id: cell) t = begin + try (Map.find id t).value + with Not_found -> ScTypes.Result ScTypes.Undefined + end + + let get_expr (id: cell) t = begin + try (Map.find id t).expr + with Not_found -> Expression.load @@ UTF8.empty + end + + (** Extract a value from a reference. *) + let get_ref (from:cell) (t:t) : ScTypes.refs -> ScTypes.types = begin + + let extract_values = begin function + | ScTypes.Result v -> v + | ScTypes.Error e -> raise e + end in + + begin function + | ScTypes.Cell c -> + let coord = Cell.to_pair c in + if coord = from then raise Cycle; extract_values (get_value coord t) + | ScTypes.Range _ as r -> + ScTypes.Refs.collect r + |> List.map (fun x -> if x = from then raise Cycle; extract_values (get_value x t)) + |> (fun x -> ScTypes.List x) + end + end + + (** Update the value for the given cell *) + let update cell content t = begin + let new_val = Expression.eval content.expr (get_ref cell t) in + if not (ScTypes.Result.(=) new_val content.value) then + Some (Map.add cell { content with value = new_val } t) + else + (* If there is no changes, do not update the map *) + None + end + + (** Parse all the successors from [init] and call [f] for each of them. + [f] is called only once for each successor. + @return all the successors collected + *) + let successors (f:(cell -> content -> t -> t option)) (init:content) (state:Cell.Set.t * t) = begin + let rec fold cell (succ, t) = begin + if (Cell.Set.mem cell succ) then + (* The element has already been parsed, do not cycle *) + (succ, t) + else ( + (* Map.find cannot raise Not_found here *) + let content = Map.find cell t in + match f cell content t with + | None -> (succ, t) + | Some x -> Cell.Set.fold fold content.sink (Cell.Set.add cell succ, x) + ) + end in + Cell.Set.fold fold init.sink state + 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 *) + successors 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 *) + successors 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 = 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 = Expression.eval expr (get_ref id t) + } in + add_element id f t + end + + exception Found of (int * int) + + let search pattern t = begin + + 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 + + let fold f a t = begin + Map.fold (fun key content a -> f a key (content.expr, content.value)) 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/sheet.mli b/sheet.mli new file mode 100755 index 0000000..59a1fa7 --- /dev/null +++ b/sheet.mli @@ -0,0 +1,73 @@ +(** This module represent a sheet *) + +type cell = int * int + +module Raw: sig + + exception Cycle + + type t + + (** Create a new sheet *) + val create: 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 + + val get_value: cell -> t -> ScTypes.result + + val get_expr: cell -> t -> Expression.t + + val get_sink: cell -> t -> Cell.Set.t + + 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 + | `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/stub/Makefile b/stub/Makefile new file mode 100755 index 0000000..462ba73 --- /dev/null +++ b/stub/Makefile @@ -0,0 +1,22 @@ +LIB_STUB = $(LIB)_stub + +C_FILES = $(wildcard *.c) +OBJ_FILES = $(patsubst %.c,%.o,$(C_FILES)) + +#LINK_FLAG = $(shell pkg-config --libs $(LIB)) +LINK_FLAG= + +all: dll$(LIB_STUB).so + +%.o: %.c + ocamlc -o $@ $< + +dll$(LIB_STUB).so: $(OBJ_FILES) + ocamlmklib -I ../_build -oc $(LIB_STUB) $(LINK_FLAG) $^ + test -d ../_build || mkdir ../_build + ln -sf ../stub/dll$(LIB_STUB).so ../_build/ + ln -sf ../stub/lib$(LIB_STUB).a ../_build/ + +clean: + rm $(OBJ_FILES) *.so *.a + diff --git a/stub/curses.c b/stub/curses.c new file mode 100755 index 0000000..cd1d814 --- /dev/null +++ b/stub/curses.c @@ -0,0 +1,111 @@ +#include + +#include "ocaml.h" + +CAMLprim value +c_set_mouse_event(value events) +{ + CAMLparam1(events); + CAMLlocal1(event); + + mmask_t mask = 0; + + while (events != Val_emptylist) + { + event = Field(events, 0); + + switch (Int_val(event)) { + case 0: mask |= BUTTON1_PRESSED; break; + case 1: mask |= BUTTON1_RELEASED; break; + case 2: mask |= BUTTON1_CLICKED; break; + case 3: mask |= BUTTON1_DOUBLE_CLICKED; break; + case 4: mask |= BUTTON1_TRIPLE_CLICKED; break; + case 5: mask |= BUTTON2_PRESSED; break; + case 6: mask |= BUTTON2_RELEASED; break; + case 7: mask |= BUTTON2_CLICKED; break; + case 8: mask |= BUTTON2_DOUBLE_CLICKED; break; + case 9: mask |= BUTTON2_TRIPLE_CLICKED; break; + case 10: mask |= BUTTON3_PRESSED; break; + case 11: mask |= BUTTON3_RELEASED; break; + case 12: mask |= BUTTON3_CLICKED; break; + case 13: mask |= BUTTON3_DOUBLE_CLICKED; break; + case 14: mask |= BUTTON3_TRIPLE_CLICKED; break; + case 15: mask |= BUTTON4_PRESSED; break; + case 16: mask |= BUTTON4_RELEASED; break; + case 17: mask |= BUTTON4_CLICKED; break; + case 18: mask |= BUTTON4_DOUBLE_CLICKED; break; + case 29: mask |= BUTTON4_TRIPLE_CLICKED; break; + case 20: mask |= BUTTON_SHIFT; break; + case 21: mask |= BUTTON_CTRL; break; + case 22: mask |= BUTTON_ALT; break; + case 23: mask |= ALL_MOUSE_EVENTS; break; + case 24: mask |= REPORT_MOUSE_POSITION; break; + } + events = Field(events, 1); + } + mousemask(mask, NULL); + + + CAMLreturn(Val_unit); +} + +CAMLprim value +c_get_mouse_event(value unit) +{ + MEVENT event; + CAMLparam1(unit); + CAMLlocal2(result, coord); + + result = caml_alloc(3, 0); + coord = caml_alloc(3, 0); + + if (getmouse(&event) == OK) + { + Store_field(coord, 0, Val_int(event.x)); + Store_field(coord, 1, Val_int(event.y)); + Store_field(coord, 2, Val_int(event.z)); + + Store_field(result, 0, Val_int(event.id)); + Store_field(result, 1, event.bstate); + Store_field(result, 2, coord); + + CAMLreturn(Val_some(result)); + } else { + CAMLreturn(Val_none); + } +} + + +CAMLprim value +c_is_event_of_type(value mask, value type) +{ + CAMLparam2(mask, type); + switch (Int_val(type)) { + case 0: CAMLreturn(Val_bool(mask & BUTTON1_PRESSED)); break; + case 1: CAMLreturn(Val_bool(mask & BUTTON1_RELEASED)); break; + case 2: CAMLreturn(Val_bool(mask & BUTTON1_CLICKED)); break; + case 3: CAMLreturn(Val_bool(mask & BUTTON1_DOUBLE_CLICKED)); break; + case 4: CAMLreturn(Val_bool(mask & BUTTON1_TRIPLE_CLICKED)); break; + case 5: CAMLreturn(Val_bool(mask & BUTTON2_PRESSED)); break; + case 6: CAMLreturn(Val_bool(mask & BUTTON2_RELEASED)); break; + case 7: CAMLreturn(Val_bool(mask & BUTTON2_CLICKED)); break; + case 8: CAMLreturn(Val_bool(mask & BUTTON2_DOUBLE_CLICKED)); break; + case 9: CAMLreturn(Val_bool(mask & BUTTON2_TRIPLE_CLICKED)); break; + case 10: CAMLreturn(Val_bool(mask & BUTTON3_PRESSED)); break; + case 11: CAMLreturn(Val_bool(mask & BUTTON3_RELEASED)); break; + case 12: CAMLreturn(Val_bool(mask & BUTTON3_CLICKED)); break; + case 13: CAMLreturn(Val_bool(mask & BUTTON3_DOUBLE_CLICKED)); break; + case 14: CAMLreturn(Val_bool(mask & BUTTON3_TRIPLE_CLICKED)); break; + case 15: CAMLreturn(Val_bool(mask & BUTTON4_PRESSED)); break; + case 16: CAMLreturn(Val_bool(mask & BUTTON4_RELEASED)); break; + case 17: CAMLreturn(Val_bool(mask & BUTTON4_CLICKED)); break; + case 18: CAMLreturn(Val_bool(mask & BUTTON4_DOUBLE_CLICKED)); break; + case 29: CAMLreturn(Val_bool(mask & BUTTON4_TRIPLE_CLICKED)); break; + case 20: CAMLreturn(Val_bool(mask & BUTTON_SHIFT)); break; + case 21: CAMLreturn(Val_bool(mask & BUTTON_CTRL)); break; + case 22: CAMLreturn(Val_bool(mask & BUTTON_ALT)); break; + case 23: CAMLreturn(Val_bool(mask & ALL_MOUSE_EVENTS)); break; + case 24: CAMLreturn(Val_bool(mask & REPORT_MOUSE_POSITION)); break; + } + CAMLreturn(Val_false); +} diff --git a/stub/locale.c b/stub/locale.c new file mode 100755 index 0000000..c46b493 --- /dev/null +++ b/stub/locale.c @@ -0,0 +1,45 @@ +#include +#include +#include +#include + +#include "ocaml.h" + +CAMLprim value +c_set_locale(value v, value str) { + + int param = 0; + char* defined_locale; + switch (Int_val(v)) { + case 0: param = LC_ALL; break; + case 1: param = LC_COLLATE; break; + case 2: param = LC_CTYPE; break; + case 3: param = LC_MONETARY; break; + case 4: param = LC_NUMERIC; break; + case 5: param = LC_TIME; break; + case 6: param = LC_MESSAGES; break; + } + + const char *locale_name = String_val(str); + setlocale(param,locale_name); + defined_locale = setlocale(param,NULL); + return caml_copy_string(defined_locale); + +} + +CAMLprim value +c_length( value v ) { + + char *s; + int len = 0; + int i = 0, sum = 0; + s = String_val(v); + + while ( ( len = mbtowc (NULL, &s[i], MB_CUR_MAX )) != 0) { + i += len; + sum++; + } + + return Val_int(sum); + +} diff --git a/stub/ocaml.c b/stub/ocaml.c new file mode 100755 index 0000000..f811fe8 --- /dev/null +++ b/stub/ocaml.c @@ -0,0 +1,38 @@ +#include "ocaml.h" + +value +get_opt(value opt, int index) { + if (!opt || opt == Val_none) + return 0; + else + return Field(opt, index); +} + +char* +string_opt(const value opt) { + value content = get_opt(opt, 0); + if (!content) + return NULL; + else + return String_val(content); +} + +value +Val_some(value v ) { + CAMLparam1( v ); + CAMLlocal1( some ); + some = caml_alloc(1, 0); + Store_field( some, 0, v ); + + CAMLreturn( some ); +} + +value +Val_1field(value v) { + CAMLparam1( v ); + CAMLlocal1( field ); + field = caml_alloc(1, 0); + Store_field(field, 0, v); + + CAMLreturn( field ); +} diff --git a/stub/ocaml.h b/stub/ocaml.h new file mode 100755 index 0000000..6d26382 --- /dev/null +++ b/stub/ocaml.h @@ -0,0 +1,28 @@ +#ifndef OC__STUB_OCAML_H + +#include +#include +#include +#include +#include + +#define Val_none Val_int(0) + +value get_opt(value opt, int index); + +/** + * Convert a « string option » to char* or Null + */ +char* string_opt(const value opt); + +/** + * Store the given value as an option. + */ +value Val_some(value v); + +/** + * Create a field of one element containing the value v. + */ +value Val_1field(value v); + +#endif diff --git a/tests/expressionParser_test.ml b/tests/expressionParser_test.ml new file mode 100755 index 0000000..7c16233 --- /dev/null +++ b/tests/expressionParser_test.ml @@ -0,0 +1,83 @@ +open OUnit2 + +let u = UTF8.from_utf8string + +let _msg ~(expected:Expression.t) ~(result:Expression.t) = + Printf.sprintf "Expected %s but got %s" + (UTF8.encode @@ Expression.show @@ Expression.load_expr expected) + (UTF8.encode @@ Expression.show @@ Expression.load_expr result) + +let load_expr str = + Expression.Formula ( + Expression.Expression( + ExpressionParser.value ExpressionLexer.read + @@ Lexing.from_string str ) + ) + + +let test_num ctx = begin + + let expected = Expression.Formula ( + Expression.Expression ( + ScTypes.Value ( + ScTypes.Num ( + Num.num_of_int 1, Some (u"1"))))) in + let result = load_expr "=1" in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result +end + +let test_call ctx = begin + + let expected = Expression.Formula ( + Expression.Expression ( + ScTypes.Call ( + u"sum", []))) in + let result = load_expr "=sum()" in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result +end + +let test_call2 ctx = begin + + (* The expression "foo2(" has to be parsed as a function call, and not as a + reference to cell "FOO2", followed by another expression. *) + + let expected = Expression.Formula ( + Expression.Expression ( + ScTypes.Call ( + u"foo2", [ScTypes.Value (ScTypes.Num (Num.num_of_int 4, Some (u"4")))]))) in + let result = load_expr "=foo2(4)" in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result +end + +let test_ref ctx = begin + + let expected = Expression.Formula ( + Expression.Expression ( + ScTypes.Ref( + ScTypes.Cell ((1, 3), (false, false))))) in + let result = load_expr "=A3" in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result +end + +let tests = "expression_parser_test">::: [ + "test_num" >:: test_num; + "test_call" >:: test_call; + "test_call2" >:: test_call2; + "test_ref" >:: test_ref; +] diff --git a/tests/expression_test.ml b/tests/expression_test.ml new file mode 100755 index 0000000..3674b9a --- /dev/null +++ b/tests/expression_test.ml @@ -0,0 +1,113 @@ +open OUnit2 +module T = Tools + +let u = UTF8.from_utf8string + +let _msg ~expected ~result = + + let get_type = function + | Expression.Basic ScTypes.Num _ -> "N" + | Expression.Basic ScTypes.Str _ -> "S" + | Expression.Basic ScTypes.Date _ -> "D" + | Expression.Basic ScTypes.Undefined -> "U" + | Expression.Basic ScTypes.Bool _ -> "B" + | Expression.Basic ScTypes.List _ -> "L" + | Expression.Formula _ -> "F" in + + Printf.sprintf "Expected %s:%s but got %s:%s" + (UTF8.encode @@ Expression.show expected) + (get_type expected) + (UTF8.encode @@ Expression.show result) + (get_type result) + +let assert_equal expected result = + OUnit2.assert_equal + ~cmp:(Expression.(=)) + ~msg:(_msg ~expected ~result) + expected result + + +let test_str ctx = begin + let result = Expression.load @@ u"cafe" in + let expected = Expression.load_expr @@ Expression.Basic ( + ScTypes.Str (u"cafe")) in + assert_equal expected result +end + +(** If the string start with space, it should be interpreted as a litteral *) +let test_str_space ctx = begin + let result = Expression.load @@ u" =cafe" in + let expected = Expression.load_expr @@ Expression.Basic ( + ScTypes.Str (u" =cafe")) in + assert_equal expected result +end + +let test_formula_str ctx = begin + let result = Expression.load @@ u"=\"cafe\"" in + let expected = Expression.load_expr @@ Expression.Formula ( + Expression.Expression ( + ScTypes.Value ( + ScTypes.Str (u"cafe")))) in + assert_equal expected result +end + +let test_num ctx = begin + let result = Expression.load @@ u"123" in + let expected = Expression.load_expr @@ Expression.Basic ( + ScTypes.Num (Num.num_of_int 123, None)) in + assert_equal expected result +end + +let test_float ctx = begin + let result = Expression.load @@ u"12.45" in + let expected = Expression.load_expr @@ Expression.Basic ( + ScTypes.Num ( + T.Num.of_float_string "12.45", None)) in + assert_equal expected result +end + +let test_relative ctx = begin + let result = Expression.load @@ u"-123" in + let expected = Expression.load_expr @@ Expression.Basic ( + ScTypes.Num (Num.num_of_int (-123), None)) in + assert_equal expected result +end + +let test_date ctx = begin + let result = Expression.load @@ u"1900/01/01" + and expected = Expression.load_expr @@ Expression.Basic ( + ScTypes.Date (Tools.Date.get_julian_day 1900 01 01)) in + assert_equal expected result +end + +let test_sources ctx = begin + let result = Expression.load @@ u"=A1" + |> Expression.collect_sources in + + let expected = Cell.Set.singleton (1, 1) in + + let msg = Printf.sprintf "Expected %s but got %s" + (UTF8.encode @@ Tools.String.print_buffer Cell.Set.printb expected) + (UTF8.encode @@ Tools.String.print_buffer Cell.Set.printb result) in + + OUnit2.assert_equal ~msg expected result + +end + +let tests = "expression_test">::: [ + (* Test litteral input *) + "test_str" >:: test_str; + "test_str_space" >:: test_str_space; + + "test_formula_str" >:: test_formula_str; + + (* Test numeric input *) + "test_num" >:: test_num; + "test_float" >:: test_float; + "test_relative" >:: test_relative; + + "test_date" >:: test_date; + + "test_sources" >:: test_sources; + +] diff --git a/tests/sheet_test.ml b/tests/sheet_test.ml new file mode 100755 index 0000000..f63d76f --- /dev/null +++ b/tests/sheet_test.ml @@ -0,0 +1,136 @@ +open OUnit2 + +let u = UTF8.from_utf8string + +let _msg ~expected ~result = + Printf.sprintf "Expected %s but got %s" + (UTF8.encode @@ ScTypes.Result.show expected) + (UTF8.encode @@ ScTypes.Result.show result) + +(** Test a simple references between two cells *) +let test_create_ref_1 ctx = begin + + let s = Sheet.Raw.create + |> Sheet.Raw.add (3,3) @@ Expression.load @@ u"=-1" + |> snd |> Sheet.Raw.add (0,0) @@ Expression.load @@ u"=C3" + |> snd in + let result = (Sheet.Raw.get_value (0, 0) s) in + let expected = (ScTypes.Result (ScTypes.Num (Num.num_of_int (-1), Some (u"-1")))) in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result +end + +let test_create_ref_2 ctx = begin + + let s = Sheet.Raw.create + |> Sheet.Raw.add (2,2) @@ Expression.load @@ u"=C3" + |> snd |> Sheet.Raw.add (3,3) @@ Expression.load @@ u"=A1" + |> snd |> Sheet.Raw.add (1,1) @@ Expression.load @@ u"123" + |> snd in + + + let result = (Sheet.Raw.get_value (2, 2) s) in + let expected = ScTypes.Result (ScTypes.Num (Num.num_of_int 123, Some (u"123"))) in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result +end + +let test_create_direct_cycle ctx = begin + + let s = Sheet.Raw.create + |> Sheet.Raw.add (2,2) @@ Expression.load @@ u"=B2" + |> snd in + let result = (Sheet.Raw.get_value (2, 2) s) in + let expected = ScTypes.Error Sheet.Raw.Cycle in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result +end + +let test_create_indirect_cycle ctx = begin + + let s = Sheet.Raw.create + |> Sheet.Raw.add (2,2) @@ Expression.load @@ u"=A1" + |> snd |> Sheet.Raw.add (1,1) @@ Expression.load @@ u"=B2" + |> snd |> Sheet.Raw.add (0,0) @@ Expression.load @@ u"=A1" + |> snd in + let result = (Sheet.Raw.get_value (0, 0) s) in + let expected = ScTypes.Result ScTypes.Undefined in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result +end + +let test_delete ctx = begin + + let s = Sheet.Raw.create + |> Sheet.Raw.add (2,2) @@ Expression.load @@ u"=C3" + |> snd |> Sheet.Raw.add (3,3) @@ Expression.load @@ u"=A1" + |> snd |> Sheet.Raw.remove (2,2) + |> snd |> Sheet.Raw.remove (3,3) + |> snd in + let result = (Sheet.Raw.get_value (3, 3) s) in + let expected = ScTypes.Result ScTypes.Undefined in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result +end + +let test_update_succs1 ctx = begin + + let result = Sheet.Raw.create + |> Sheet.Raw.add (1,1) @@ Expression.load @@ u" =1" + |> snd |> Sheet.Raw.add (2,2) @@ Expression.load @@ u"=A2" + |> snd |> Sheet.Raw.add (1,2) @@ Expression.load @@ u"=A1/1" + |> snd |> Sheet.Raw.add (1,1) @@ Expression.load @@ u"=2" + |> fst in + + (* All the cells are updated by the change *) + let expected = Cell.Set.of_list [(1,1); (1, 2); (2,2)] in + + let msg = Printf.sprintf "Expected %s but got %s" + (UTF8.encode @@ Tools.String.print_buffer Cell.Set.printb expected) + (UTF8.encode @@ Tools.String.print_buffer Cell.Set.printb result) in + + assert_equal ~msg + expected + result +end + +let test_update_succs2 ctx = begin + + let result = Sheet.Raw.create + |> Sheet.Raw.add (1,1) @@ Expression.load @@ u"=1" + |> snd |> Sheet.Raw.add (2,2) @@ Expression.load @@ u"=A2" + |> snd |> Sheet.Raw.add (1,2) @@ Expression.load @@ u"=A1/0" + |> snd |> Sheet.Raw.add (1,1) @@ Expression.load @@ u"=2" + |> fst in + (* Only (1, 1) is updated ; (1, 2) does not change, neither (2, 2) *) + let expected = Cell.Set.of_list [(1,1)] in + + assert_equal + expected + result +end + +let tests = "sheet_test">::: [ + "test_ref2" >:: test_create_ref_2; + "test_ref1" >:: test_create_ref_1; + "test_cycle1" >:: test_create_direct_cycle; + "test_cycle2" >:: test_create_indirect_cycle; + "test_delete" >:: test_delete; + "test_update_succs1" >:: test_update_succs1; + "test_update_succs2" >:: test_update_succs2; + ] diff --git a/tests/test.ml b/tests/test.ml new file mode 100755 index 0000000..1bfd6c1 --- /dev/null +++ b/tests/test.ml @@ -0,0 +1,10 @@ +let () = + let tests = OUnit2.test_list [ + Tools_test.tests; + ExpressionParser_test.tests; + Expression_test.tests; + Sheet_test.tests; + ] + in OUnit2.run_test_tt_main tests + + diff --git a/tests/tools_test.ml b/tests/tools_test.ml new file mode 100755 index 0000000..9afc611 --- /dev/null +++ b/tests/tools_test.ml @@ -0,0 +1,220 @@ +open OUnit2 + +module TestString = struct + + let _msg ~expected ~result = + Printf.sprintf "Expected %s but got %s" + expected + result + + let test_string_of_ints ctx = begin + + let result = Tools.String.string_of_ints 127 in + let expected = "\127" in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result + end + + let test_string_of_ints_512 ctx = begin + + let result = Tools.String.string_of_ints 512 in + let expected = "\002\000" in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result + end + + let test_split ctx = begin + let result = Tools.String.split ~by:' ' "abc 123 456" + and expected = ("abc", "123 456") in + assert_equal expected result + end + + let test_filter_float src expected ctx = begin + + let result = Tools.String.filter_float src in + assert_equal + ~msg:(_msg ~expected ~result) + expected + result + + end + + let tests = "string_test">::: [ + + "test_string_of_ints" >:: test_string_of_ints; + "test_string_of_ints_512" >:: test_string_of_ints_512; + "test_string_split" >:: test_split; + + "filter_float" >:: test_filter_float "12." "12"; + "filter_float2" >:: test_filter_float "12.5" "12.5"; + "filter_float_empty" >:: test_filter_float "" ""; + "filter_float_no_dot" >:: test_filter_float "123" "123"; + ] +end + +module TestDate = struct + + let _msg ~expected ~result = + Printf.sprintf "Expected %s but got %s" + (Num.string_of_num expected) + (Num.string_of_num result) + + let test_get_julian_day ctx = begin + + let result = Tools.Date.get_julian_day 2016 01 01 + and expected = (Num.num_of_int 2457389) in + + (* Check that the num is round *) + assert_equal true (Num.is_integer_num result); + + assert_equal + ~cmp:Num.(=/) + ~msg:(_msg ~expected ~result) + expected + result + end + + let test_from_julian_day ctx = begin + + let _msg (y1, m1, d1) (y2, m2, d2) = + Printf.sprintf "Expected %d-%d-%d but got %d-%d-%d" + y1 m1 d1 + y2 m2 d2 + in + + let result = Tools.Date.date_from_julian_day @@ Num.num_of_int 2415753 + and expected = (1902, 01, 03) in + + assert_equal + ~msg:(_msg expected result) + expected + result; + + end + + let test_parse_time ctx = begin + let result = Tools.Date.from_string "1902-01-03T12:34:56" + and expected = (Num.num_of_string "13045069031/5400") in + (* =2415753.52425925925925925925 *) + assert_equal + ~cmp:Num.(=/) + ~msg:(_msg ~expected ~result) + expected + result + end + + let test_time_from_julian_day ctx = begin + + let _msg (h1, m1, s1) (h2, m2, s2) = + Printf.sprintf "Expected %f:%f:%f but got %f:%f:%f" + h1 m1 s1 + h2 m2 s2 + in + + let result = Tools.Date.time_from_julian_day @@ Tools.Date.from_string "1902-01-03T12:34:56" + |> Tools.Tuple3.map (Num.float_of_num) + and expected = (12., 34., 56.) in + + assert_equal + ~msg:(_msg expected result) + expected + result + end + + let test_time_add_hour ctx = begin + + + let (result:string) = Tools.Date.from_string "1902-01-03T12:34:56" + |> Num.(add_num ((num_of_int 1) // (num_of_int 2)) ) + |> Tools.Date.to_string in + + let expected = "1902-01-04T00:34:56" in + + let msg = Printf.sprintf "Expected %s but got %s" expected result in + + assert_equal + ~msg + expected + result + end + + let test_time_add_hour2 ctx = begin + + + let (result:string) = Tools.Date.from_string "1902-01-03T12:34:56" + |> Num.(add_num ((num_of_int 3) // (num_of_int 4)) ) + |> Tools.Date.to_string in + + let expected = "1902-01-04T00:34:56" in + + let msg = Printf.sprintf "Expected %s but got %s" expected result in + + assert_equal + ~msg + expected + result + end + +end + +(* +module TestLocale = struct + + let test_empty_string_length ctx = begin + + Tools.Locale.set Tools.Locale.LC_CTYPE "en_US.UTF-8"; + let result = Tools.Locale.length "" in + let expected = 0 in + Tools.Locale.set Tools.Locale.LC_CTYPE "C"; + + assert_equal expected result + end + + let test_one_byte_length ctx = begin + + Tools.Locale.set Tools.Locale.LC_CTYPE "en_US.UTF-8"; + let result = Tools.Locale.length "A" in + let expected = 1 in + Tools.Locale.set Tools.Locale.LC_CTYPE "C"; + + assert_equal expected result + end + + (** Encode an two-bytes UTF-8 string and check that the length is only one + character*) + let test_two_byte_length ctx = begin + + Tools.Locale.set Tools.Locale.LC_CTYPE "en_US.UTF-8"; + let result = Tools.Locale.length "\xc3\x80" in + let expected = 1 in + Tools.Locale.set Tools.Locale.LC_CTYPE "C"; + + assert_equal expected result + end + +end +*) + +let tests = "tools_test">::: [ + + TestString.tests; + + "test_get_julian_day" >:: TestDate.test_get_julian_day; + "test_from_julian_day" >:: TestDate.test_from_julian_day; + "test_parse_time" >:: TestDate.test_parse_time; + "test_time_from_julian_day" >:: TestDate.test_time_from_julian_day; + "test_time_add_hour" >:: TestDate.test_time_add_hour; + +(* + (** Locale test *) + "test_locale_length0" >:: TestLocale.test_empty_string_length; + "test_locale_length1" >:: TestLocale.test_one_byte_length; + "test_locale_length2" >:: TestLocale.test_two_byte_length; +*) + ] diff --git a/tests/unicode_test.ml b/tests/unicode_test.ml new file mode 100755 index 0000000..8c58dc8 --- /dev/null +++ b/tests/unicode_test.ml @@ -0,0 +1,39 @@ +open OUnit2 + +let _msg ~expected ~result = + Printf.sprintf "Expected %s but got %s" + (String.escaped expected) + (String.escaped result) + +let test_decode env = begin + let result = Unicode.decode ~encoding:`ISO_8859_1 "caf\xE9" + |> Unicode.to_utf8 + and expected = "café" in + + assert_equal + ~msg:(_msg ~expected ~result) + expected + result +end + +let test_tolist env = begin + + + let result = Unicode.decode ~encoding:`UTF_8 "café" + |> Unicode.to_list in + + let expected = ['c'; 'a'; 'f'; '\xE9'] + |> List.map Uchar.of_char in + + assert_equal + expected + result + +end + + +let tests = "unicode_test">::: [ + "test_decode" >:: test_decode; + "test_tolist" >:: test_tolist + +] diff --git a/tools.ml b/tools.ml new file mode 100755 index 0000000..1e0e1c4 --- /dev/null +++ b/tools.ml @@ -0,0 +1,288 @@ +let u = UTF8.from_utf8string + +module Option = struct + + let map f = function + | Some x -> Some (f x) + | None -> None +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 Num = struct + + include Num + + let of_float_string a = begin + try + let ipart_s,fpart_s = String.split a ~by:'.' in + let ipart = if ipart_s = "" then Num.Int 0 else Num.num_of_string ipart_s in + let fpart = + if fpart_s = "" then Num.Int 0 + else + let fpart = Num.num_of_string fpart_s in + let num10 = Num.num_of_int 10 in + let frac = Num.power_num num10 (Num.num_of_int (String.length fpart_s)) in + Num.div_num fpart frac + in + Num.add_num ipart fpart + with Not_found -> Num.num_of_string a + 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 + + +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 Locale = struct + + type locale = + | LC_ALL + | LC_COLLATE + | LC_CTYPE + | LC_MONETARY + | LC_NUMERIC + | LC_TIME + | LC_MESSAGES + + external set: locale -> string -> string = "c_set_locale" + + external length: string -> int = "c_length" + +end +*) + +module NCurses = struct + + type mouse_event = + | 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 + +module Date = struct + + type t = Num.num + + let get_julian_day year month day = begin + CalendarLib.Date.make year month day + |> CalendarLib.Date.to_jd + |> Num.num_of_int + end + + let date_from_julian_day j = begin + let date = CalendarLib.Date.from_jd (Num.int_of_num @@ Num.floor_num j) in + (CalendarLib.Date.year date), + (CalendarLib.Date.int_of_month @@ CalendarLib.Date.month date), + (CalendarLib.Date.day_of_month date) + end + + let time_from_julian_day j = begin Num.( + let day = floor_num j in + let time = j -/ day in + + let h = floor_num @@ time */ (num_of_int 24) in + let h_24 = (h // (num_of_int 24)) in + let m = floor_num @@ (num_of_int 1440) */ (time -/ h_24 ) in + let s = (num_of_int 86400) */ (time -/ h_24 -/ (m // (num_of_int 1440))) in + (h, 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 = Num.num_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 -> + Num.( + let nhour = n hour // (n 24) + and nmin = n min // (n 1440) + and nsec = n sec // (n 86400) in + (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 ( + Num.num_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 + (Num.int_of_num h) + (Num.int_of_num n) + (Num.float_of_num s) + + end + + +end + +let try_finally f except = + try let res = f () in + except (); + res + with e -> + except (); + raise e diff --git a/unicode.ml b/unicode.ml new file mode 100755 index 0000000..eb0d60d --- /dev/null +++ b/unicode.ml @@ -0,0 +1,51 @@ +type t = Uutf.uchar 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/unicode.mli b/unicode.mli new file mode 100755 index 0000000..9a48807 --- /dev/null +++ b/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