(* Lightweight thread library for Objective Caml
 * http://www.ocsigen.org/lwt
 * Module Lwt_read_line
 * Copyright (C) 2009 Jérémie Dimino
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as
 * published by the Free Software Foundation, with linking exceptions;
 * either version 2.1 of the License, or (at your option) any later
 * version. See COPYING file for details.
 *
 * This program 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 * 02111-1307, USA.
 *)

open Lwt
open Lwt_text
open Lwt_term

module TextSet = Set.Make(Text)
type text_set = TextSet.t

type edition_state = Text.t * Text.t
type history = Text.t list
type prompt = Lwt_term.styled_text
type password_style = [ `empty | `clear | `text of Text.t ]

class clipboard =
  let signal, setter = React.S.create "" in
object
  method set text = setter text
  method contents = signal
end

let clipboard = new clipboard

exception Interrupt

(* +-----------------------------------------------------------------+
   | Completion                                                      |
   +-----------------------------------------------------------------+ *)

type completion_mode = [ `classic | `real_time | `none ]

type completion_result = {
  comp_state : edition_state;
  comp_words : text_set;
}

type completion = edition_state -> completion_result Lwt.t

let no_completion state = return {
  comp_state = state;
  comp_words = TextSet.empty;
}

let common_prefix a b =
  let lena = String.length a and lenb = String.length b in
  let rec loop i =
    if i = lena || i = lenb || (a.[i] <> b.[i]) then
      String.sub a 0 i
    else
      loop (i + 1)
  in
  loop 0

let lookup word words =
  let words = TextSet.filter (fun word' -> Text.starts_with word' word) words in
  if TextSet.is_empty words then
    ("", TextSet.empty)
  else
    (TextSet.fold common_prefix words (TextSet.choose words), words)

let complete ?(suffix=" ") before word after words =
  let prefix, words = lookup word words in
  match TextSet.cardinal words with
    | 0 ->
        { comp_state = (before ^ word, after);
          comp_words = TextSet.empty }
    | 1 ->
        { comp_state = (before ^ prefix ^ suffix, after);
          comp_words = words }
    | _ ->
        { comp_state = (before ^ prefix, after);
          comp_words = words }

(* +-----------------------------------------------------------------+
   | Commands                                                        |
   +-----------------------------------------------------------------+ *)

module Command =
struct

  type t =
    | Nop
    | Char of Text.t
    | Backward_delete_char
    | Forward_delete_char
    | Beginning_of_line
    | End_of_line
    | Complete
    | Meta_complete
    | Kill_line
    | Backward_kill_line
    | Accept_line
    | Backward_delete_word
    | Forward_delete_word
    | History_next
    | History_previous
    | Break
    | Clear_screen
    | Insert
    | Refresh
    | Backward_char
    | Forward_char
    | Set_mark
    | Paste
    | Copy
    | Cut
    | Uppercase
    | Lowercase
    | Capitalize
    | Backward_word
    | Forward_word
    | Backward_search
    | Complete_left
    | Complete_right
    | Complete_up
    | Complete_down
    | Complete_first
    | Complete_last
    | Undo
    | Delete_char_or_list

  let names = [
    (Nop, "nop");
    (Backward_delete_char, "backward-delete-char");
    (Forward_delete_char, "forward-delete-char");
    (Beginning_of_line, "beginning-of-line");
    (End_of_line, "end-of-line");
    (Complete, "complete");
    (Meta_complete, "meta-complete");
    (Kill_line, "kill-line");
    (Backward_kill_line, "backward-kill-line");
    (Accept_line, "accept-line");
    (Backward_delete_word, "backward-delete-word");
    (Forward_delete_word, "forward-delete-word");
    (History_next, "history-next");
    (History_previous, "history-previous");
    (Break, "break");
    (Clear_screen, "clear-screen");
    (Insert, "insert");
    (Refresh, "refresh");
    (Backward_char, "backward-char");
    (Forward_char, "forward-char");
    (Set_mark, "set-mark");
    (Paste, "paste");
    (Copy, "copy");
    (Cut, "cut");
    (Uppercase, "uppercase");
    (Lowercase, "lowercase");
    (Capitalize, "capitalize");
    (Backward_word, "backward-word");
    (Forward_word, "forward-word");
    (Complete_left, "complete-left");
    (Complete_right, "complete-right");
    (Complete_up, "complete-up");
    (Complete_down, "complete-down");
    (Backward_search, "backward-search");
    (Complete_first, "complete-first");
    (Complete_last, "complete-last");
    (Undo, "undo");
    (Delete_char_or_list, "delete-char-or-list");
  ]

  let to_string = function
    | Char ch ->
        Printf.sprintf "Char %S" ch
    | command ->
        let rec search = function
          | (command', name) :: _ when command = command' ->
              name
          | _ :: rest ->
              search rest
          | [] ->
              assert false
        in
        search names

  let of_string name =
    let rec search = function
      | (command, name') :: _ when name = name' ->
          command
      | _ :: rest ->
          search rest
      | [] ->
          failwith "Lwt_read_line.Command.of_stirng: cannot convert string to command"
    in
    search names

  let of_key = function
    | Key_up -> History_previous
    | Key_down -> History_next
    | Key_left -> Backward_char
    | Key_right -> Forward_char
    | Key_home -> Beginning_of_line
    | Key_end -> End_of_line
    | Key_insert -> Insert
    | Key_delete -> Forward_delete_char
    | Key_control '@' -> Set_mark
    | Key_control 'a' -> Beginning_of_line
    | Key_control 'd' -> Delete_char_or_list
    | Key_control 'e' -> End_of_line
    | Key_control 'h' -> Backward_delete_word
    | Key_control 'i' -> Complete
    | Key_control 'j' -> Accept_line
    | Key_control 'k' -> Kill_line
    | Key_control 'l' -> Clear_screen
    | Key_control 'm' -> Accept_line
    | Key_control 'n' -> Backward_char
    | Key_control 'p' -> Forward_char
    | Key_control 'r' -> Backward_search
    | Key_control 'u' -> Backward_kill_line
    | Key_control 'w' -> Cut
    | Key_control 'y' -> Paste
    | Key_control '_' -> Undo
    | Key_control '?' -> Backward_delete_char
    | Key "\027u" -> Uppercase
    | Key "\027l" -> Lowercase
    | Key "\027c" -> Capitalize
    | Key ("\027Oc" | "\027[1;5C") -> Forward_word
    | Key ("\027Od" | "\027[1;5D") -> Backward_word
    | Key ("\027\027[A" | "\027[1;3A") -> Complete_up
    | Key ("\027\027[B" | "\027[1;3B") -> Complete_down
    | Key ("\027\027[C" | "\027[1;3C") -> Complete_right
    | Key ("\027\027[D" | "\027[1;3D") -> Complete_left
    | Key ("\027\027[7~" | "\027[1;3H") -> Complete_first
    | Key ("\027\027[8~" | "\027[1;3F") -> Complete_last
    | Key ("\027\n" | "\194\141") -> Char "\n"
    | Key ("\027\t" | "\194\137") -> Meta_complete
    | Key ("\027w" | "\195\183") -> Copy
    | Key ("\027[3^" | "\027[3;5~") -> Forward_delete_word
    | Key ch when Text.length ch = 1 && Text.is_print ch -> Char ch
    | _ -> Nop
end

(* +-----------------------------------------------------------------+
   | Read-line engine                                                |
   +-----------------------------------------------------------------+ *)

module Engine =
struct
  open Command

  type selection_state = {
    sel_text : Text.t;
    sel_mark : Text.pointer;
    sel_cursor : Text.pointer;
  }

  type search_state = {
    search_word : Text.t;
    search_history : history;
    search_init_history : history;
  }

  type mode =
    | Edition of edition_state
    | Selection of selection_state
    | Search of search_state

  type state = {
    mode : mode;
    history : history * history;
  }

  let init history = {
    mode = Edition("", "");
    history = (history, []);
  }

  let all_input state = match state.mode with
    | Edition(before, after) ->
        before ^ after
    | Selection sel ->
        sel.sel_text
    | Search search ->
        match search.search_history with
          | [] ->
              ""
          | phrase :: _ ->
              phrase

  let edition_state state = match state.mode with
    | Edition(before, after) ->
        (before, after)
    | Selection sel ->
        (Text.chunk (Text.pointer_l sel.sel_text) sel.sel_cursor,
         Text.chunk sel.sel_cursor (Text.pointer_r sel.sel_text))
    | Search search ->
        match search.search_history with
          | [] ->
              ("", "")
          | phrase :: _ ->
              (phrase, "")

  (* Reset the mode to the edition mode: *)
  let reset state = match state.mode with
    | Edition _ ->
        state
    | Selection sel ->
        { state with mode = Edition(Text.chunk (Text.pointer_l sel.sel_text) sel.sel_cursor,
                                    Text.chunk sel.sel_cursor (Text.pointer_r sel.sel_text)) }
    | Search search ->
        { state with mode = Edition((match search.search_history with
                                       | [] ->
                                           ""
                                       | phrase :: _ ->
                                           phrase), "") }

  let split_first_word text =
    let rec find_last ptr =
      match Text.next ptr with
        | Some(ch, ptr) when Text.is_alnum ch ->
            find_last ptr
        | _ ->
            ptr
    in
    let rec find_first ptr =
      match Text.next ptr with
        | Some(ch, ptr') ->
            if Text.is_alnum ch then
              let ptr' = find_last ptr' in
              (Text.chunk (Text.pointer_l text) ptr,
               Text.chunk ptr ptr',
               Text.chunk ptr' (Text.pointer_r text))
            else
              find_first ptr'
        | None ->
            (text, "", "")
    in
    find_first (Text.pointer_l text)

  let split_last_word text =
    let rec find_first ptr =
      match Text.prev ptr with
        | Some(ch, ptr) when Text.is_alnum ch ->
            find_first ptr
        | _ ->
            ptr
    in
    let rec find_last ptr =
      match Text.prev ptr with
        | Some(ch, ptr') ->
            if Text.is_alnum ch then
              let ptr' = find_first ptr' in
              (Text.chunk (Text.pointer_l text) ptr',
               Text.chunk ptr' ptr,
               Text.chunk ptr (Text.pointer_r text))
            else
              find_last ptr'
        | None ->
            (text, "", "")
    in
    find_last (Text.pointer_r text)

  let rec update ~engine_state ?(clipboard=clipboard) ~command () =
    (* Helpers for updating the mode state only: *)
    let edition st = { engine_state with mode = Edition st }
    and selection st = { engine_state with mode = Selection st }
    and search st = { engine_state with mode = Search st } in
    match engine_state.mode with
      | Selection sel ->
          (* Change the cursor position: *)
          let maybe_set_cursor = function
            | Some(_, ptr) ->
                selection { sel with sel_cursor = ptr }
            | None ->
                engine_state
          in

          begin match command with
            | Nop ->
                engine_state

            | Forward_char ->
                maybe_set_cursor (Text.next sel.sel_cursor)

            | Backward_char ->
                maybe_set_cursor (Text.prev sel.sel_cursor)

            | Forward_word ->
                let rec skip ptr =
                  match Text.next ptr with
                    | Some(ch, ptr) ->
                        if Text.is_alnum ch then find ptr else skip ptr
                    | None ->
                        ptr
                and find ptr =
                  match Text.next ptr with
                    | Some(ch, ptr') ->
                        if Text.is_alnum ch then find ptr' else ptr
                    | None ->
                        ptr
                in
                selection { sel with sel_cursor = skip sel.sel_cursor }

            | Backward_word ->
                let rec skip ptr =
                  match Text.prev ptr with
                    | Some(ch, ptr) ->
                        if Text.is_alnum ch then find ptr else skip ptr
                    | None ->
                        ptr
                and find ptr =
                  match Text.prev ptr with
                    | Some(ch, ptr') ->
                        if Text.is_alnum ch then find ptr' else ptr
                    | None ->
                        ptr
                in
                selection { sel with sel_cursor = skip sel.sel_cursor }

            | Beginning_of_line ->
                selection { sel with sel_cursor =  Text.pointer_l sel.sel_text }

            | End_of_line ->
                selection { sel with sel_cursor =  Text.pointer_r sel.sel_text }

            | Copy ->
                let a = min sel.sel_cursor sel.sel_mark and b = max sel.sel_cursor sel.sel_mark in
                clipboard#set (Text.chunk a b);
                edition (Text.chunk (Text.pointer_l sel.sel_text) sel.sel_cursor,
                         Text.chunk sel.sel_cursor (Text.pointer_r sel.sel_text))

            | Cut ->
                let a = min sel.sel_cursor sel.sel_mark and b = max sel.sel_cursor sel.sel_mark in
                clipboard#set (Text.chunk a b);
                edition (Text.chunk (Text.pointer_l sel.sel_text) a,
                         Text.chunk b (Text.pointer_r sel.sel_text))

            | command ->
                (* If the user sent another command, reset the mode to
                   edition and process the command: *)
                update ~engine_state:(reset engine_state) ~clipboard ~command ()
          end

      | Edition(before, after) ->
          begin match command with
            | Char ch ->
                edition (before ^ ch, after)

            | Set_mark ->
                let txt = before ^ after in
                let ptr = Text.pointer_at txt (Text.length before) in
                selection { sel_text = txt;
                            sel_mark = ptr;
                            sel_cursor = ptr }

            | Paste ->
                edition (before ^ (React.S.value clipboard#contents), after)

            | Backward_delete_char ->
                edition (Text.rchop before, after)

            | Forward_delete_char ->
                edition (before, Text.lchop after)

            | Beginning_of_line ->
                edition ("", before ^ after)

            | End_of_line ->
                edition (before ^ after, "")

            | Kill_line ->
                clipboard#set after;
                edition (before, "")

            | Backward_kill_line ->
                clipboard#set before;
                edition ("", after)

            | History_previous ->
                begin match engine_state.history with
                  | ([], _) ->
                      engine_state
                  | (line :: hist_before, hist_after) ->
                      { mode = Edition(line, "");
                        history = (hist_before, (before ^ after) :: hist_after) }
                end

            | History_next ->
                begin match engine_state.history with
                  | (_, []) ->
                      engine_state
                  | (hist_before, line :: hist_after) ->
                      { mode = Edition(line, "");
                        history = ((before ^ after) :: hist_before, hist_after) }
                end

            | Backward_char ->
                if before = "" then
                  engine_state
                else
                  edition (Text.rchop before,
                           Text.get before (-1) ^ after)

            | Forward_char ->
                if after = "" then
                  engine_state
                else
                  edition (before ^ (Text.get after 0),
                           Text.lchop after)

            | Uppercase ->
                let a, b, c = split_first_word after in
                edition (before ^ a ^ Text.upper b, c)

            | Lowercase ->
                let a, b, c = split_first_word after in
                edition (before ^ a ^ Text.lower b, c)

            | Capitalize ->
                let a, b, c = split_first_word after in
                edition (before ^ a ^ Text.capitalize (Text.lower b), c)

            | Backward_word ->
                let a, b, c = split_last_word before in
                edition (a, b ^ c ^ after)

            | Forward_word ->
                let a, b, c = split_first_word after in
                edition (before ^ a ^ b, c)

            | Backward_delete_word ->
                let a, b, c = split_last_word before in
                edition (a, c ^ after)

            | Forward_delete_word ->
                let a, b, c = split_first_word after in
                edition (before ^ a, c)

            | Backward_search ->
                let hist_before, hist_after = engine_state.history in
                let history = List.rev_append hist_after ((before ^ after) :: hist_before) in
                search { search_word = "";
                         search_history = history;
                         search_init_history = history }

            | _ ->
                engine_state
          end

      | Search st ->
          let lookup word history =
            let rec aux history = match history with
              | [] ->
                  []
              | phrase :: rest ->
                  if Text.contains phrase word then
                    history
                  else
                    aux rest
            in
            aux history
          in

          begin match command with
            | Char ch ->
                let word = st.search_word ^ ch in
                search {
                  st with
                    search_word = word;
                    search_history = lookup word st.search_history;
                }

            | Backward_search ->
                search {
                  st with
                    search_history = match st.search_history with
                      | [] -> []
                      | _ :: rest -> lookup st.search_word rest
                }

            | Backward_delete_char ->
                if st.search_word <> "" then
                  let word = Text.rchop st.search_word in
                  search {
                    st with
                      search_word = word;
                      search_history = lookup word st.search_init_history;
                  }
                else
                  search st

            | cmd ->
                let phrase = match st.search_history with
                  | [] -> ""
                  | phrase :: _ -> phrase
                in
                edition (phrase, "")
          end
end

(* +-----------------------------------------------------------------+
   | Rendering                                                       |
   +-----------------------------------------------------------------+ *)

let rec repeat f n =
  if n <= 0 then
    return ()
  else
    lwt () = f () in
    repeat f (n - 1)

let print_words oc screen_width words = match List.filter ((<>) "") words with
  | [] ->
      return ()
  | words ->
      let max_width = List.fold_left (fun x word -> max x (Text.length word)) 0 words + 1 in
      let count = List.length words in
      let columns = max 1 (screen_width / max_width) in
      let lines =
        if count < columns then
          1
        else
          let l = count / columns in
          if columns mod count = 0 then l else l + 1
      in
      let column_width = screen_width / columns in
      let m = Array.make_matrix lines columns "" in
      let rec fill_display line column = function
        | [] ->
            ()
        | word :: words ->
            m.(line).(column) <- word;
            let line = line + 1 in
            if line < lines then
              fill_display line column words
            else
              fill_display 0 (column + 1) words
      in
      fill_display 0 0 words;
      for_lwt line = 0 to lines - 1 do
        lwt () =
          for_lwt column = 0 to columns - 1 do
            let word = m.(line).(column) in
            lwt () = write oc word in
            let len = Text.length word in
            if len < column_width then
              repeat (fun () -> write_char oc " ") (column_width - len)
            else
              return ()
          done
        in
        write_char oc "\n"
      done

module Terminal =
struct
  open Engine
  open Command

  type state = {
    printed_before : styled_text;
    (* The text displayed before the cursor *)
    printed_after : styled_text;
    (* The text displayed after the cursor *)
    box : bool;
    (* Tell whether a box is currently displayed *)
    display_start : int;
    (* For dynamic completion. It is the index of the first displayed word. *)
  }

  let init = { printed_before = []; printed_after = []; display_start = 0; box = false }

  type box =
    | Box_none
    | Box_empty
    | Box_words of text_set * int
    | Box_message of string

  let make_completion index columns words =
    let rec aux ofs idx = function
      | [] ->
          [Text(Text.repeat (columns - ofs) " ")]
      | word :: words ->
          let len = Text.length word in
          let ofs' = ofs + len in
          if ofs' <= columns then
            if idx = index then
              Inverse :: Text word :: Reset ::
                if ofs' + 1 > columns then
                  []
                else
                  Text "│" :: aux (ofs' + 1) (idx + 1) words
            else
              Text word ::
                if ofs' + 1 > columns then
                  []
                else
                  Text "│" :: aux (ofs' + 1) (idx + 1) words
          else
            [Text(Text.sub word 0 (columns - ofs))]
    in
    aux 0 0 words

  let make_bar delimiter columns words =
    let buf = Buffer.create (columns * 3) in
    let rec aux ofs = function
      | [] ->
          for i = ofs + 1 to columns do
            Buffer.add_string buf "─"
          done;
          Buffer.contents buf
      | word :: words ->
          let len = Text.length word in
          let ofs' = ofs + len in
          if ofs' <= columns then begin
            for i = 1 to len do
              Buffer.add_string buf "─"
            done;
            if ofs' + 1 > columns then
              Buffer.contents buf
            else begin
              Buffer.add_string buf delimiter;
              aux (ofs' + 1) words
            end
          end else begin
            for i = ofs + 1 to columns do
              Buffer.add_string buf "─"
            done;
            Buffer.contents buf
          end
    in
    aux 0 words

  let rec drop count l =
    if count <= 0 then
      l
    else match l with
      | [] -> []
      | e :: l -> drop (count - 1) l

  let rec goto_beginning_of_line = function
    | 0 ->
        [Text "\r"]
    | 1 ->
        [Text "\027[F"]
    | n ->
        Text "\027[F" :: goto_beginning_of_line (n - 1)

  let rec compute_position columns acc = function
    | [] ->
        acc
    | Text txt :: rest ->
        let acc = Text.fold (fun ch (column, line) ->
                               match ch with
                                 | "\n" ->
                                     (0, line + 1)
                                 | _ ->
                                     if column = columns then
                                       (1, line + 1)
                                     else
                                       (column + 1, line)) txt acc in
        compute_position columns acc rest
    | _ :: rest ->
        compute_position columns acc rest

  let _draw columns old_render_state new_render_state =

    let new_width_before, new_height_before =
      compute_position columns (0, 0) new_render_state.printed_before
    and old_width_before, old_height_before =
      compute_position columns (0, 0) old_render_state.printed_before in

    let new_render_state, new_width_before, new_height_before =
      (* If we terminates on the right margin, we add a "\n" to ensure
         that the cursor will be printed at the beginning of the next
         line: *)
      if new_width_before = columns then
        ({ new_render_state with printed_before = new_render_state.printed_before @ [Text "\n"] }, 0, new_height_before + 1)
      else
        (new_render_state, new_width_before, new_height_before)
    in

    let new_width_total, new_height_total =
      compute_position columns (new_width_before, new_height_before) new_render_state.printed_after
    and old_width_total, old_height_total =
      compute_position columns (old_width_before, old_height_before) old_render_state.printed_after in

    (* Produce a sequence erasing n lines: *)
    let rec eraser acc = function
      | 0 -> acc
      | n -> eraser (Text "\027[K\n" :: acc) (n - 1)
    in

    let text = List.flatten [
      (* Go back by the number of rows of the previous text: *)
      goto_beginning_of_line old_height_before;

      (* Erase all old contents: *)
      eraser [Text "\027[K"] old_height_total;

      (* Go back to the starting point: *)
      goto_beginning_of_line old_height_total;

      (* Print all new contents: *)
      new_render_state.printed_before;
      new_render_state.printed_after;

      (* Go back again to the beginning of printed text: *)
      goto_beginning_of_line new_height_total;

      (* Prints again the text before the cursor, to put the cursor at
         the right place: *)
      new_render_state.printed_before;
    ] in

    (text, new_render_state)

  (* Render the current state on the terminal, and returns the new
     terminal rendering state: *)
  let draw ~columns ?(map_text=fun x -> x) ?(box=Box_none) ~render_state ~engine_state ~prompt () =
    match engine_state.mode with
      | Search st ->
          let printed_before = Reset :: prompt @ [Reset; Text "(reverse-i-search)'"; Text st.search_word] in
          let printed_after = match st.search_history with
            | [] ->
                [Text "'"]
            | phrase :: _ ->
                let ptr_start = match Text.find phrase st.search_word with
                  | Some ptr ->
                      ptr
                  | None ->
                      (* The first phrase of st.search_history is a
                         phrase containing st.search_word, so this
                         case will never happen *)
                      assert false
                in
                let ptr_end = Text.move (Text.length st.search_word) ptr_start in
                [Text "': ";
                 Text(Text.chunk (Text.pointer_l phrase) ptr_start);
                 Underlined;
                 Text(Text.chunk ptr_start ptr_end);
                 Reset;
                 Text(Text.chunk ptr_end (Text.pointer_r phrase))]
          in
          _draw columns render_state { render_state with
                                         printed_before = printed_before;
                                         printed_after = printed_after }

      | _ ->
          (* Text before and after the cursor, according to the current mode: *)
          let before, after = match engine_state.mode with
            | Edition(before, after) ->
                ([Text(map_text before)], [Text(map_text after)])
            | Selection sel ->
                let a = min sel.sel_cursor sel.sel_mark and b = max sel.sel_cursor sel.sel_mark in
                let part_before = [Text(map_text (Text.chunk (Text.pointer_l sel.sel_text) a))]
                and part_selected = [Underlined; Text(map_text (Text.chunk a b)); Reset]
                and part_after = [Text(map_text (Text.chunk (Text.pointer_r sel.sel_text) b))] in
                if sel.sel_cursor < sel.sel_mark then
                  (part_before, part_selected @ part_after)
                else
                  (part_before @ part_selected, part_after)
            | Search _ ->
                assert false
          in

          (* All the text printed before the cursor: *)
          let printed_before = List.flatten [[Reset]; prompt; [Reset]; before] in

          match box with
            | Box_none ->
                _draw columns render_state
                  { render_state with
                      printed_before = printed_before;
                      printed_after = after;
                      box = false }

            | Box_message message ->
                let bar = Text(Text.repeat (columns - 2) "─") in
                let message_len = Text.length message in
                let message = if message_len + 2 > columns then Text.sub message 0 (columns - 2) else message in
                let printed_after =
                  after @
                    [Text "\n";
                     Text "┌"; bar; Text "┐\n";
                     Text "│"; Text message; Text(String.make (columns - 2 - message_len) ' '); Text "│\n";
                     Text "└"; bar; Text "┘"]
                in
                _draw columns render_state
                  { render_state with
                      printed_before = printed_before;
                      printed_after = printed_after;
                      box = true }

            | Box_empty ->
                let bar = Text(Text.repeat (columns - 2) "─") in
                let printed_after =
                  after @
                    [Text "\n";
                     Text "┌"; bar; Text "┐\n";
                     Text "│"; Text(Text.repeat (columns - 2) " "); Text "│\n";
                     Text "└"; bar; Text "┘"]
                in
                _draw columns render_state
                  { render_state with
                      printed_before = printed_before;
                      printed_after = printed_after;
                      box = true }

            | Box_words(words, position) ->
                let words = TextSet.elements words and count = TextSet.cardinal words in

                (* Sets the index of the first displayed words such
                   that the cursor is displayed: *)
                let display_start =

                  (* Given a list of words and an offset, it returns
                     the index of the last word that can be
                     dusplayed *)
                  let rec compute_end offset index words =
                    match words with
                      | [] ->
                          index - 1
                      | word :: words ->
                          let offset = offset + Text.length word in
                          if offset <= columns - 1 then
                            compute_end (offset + 1) (index + 1) words
                          else
                            index - 1
                  in

                  if position < render_state.display_start then
                    (* The cursor is before the left margin *)
                    let rev_index = count - position - 1 in
                    count - compute_end 1 rev_index (drop rev_index (List.rev words)) - 1
                  else if compute_end 1 render_state.display_start (drop render_state.display_start words) < position then
                    (* The cursor is after the right margin *)
                    position
                  else
                    (* The cursor points to a word which is
                       displayed *)
                    render_state.display_start
                in

                let words = drop display_start words in
                let printed_after =
                  List.flatten
                    [after;
                     [Text "\n";
                      Text "┌"; Text(make_bar "┬" (columns - 2) words); Text "┐\n";
                      Text "│"];
                     make_completion (position - display_start) (columns - 2) words;
                     [Text "│\n";
                      Text "└"; Text(make_bar "┴" (columns - 2) words); Text "┘"]]
                in

                _draw columns render_state
                  { display_start = display_start;
                    box = true;
                    printed_before = printed_before;
                    printed_after = printed_after }

  let last_draw ~columns ?(map_text=fun x -> x) ~render_state ~engine_state ~prompt () =
    let printed = prompt @ [Reset; Text(map_text(all_input engine_state)); Text "\n"] in
    fst (_draw columns render_state { render_state with
                                        printed_before = printed;
                                        printed_after = [] })

  let erase ~columns ~render_state () =
    goto_beginning_of_line (snd(compute_position columns (0, 0) render_state.printed_before)) @ [Text "\027[J"]
end

(* +-----------------------------------------------------------------+
   | Controlling a running instance                                  |
   +-----------------------------------------------------------------+ *)

module Control =
struct
  type 'a t = {
    result : 'a Lwt.t;
    send_command : Command.t -> unit;
    hide : unit -> unit Lwt.t;
    show : unit -> unit Lwt.t;
  }

  type prompt = Engine.state React.signal -> Lwt_term.styled_text React.signal

  let fake w = { result = w;
                 send_command = ignore;
                 hide = return;
                 show = return }

  let result ctrl = ctrl.result
  let send_command ctrl command = ctrl.send_command command
  let accept ctrl = ctrl.send_command Command.Accept_line
  let interrupt ctrl = ctrl.send_command Command.Break
  let hide ctrl = ctrl.hide ()
  let show ctrl = ctrl.show ()

  (* +---------------------------------------------------------------+
     | Instance parameters                                           |
     +---------------------------------------------------------------+ *)

  open Command

  let set_nth set n =
    let module M = struct exception Return of string end in
    try
      let _ = TextSet.fold (fun x n -> if n = 0 then raise (M.Return x) else n - 1) set n in
      invalid_arg "Lwt_read_line.set_nth"
    with M.Return x ->
      x

  let read_command () = read_key () >|= Command.of_key

  (* State of a read-line instance *)
  type state = {
    render : Terminal.state;
    engine : Engine.state;
    box : Terminal.box;
    prompt : Lwt_term.styled_text;
    visible : bool;
    old_states : edition_state list;
  }

  type event =
    | Ev_command of Command.t
    | Ev_prompt of Lwt_term.styled_text
    | Ev_box of Terminal.box
    | Ev_completion of completion_result
    | Ev_screen_size_changed
    | Ev_hide of unit Lwt.u
    | Ev_show of unit Lwt.u

  let engine_state state = state.engine
  let render_state state = state.render

  (* +---------------------------------------------------------------+
     | Read-line generator                                           |
     +---------------------------------------------------------------+ *)

  let default_prompt _ = React.S.const [Text "# "]

  let rec truncate_list n l = match n, l with
    | 0, l ->
        l
    | _, [] ->
        []
    | n, x :: l ->
        if n > 0 then
          x :: truncate_list (n - 1) l
        else
          []

  let make ?(history=[]) ?(complete=no_completion) ?(clipboard=clipboard) ?(mode=`real_time)
      ?(map_text=fun x -> x) ?(filter=fun s c -> return c) ~map_result ?(prompt=default_prompt) () =
    (* Signal holding the last engine state before waiting for a new
       command: *)
    let engine_state, set_engine_state = React.S.create (Engine.init history) in

    let prompt = prompt engine_state in

    (* The thread of the last launched completion *)
    let completion_thread = ref (return ()) in

    (*** Events ***)

    (* Thread of the last [read_command]. It is cancelled when
       read-line terminates. *)
    let last_read_command_thread = ref (raise_lwt Exit) in

    (* Events typed by the user: *)
    let user_events = Lwt_stream.from (fun () ->
                                         let t = read_command () in
                                         last_read_command_thread := t;
                                         lwt command = t in
                                         return (Some(Ev_command command))) in

    (* Events sent by the program: *)
    let program_events, push_event = Lwt_stream.create () in
    let push_event event = push_event (Some event) in

    (* Screan resizing *)
    let size_events = Lwt_event.to_stream (React.E.stamp (React.S.changes Lwt_term.size) Ev_screen_size_changed) in

    (* Prompt events *)
    let prompt_events = Lwt_event.to_stream (React.E.map (fun prompt -> Ev_prompt prompt) (React.S.changes prompt)) in

    (* All events  *)
    let events = Lwt_stream.choose [user_events; program_events; size_events; prompt_events] in

    (*** Box for `real_time mode ***)

    (* Contains the last suggested completion: *)
    let last_completion = ref None in

    (* If [true], [update_box] will generate an [Ev_completion] when
       completion is done, instead of an [Ev_box]. *)
    let want_completion = ref false in

    let update_box =
      match mode with
        | `real_time ->
            React.S.map
              (function
                 | { Engine.mode = Engine.Selection _ } ->
                     push_event (Ev_box(Terminal.Box_message "<selection>"))
                 | { Engine.mode = Engine.Search _ } ->
                     push_event (Ev_box Terminal.Box_none)
                 | { Engine.mode = Engine.Edition edition_state } ->
                     last_completion := None;
                     want_completion := false;
                     completion_thread := begin
                       let thread = complete edition_state >|= fun x -> `Result x in
                       let start_date = Unix.time () in
                       (* Animation to make the user happy: *)
                       let rec loop anim =
                         pick [thread; Lwt_unix.sleep 0.1 >> return `Timeout] >>= function
                           | `Result comp ->
                               last_completion := Some comp.comp_state;
                               if !want_completion then
                                 push_event (Ev_completion comp)
                               else
                                 push_event (Ev_box(Terminal.Box_words(comp.comp_words, 0)));
                               return ()
                           | `Timeout ->
                               let delta = truncate (Unix.time () -. start_date) in
                               let seconds = delta mod 60
                               and minutes = (delta / 60) mod 60
                               and hours = (delta / (60 * 60)) mod 24
                               and days = (delta / (60 * 60 * 24)) in
                               let message =
                                 if days = 0 then
                                   Printf.sprintf "working %s %02d:%02d:%02d" (List.hd anim) hours minutes seconds
                                 else if days = 1 then
                                   Printf.sprintf "working %s 1 day %02d:%02d:%02d" (List.hd anim) hours minutes seconds
                                 else
                                   Printf.sprintf "working %s %d days %02d:%02d:%02d" (List.hd anim) days hours minutes seconds
                               in
                               push_event (Ev_box(Terminal.Box_message message));
                               loop (List.tl anim)
                       in
                       let rec anim = "─" :: "\\" :: "│" :: "/" :: anim in
                       let thread = loop anim in
                       Lwt.on_cancel thread (fun () -> push_event (Ev_box Terminal.Box_empty));
                       thread
                     end)
              engine_state
        | `classic | `none ->
            React.S.const ()
    in

    (*** Main loop ***)

    (* Draw the state on the terminal and update the rendering
       state: *)
    let draw state =
      let text, render_state =
        Terminal.draw
          ~columns:(React.S.value columns)
          ~box:state.box
          ~render_state:state.render
          ~engine_state:state.engine
          ~prompt:state.prompt
          ~map_text
          ()
      in
      lwt () = printc text in
      return { state with render = render_state }
    in

    (* - [prev] is the last displayed state
       - [state] is the current state *)
    let rec loop prev state =
      let thread = Lwt_stream.next events in
      match Lwt.state thread with
        | Sleep ->
            (* This may update the prompt and dynamic completion: *)
            set_engine_state state.engine;
            (* Check a second time since the last command may have
               created new messages: *)
            begin match Lwt.state thread with
              | Sleep ->
                  (* Redraw screen if the event queue is empty *)
                  lwt state = (if state.visible && prev <> state then draw else return) state in
                  lwt event = thread in
                  process_event state event (loop state)

              | Return event ->
                  process_event state event (loop prev)

              | Fail exn ->
                  raise_lwt exn
            end

        | Return event ->
            process_event state event (loop prev)

        | Fail exn ->
            raise_lwt exn

    (* loop_refresh redraw the current state, even if it haa not
       changed: *)
    and loop_refresh state =
      let thread = Lwt_stream.next events in
      match Lwt.state thread with
        | Sleep ->
            set_engine_state state.engine;
            begin match Lwt.state thread with
              | Sleep ->
                  lwt state = (if state.visible then draw else return) state in
                  lwt event = thread in
                  process_event state event (loop state)

              | Return event ->
                  process_event state event loop_refresh

              | Fail exn ->
                  raise_lwt exn
            end

        | Return event ->
            process_event state event loop_refresh

        | Fail exn ->
            raise_lwt exn

    and process_event state event loop = match event with
      | Ev_prompt prompt ->
          loop { state with prompt = prompt }

      | Ev_screen_size_changed ->
          lwt () = printc (Terminal.erase ~columns:(React.S.value columns) ~render_state:state.render ()) in
          loop_refresh { state with render = Terminal.init }

      | Ev_hide wakener ->
          if state.visible then begin
            lwt () = printc (Terminal.erase ~columns:(React.S.value columns) ~render_state:state.render ()) in
            wakeup wakener ();
            loop { state with render = Terminal.init; visible = false }
          end else
            loop state

      | Ev_show wakener ->
          if not state.visible then begin
            lwt state = draw state in
            wakeup wakener ();
            loop { state with visible = true }
          end else
            loop state

      | Ev_box box ->
          loop { state with box = box }

      | Ev_completion comp ->
          let state = { state with engine = { state.engine with Engine.mode = Engine.Edition comp.comp_state } } in
          if mode = `classic && TextSet.cardinal comp.comp_words > 1 then
            lwt () =
              printc (Terminal.last_draw
                        ~columns:(React.S.value columns)
                        ~render_state:state.render
                        ~engine_state:state.engine
                        ~prompt:state.prompt
                        ~map_text
                        ())
            in
            lwt () = print_words stdout (React.S.value Lwt_term.columns) (TextSet.elements comp.comp_words) in
            loop_refresh { state with render = Terminal.init }
          else
            loop state

      | Ev_command command ->
          if not (command = Complete && mode = `real_time) then
            (* Cancel completion on user input: *)
            Lwt.cancel !completion_thread;

          (* Save the command for possible [Undo] command *)
          let state =
            match command, state.engine with
              | Undo, _ ->
                  state
              | _, { Engine.mode = Engine.Edition es } -> begin
                  let old_states =
                    match state.old_states with
                      | es' :: _ when es = es' ->
                          state.old_states
                      | old_states ->
                          es :: old_states
                  in
                  { state with old_states = truncate_list 1000 old_states }
                end
              | _ ->
                  state
          in

          (* User-provided filter *)
          lwt command = filter state command in

          (* Commands that need pre-processing *)
          lwt command = match command, state.engine.Engine.mode with
            | Delete_char_or_list, Engine.Edition ("", "") -> return Break
            | Delete_char_or_list, Engine.Edition (_, "") -> return Complete
            | Delete_char_or_list, Engine.Edition (_, _) -> return Forward_delete_char
            | _ -> return command
          in

          match command with
            | Nop ->
                loop state

            | Undo -> begin
                match state.old_states with
                  | [] ->
                      loop state
                  | s :: l ->
                      loop { state with
                               engine = { state.engine with Engine.mode = Engine.Edition s };
                               old_states = l }
              end

            | Complete_right ->
                begin match state.box with
                  | Terminal.Box_words(words, index) when index < TextSet.cardinal words - 1 ->
                      loop { state with box = Terminal.Box_words(words, index + 1) }
                  | _ ->
                      loop state
                end

            | Complete_left ->
                begin match state.box with
                  | Terminal.Box_words(words, index) when index > 0 ->
                      loop { state with box = Terminal.Box_words(words, index - 1) }
                  | _ ->
                      loop state
                end

            | Complete_first ->
                begin match state.box with
                  | Terminal.Box_words(words, index) ->
                      loop { state with box = Terminal.Box_words(words, 0) }
                  | _ ->
                      loop state
                end

            | Complete_last ->
                begin match state.box with
                  | Terminal.Box_words(words, index) when not (TextSet.is_empty words)->
                      loop { state with box = Terminal.Box_words(words, TextSet.cardinal words - 1) }
                  | _ ->
                      loop state
                end

            | Complete ->
                begin match mode with
                  | `none ->
                      loop state
                  | `classic ->
                      let state = { state with engine = Engine.reset state.engine } in
                      completion_thread := begin
                        lwt comp = complete (Engine.edition_state state.engine) in
                        push_event (Ev_completion comp);
                        return ()
                      end;
                      loop state
                  | `real_time ->
                      match !last_completion with
                        | Some comp_state ->
                            loop { state with engine = { state.engine with Engine.mode = Engine.Edition comp_state } }
                        | None ->
                            want_completion := true;
                            loop state
                end

            | Meta_complete ->
                if mode = `real_time then begin
                  let state = { state with engine = Engine.reset state.engine } in
                  match state.box with
                    | Terminal.Box_words(words, index) when not (TextSet.is_empty words) ->
                        let before, after = Engine.edition_state state.engine in
                        let word = set_nth words index in
                        let word_len = Text.length word and before_len = Text.length before in
                        (* [search] searches the longest suffix of
                           [before] which is a prefix of [word]: *)
                        let rec search ptr idx =
                          if Text.equal_at ptr (Text.sub word 0 idx) then
                            loop { state with engine = { state.engine with Engine.mode = Engine.Edition(before ^ Text.sub word idx (word_len - idx), after) } }
                          else
                            match Text.next ptr with
                              | None -> raise_lwt (Failure "invalid completion")
                              | Some(ch, ptr) -> search ptr (idx - 1)
                        in
                        if word_len > before_len then
                          search (Text.pointer_l before) before_len
                        else
                          search (Text.pointer_at before (-word_len)) word_len
                    | _ ->
                        loop state
                end else
                  loop state

            | Clear_screen ->
                lwt () = clear_screen () in
                loop_refresh state

            | Refresh ->
                loop_refresh state

            | Accept_line ->
                return (state, `Accept)

            | Break ->
                return (state,`Interrupt)

            | command ->
                loop { state with engine = Engine.update ~engine_state:state.engine ~clipboard ~command () }

    in

    let result = with_raw_mode begin fun () ->

      (* Wait for edition to terminate *)
      lwt state, result = loop_refresh {
        render = Terminal.init;
        engine = React.S.value engine_state;
        box = Terminal.Box_none;
        prompt = React.S.value prompt;
        visible = true;
        old_states = [];
      } in

      (* Cleanup *)
      React.S.stop update_box;
      Lwt.cancel !last_read_command_thread;

      (* Do the last draw *)
      lwt () = printc (Terminal.last_draw
                         ~columns:(React.S.value columns)
                         ~render_state:state.render
                         ~engine_state:state.engine
                         ~prompt:state.prompt
                         ~map_text
                         ())
      in

      match result with
        | `Accept ->
            map_result (Engine.all_input state.engine)
        | `Interrupt ->
            raise_lwt Interrupt
    end in
    {
      result = result;
      send_command = (fun command -> push_event (Ev_command command));
      hide = (fun () ->
                let waiter, wakener = Lwt.wait () in
                push_event (Ev_hide wakener);
                waiter);
      show = (fun () ->
                let waiter, wakener = Lwt.wait () in
                push_event (Ev_show wakener);
                waiter);
    }

  (* +---------------------------------------------------------------+
     | Predefined instances                                          |
     +---------------------------------------------------------------+ *)

  let make_prompt prompt = React.S.value (prompt (React.S.const (Engine.init [])))

  let read_line ?history ?complete ?clipboard ?mode ?(prompt=default_prompt) () =
    lwt stdin_isatty = Lwt_unix.isatty Lwt_unix.stdin
    and stdout_isatty = Lwt_unix.isatty Lwt_unix.stdout in
    if stdin_isatty && stdout_isatty then
      return (make ?history ?complete ?clipboard ?mode ~prompt ~map_result:return ())
    else
      return (fake (lwt () = write stdout (strip_styles (make_prompt prompt)) in
                    Lwt_text.read_line stdin))

  let read_password ?clipboard ?(style:password_style=`text "*") ?prompt () =
    lwt stdin_isatty = Lwt_unix.isatty Lwt_unix.stdin
    and stdout_isatty = Lwt_unix.isatty Lwt_unix.stdout in
    if stdin_isatty && stdout_isatty then
      let map_text = match style with
        | `text ch -> (fun txt -> Text.map (fun _ -> ch) txt)
        | `clear -> (fun x -> x)
        | `empty -> (fun _ -> "")
      and filter state = function
        | Backward_search ->
            (* Drop search commands *)
            return Nop
        | command ->
            return command
      in
      return (make ?clipboard ~map_text ~mode:`none ~filter ?prompt ~map_result:return ())
    else
      fail (Failure "Lwt_read_line.read_password: not running in a terminal")

  let read_keyword ?history ?(case_sensitive=false) ?mode ?(prompt=default_prompt) ~values () =
    let compare = if case_sensitive then Text.compare else Text.icompare in
    let rec assoc key = function
      | [] -> None
      | (key', value) :: l ->
          if compare key key' = 0 then
            Some value
          else
            assoc key l
    in
    lwt stdin_isatty = Lwt_unix.isatty Lwt_unix.stdin
    and stdout_isatty = Lwt_unix.isatty Lwt_unix.stdout in
    if stdin_isatty && stdout_isatty then
      let words = List.fold_left (fun acc (key, value) -> TextSet.add key acc) TextSet.empty values in
      let filter state = function
        | Accept_line ->
            let text = Engine.all_input state.engine in
            if List.exists (fun (key, value) -> compare key text = 0) values then
              return Accept_line
            else
              return Nop
        | command ->
            return command
      and map_result text = match assoc text values with
        | Some value ->
            return value
        | None ->
            assert false
      and complete (before, after) =
        return (complete "" before after words)
      in
      return (make ?history ?mode ~prompt ~filter ~map_result ~complete ())
    else
      return (fake (lwt () = write stdout (strip_styles (make_prompt prompt)) in
                    lwt txt = Lwt_text.read_line stdin in
                    match assoc txt values with
                      | Some value ->
                          return value
                      | None ->
                          raise_lwt (Failure "Lwt_read_line.read_keyword: invalid input")))

  let read_yes_no ?history ?mode ?prompt () =
    read_keyword ?history ?mode ?prompt ~values:[("yes", true); ("no", false)] ()
end

(* +-----------------------------------------------------------------+
   | Simple calls                                                    |
   +-----------------------------------------------------------------+ *)

let default_prompt = [Text "# "]

let read_line ?history ?complete ?clipboard ?mode ?(prompt=default_prompt) () =
  Control.read_line ?history ?complete ?clipboard ?mode ~prompt:(fun _ -> React.S.const prompt) () >>= Control.result

let read_password ?clipboard ?style ?(prompt=default_prompt) () =
  Control.read_password ?clipboard ?style ~prompt:(fun _ -> React.S.const prompt) () >>= Control.result

let read_keyword ?history ?case_sensitive ?mode ?(prompt=default_prompt) ~values () =
  Control.read_keyword ?history ?case_sensitive ?mode ~prompt:(fun _ -> React.S.const prompt) ~values () >>= Control.result

let read_yes_no ?history ?mode ?(prompt=default_prompt) () =
  Control.read_yes_no ?history ?mode ~prompt:(fun _ -> React.S.const prompt) () >>= Control.result

(* +-----------------------------------------------------------------+
   | History                                                         |
   +-----------------------------------------------------------------+ *)

let add_entry line history =
  if Text.strip line = "" then
    history
  else
    if (match history with [] -> false | x :: _ -> x = line) then
      history
    else
      line :: history

let escape line =
  Text.map (function
              | "\n" -> "\\n"
              | "\\" -> "\\\\"
              | ch -> ch) line

let unescape line =
  let buf = Buffer.create (String.length line) in
  let rec loop ptr = match Text.next ptr with
    | Some("\\", ptr) ->
        begin match Text.next ptr with
          | Some("\\", ptr) ->
              Buffer.add_string buf "\\";
              loop ptr
          | Some("n", ptr) ->
              Buffer.add_string buf "\n";
              loop ptr
          | Some(ch, ptr) ->
              Buffer.add_string buf "\\";
              Buffer.add_string buf ch;
              loop ptr
          | None ->
              Buffer.add_string buf "\\";
              Buffer.contents buf
        end
    | Some(ch, ptr) ->
        Buffer.add_string buf ch;
        loop ptr
    | None ->
        Buffer.contents buf
  in
  loop (Text.pointer_l line)

let rec load_lines ic acc =
  Lwt_io.read_line_opt ic >>= function
    | Some l ->
        load_lines ic (unescape l :: acc)
    | None ->
        return acc

let load_history name =
  if Sys.file_exists name then
    Lwt_io.with_file ~mode:Lwt_io.input name (fun ic -> load_lines ic [])
  else
    return []

let rec merge h1 h2 = match h1, h2 with
  | l1 :: h1, l2 :: h2 when l1 = l2 ->
      l1 :: merge h1 h2
  | _ ->
      h1 @ h2

let save_history name history =
  lwt on_disk_history = load_history name in
  Lwt_io.lines_to_file name (Lwt_stream.map escape (Lwt_stream.of_list (merge (List.rev on_disk_history) (List.rev history))))
