From a6b5a6bdd138a5ccc6827bcc73580df1e9218820 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Fri, 24 Nov 2017 09:22:24 +0100 Subject: Moved all the code to src directory --- screen.ml | 459 -------------------------------------------------------------- 1 file changed, 459 deletions(-) delete mode 100755 screen.ml (limited to 'screen.ml') diff --git a/screen.ml b/screen.ml deleted file mode 100755 index c61efea..0000000 --- a/screen.ml +++ /dev/null @@ -1,459 +0,0 @@ -(** Curses submodules *) -module Attrs = Curses.A -module Color = Curses.Color - -module T2 = Tools.Tuple2 - -module Option = Tools.Option - -let cell_size = 10 - -let u = UTF8.from_utf8string - -type t = { - window: Curses.window; (* the main window *) - sheet: Curses.window; (* the spreadsheet *) - input: Curses.window; (* the input window *) - status: Curses.window; (* status bar *) - start: (int * int); (* Left corner *) - left_margin: int; (* Reserved margin for rows name *) - - mutable size: int * int; (* Terminal size *) -} - -let get_cell screen (x, y) = begin - - let x' = (fst screen.start) + (x - screen.left_margin) / cell_size - and y' = (snd screen.start) + y - 3 in - - if (x' < 1 || y' < 1) then - None - else - Some (x', y') -end - -let center data screen height width = begin - let height' = height - 3 - and width' = (width - screen.left_margin) / cell_size in - let end_x = (fst screen.start) + width' -1 in - let end_y = (snd screen.start) + height' -2 in - - let selected = Selection.extract data.Sheet.selected in - - let center_axis f replace max_limit shift screen = begin - let selected_axis = f selected in - match (selected_axis >= f screen.start), (selected_axis > max_limit) with - | true, false -> screen - | _ -> { screen with start = replace (max 1 (selected_axis - shift)) screen.start } - end in - center_axis T2.fst T2.replace1 end_x (width' / 2) screen - |> center_axis T2.snd T2.replace2 end_y (height' / 2) -end - -let status screen msg = begin - let height, width = screen.size in - UTF8.encode msg |> Option.iter (fun encoded -> - let status = Bytes.make (width -1) ' ' in - String.blit encoded 0 status 0 (String.length encoded); - Curses.werase screen.status; - if not ( - Curses.mvwaddstr screen.status 0 0 encoded - && Curses.wrefresh screen.status - ) then - raise (Failure "Status update") - ) -end - -(** Draw the spreadsheet *) -let draw data screen = begin - - let selected = Selection.extract data.Sheet.selected in - - let referenced = - Sheet.Raw.get_expr selected data.Sheet.data - |> Expression.collect_sources - - and sink = Sheet.Raw.get_sink selected data.Sheet.data in - - let height, width = screen.size in - let screen = center data screen height width in - - for y = 1 to (height-2) do - let pos_y = (y + (snd screen.start) - 1) in - if (Curses.has_colors ()) then begin - if Selection.is_selected (Selection.Vertical pos_y) data.Sheet.selected then - Curses.wattrset screen.sheet (Attrs.color_pair 2 ) - else - Curses.wattrset screen.sheet (Attrs.color_pair 1 ) - end; - ignore - @@ Curses.mvwaddstr screen.sheet y 0 - @@ Printf.sprintf "%-*d" screen.left_margin pos_y - done; - Curses.wattrset screen.sheet Attrs.normal; - - for x = 0 to ((width - cell_size - screen.left_margin) / cell_size) do - let pos_x = x + (fst screen.start) in - if (Curses.has_colors ()) then begin - if Selection.is_selected (Selection.Horizontal pos_x) data.Sheet.selected then - Curses.wattrset screen.sheet (Attrs.color_pair 2 ) - else - Curses.wattrset screen.sheet (Attrs.color_pair 1 ) - end; - - ignore - @@ Curses.mvwaddstr screen.sheet 0 (x * cell_size + screen.left_margin) - @@ Printf.sprintf "%-*s" cell_size (UTF8.raw_encode @@ Cell.to_hname pos_x); - - Curses.wattrset screen.sheet Attrs.normal; - - for y = 1 to (height-2) do - - let pos_y = y + (snd screen.start) - 1 in - - if (Curses.has_colors ()) then begin - if Selection.is_selected (Selection.Cell (pos_x, pos_y)) data.Sheet.selected then - Curses.wattrset screen.sheet (Attrs.color_pair 3 ) - else if Cell.Set.mem (pos_x, pos_y) referenced then - Curses.wattrset screen.sheet (Attrs.color_pair 4 ) - else if Cell.Set.mem (pos_x, pos_y) sink then - Curses.wattrset screen.sheet (Attrs.color_pair 5 ) - else - Curses.wattrset screen.sheet Attrs.normal; - end; - - - (* Get the content from the cell *) - let content = Sheet.Raw.get_value (pos_x, pos_y) data.Sheet.data - |> Option.map (fun x -> UTF8.split ~sep:(u"\n") (ScTypes.Result.show x)) - |> Option.default UTF8.empty in - - (* If the content is defined, try to encode it and print it*) - UTF8.encode content |> Tools.Option.iter (fun value -> - let length = UTF8.length content in - let strlength = String.length value in - let blank = cell_size - length in - let padding = if blank > 0 - then String.make blank ' ' - else "" in - ignore - @@ Curses.mvwaddnstr screen.sheet y (x * cell_size + screen.left_margin) - (Printf.sprintf "%s%s" value padding) - 0 (blank + strlength) - ) - done - done; - ignore @@ Curses.wrefresh screen.sheet; - screen - -end - -let init () = begin - (* Do not set delay after ESC keycode *) - begin try ignore @@ Unix.getenv "ESCDELAY" with - | Not_found -> Unix.putenv "ESCDELAY" "25" end; - - let window = Curses.initscr () in - let height, width = Curses.getmaxyx window in - - Tools.NCurses.set_mouse_event (Tools.NCurses.BUTTON1_CLICKED::[]); - - let init = Curses.keypad window true - && Curses.noecho () - && Curses.start_color () - && Curses.use_default_colors () - - (* Build the color map *) - && Curses.init_pair 1 Color.white Color.blue (* Titles *) - && Curses.init_pair 2 Color.blue Color.white (* Selected titles *) - && Curses.init_pair 3 Color.black Color.white (* Selected cell *) - && Curses.init_pair 4 Color.black Color.red (* referenced cell *) - && Curses.init_pair 5 Color.black Color.green (* sink cell *) - && Curses.curs_set 0 in - - if not init then - raise (Failure "Initialisation") - else - { - window = window; - input = Curses.subwin window 2 width 0 0; - sheet = Curses.subwin window (height - 3) width 2 0; - status = Curses.subwin window 1 width (height - 1) 0; - start = 1, 1; - left_margin = 4; - size = height, width; - } -end - -let close {window} = begin - ignore @@ (Curses.keypad window false && Curses.echo ()); - Curses.endwin() -end - -let draw_input t screen = begin - - let height, width = screen.size in - - let expr = Sheet.Raw.get_expr (Selection.extract t.Sheet.selected) t.Sheet.data - |> Expression.show in - - let result = Sheet.Raw.get_value (Selection.extract t.Sheet.selected) t.Sheet.data - |> Option.map ScTypes.Result.show - |> Option.default UTF8.empty in - - UTF8.encode result |> Option.iter (fun encoded_result -> - (* Compute the difference between number of bytes in the string, and the - number of character printed : Printf.sprintf format use the bytes number - in the string, while Curses print the characters in the user encoding *) - let result_length_delta = (UTF8.length result) - (String.length encoded_result) in - - ignore ( - encoded_result - |> Printf.sprintf "%-*s" (width - 11 - result_length_delta) - |> Curses.mvwaddstr screen.input 0 10 - - && Curses.wrefresh screen.input) - ); - status screen expr; - screen -end - -(** Wait for an event and return the key pressed - If the key code contains more than one char, they are both returned - *) -let read_key {window} = begin - let buff = Buffer.create 2 in - let int_val = Curses.wgetch window in - if int_val > 255 then - Buffer.add_string buff @@ Tools.String.string_of_ints int_val - else - Buffer.add_char buff @@ char_of_int int_val; - (** Check for a second key code *) - ignore @@ Curses.nodelay window true; - begin match Curses.wgetch window with - | -1 -> () - | x -> Buffer.add_char buff @@ char_of_int x; - end; - ignore @@ Curses.nodelay window false; - Buffer.contents buff -end - -let resize data t = begin - let size = Curses.getmaxyx t.window in - if (size <> t.size) then ( - let height, width = size in - t.size <- size; - ignore ( - Curses.wresize t.input 2 width - - && Curses.wresize t.sheet (height - 3) width - - (* The status window *) - && Curses.wresize t.status 1 width - && Curses.mvwin t.status (height - 1) 0); - Curses.wclear t.status; - ignore @@ Curses.wrefresh t.status; - draw data t - ) else t -end - -let editor ?position ?(prefix=UTF8.empty) ?(init=UTF8.empty) t = begin - let encodedPrefix = UTF8.raw_encode prefix - and encodedInit = UTF8.raw_encode init in - let with_refs, position = match position with - | None -> false, (1, 1) - | Some x -> true, x in - Curses.werase t.status; - ignore @@ Curses.mvwaddstr t.status 0 0 (encodedPrefix^encodedInit); - ignore @@ Curses.wrefresh t.status; - - (** Rewrite all the text after the cursor *) - let rewrite_after = begin function - | [] -> () - | elems -> ( (* Rewrite each char after the cursor *) - let y, x = Curses.getyx t.status in - List.iter (fun x -> ignore @@ Curses.waddstr t.status (UTF8.raw_encode x)) elems; - ignore @@ Curses.wmove t.status y x ) - end - - (** Delete the previous text (or block of text) *) - and delete_previous hd = begin - let y, x = Curses.getyx t.status in - let length = UTF8.length hd in - ignore @@ Curses.wmove t.status y (x - length); - for position = 1 to length do - ignore @@ Curses.wdelch t.status - done; - end in - - (* Text edition, handle the keycode. - - [before] contains all the caracters inserted before the cursor (reverse - ordered), and [after] contains all the caracters after the cursor. - *) - let rec _edit before after = begin function - | "\027" -> (* Escape, cancel the modifications *) - None - | "\010" -> (* Enter, validate the input *) - - (* We concatenate all the characters. This can create an invalid string in - * the current locale (if there are copy/paste, or other events). - *) - Some (UTF8.implode @@ (UTF8.rev_implode before)::after) - - | "\001\004" -> (* Left *) - begin match before with - | [] -> _edit before after @@ read_key t - | hd::tl -> - let y, x = Curses.getyx t.status - and length = UTF8.length hd in - ignore @@ Curses.wmove t.status y (x - length); - ignore @@ Curses.wrefresh t.status; - _edit tl (hd::after) @@ read_key t - end - - | "\001\005" -> (* Right *) - begin match after with - | [] -> _edit before after @@ read_key t - | hd::tl -> - let y, x = Curses.getyx t.status - and length = UTF8.length hd in - ignore @@ Curses.wmove t.status y (x + length); - ignore @@ Curses.wrefresh t.status; - _edit (hd::before) tl @@ read_key t - end - - | "\001\007" -> (* Backspace *) - begin match before with - | [] -> _edit before after @@ read_key t - | hd::tl -> - delete_previous hd; - ignore @@ Curses.wrefresh t.status; - _edit tl after @@ read_key t - end - - | "\001\006" -> (* Home *) - begin match before with - | [] -> _edit before after @@ read_key t - | elems -> - let to_left (size, after) elem = begin - let size' = size + UTF8.length elem in - size', elem::after - end in - let chars, after' = List.fold_left to_left (0, after) elems in - let y, x = Curses.getyx t.status in - ignore @@ Curses.wmove t.status y (x - chars); - ignore @@ Curses.wrefresh t.status; - _edit [] after' @@ read_key t - end - - | "\001\104" -> (* End *) - begin match after with - | [] -> _edit before after @@ read_key t - | elems -> - let to_rigth (size, before) elem = begin - let size' = size + UTF8.length elem in - size', elem::before - end in - let chars, before' = List.fold_left to_rigth (0, before) elems in - let y, x = Curses.getyx t.status in - ignore @@ Curses.wmove t.status y (x + chars); - ignore @@ Curses.wrefresh t.status; - _edit before' [] @@ read_key t - end - | "\001\074" - | "\127" -> (* Del *) - begin match after with - | [] -> _edit before after @@ read_key t - | hd::tl -> - let y, x = Curses.getyx t.status in - ignore @@ Curses.wmove t.status y (x + 1); - delete_previous hd; - ignore @@ Curses.wrefresh t.status; - _edit before tl @@ read_key t - end - - | ("\001\002" as key) (* Down *) - | ("\001\003" as key) (* Up *) - | ("\001\153" as key) -> (* click *) - if with_refs then - select_content position (UTF8.empty) before after key - else - _edit before after @@ read_key t - - | any -> - ignore @@ Curses.waddstr t.status any; - rewrite_after after; - ignore @@ Curses.wrefresh t.status; - _edit (UTF8.decode any::before) after @@ read_key t - end - - (* Selection mode, Left and Right keys allow to select a cell, and not to - move inside the edition *) - and select_content (x, y) name before after = begin - function - | "\001\002" -> (* Down *) insert_cell_name (x, y + 1) name before after - | "\001\005" -> (* Right *) insert_cell_name (x + 1, y) name before after - - | "\001\003" -> (* Up *) - if y > 1 then - insert_cell_name (x, y - 1) name before after - else select_content (x, y) name before after @@ read_key t - - | "\001\004" -> (* Left *) - if x > 1 then - insert_cell_name (x - 1, y) name before after - else select_content (x, y) name before after @@ read_key t - - | "\001\153" -> (* click *) - let position = - begin match Tools.NCurses.get_mouse_event () with - | None -> None - | Some (id, ev, (x, y, z)) -> - if Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_CLICKED ev - || Tools.NCurses.is_event_of_type Tools.NCurses.BUTTON1_PRESSED ev then - get_cell t (x,y) - else - None - end in - begin match position with - | None -> select_content (x, y) name before after @@ read_key t - | Some (x, y) -> insert_cell_name (x, y) name before after - end - - | key -> - _edit (UTF8.fold List.cons name before) after key - end - - and insert_cell_name position name before after = begin - let cell_name = Cell.to_string @@ (position, (false, false)) in - ignore @@ delete_previous name; - ignore @@ Curses.waddstr t.status (UTF8.raw_encode cell_name); - rewrite_after after; - ignore @@ Curses.wrefresh t.status; - select_content position cell_name before after @@ read_key t - end - in - - Tools.try_finally - (fun () -> - ignore @@ Curses.curs_set 1; - try _edit (UTF8.rev_explode init) [] @@ read_key t - with _ -> None) - (fun () -> ignore @@ Curses.curs_set 0) - -end - -let search screen = begin - let result = editor ~prefix:(u"/") screen in - begin match result with - | Some content -> content - | None -> UTF8.empty - end -end - -let run f = - let window = init () in - Tools.try_finally - (fun () -> f window) - (fun () -> ignore @@ close window ) -- cgit v1.2.3