path: root/src/screen.ml

(*
This file is part of licht.

licht is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

licht is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with licht.  If not, see <http://www.gnu.org/licenses/>.
*)

(** 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 position 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 center_axis f replace max_limit shift screen = begin
    let selected_axis = f position 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 selected screen = begin

  let position = Selection.extract selected in

  let expr, _, sink = Sheet.get_cell position data in
  let referenced = Expression.collect_sources expr in

  let height, width = screen.size in
  let screen = center data position 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) 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) 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)) 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 _, value, _ = Sheet.get_cell (pos_x, pos_y) data in
      let content = Option.map (fun x -> UTF8.split ~sep:(u"\n") (ScTypes.Result.show x)) value
        |> 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

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 selected screen = begin

  let height, width = screen.size in

  let expr, value, _ = Sheet.get_cell (Selection.extract selected) t in

  let result = Option.map ScTypes.Result.show value
            |> 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 (Expression.show expr);
  ()
end

(** Wait for an event and return the key pressed.

    Non blocking for other running Lwt thread.

    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 selection 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 selection t;
    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 run f =
  let window = init () in
  Tools.try_finally
    (fun () -> f window)
    (fun () -> ignore @@ close window )