diff options
Diffstat (limited to 'screen.ml')
| -rwxr-xr-x | screen.ml | 452 |
1 files changed, 452 insertions, 0 deletions
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 + |