Source file down.ml

(*---------------------------------------------------------------------------
   Copyright (c) 2017 The down programmers. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

open Down_std

let original_ocaml_readline = ref (fun _ _ _ -> assert false)

let use_file ?(silent = false) file = match silent with
| true -> Toploop.use_silently Format.std_formatter (Toploop.File file)
| false -> Toploop.use_file Format.std_formatter file

(* Logging and formatting styles *)

let faint = ref true
let add_faint acc = if !faint then `Faint :: acc else acc
let tty_no_faint () = faint := false
let style_err = [`Bold; `Fg `Red] (* match ocaml *)
let style_warn = [`Bold; `Fg `Magenta] (* match ocaml *)
let style_doc_section = [`Fg `Yellow]
let style_code = [`Bold]
let style_id_complete_suff = [`Fg (`Hi `Cyan)]
let style_id_complete_info () = add_faint [`Italic]
let style_id_info_id = [`Fg (`Hi `Cyan) ]
let style_id_info_type = [`Italic]
let style_last_indicator = [`Fg `Yellow]
let style_key = [`Bold ]
let style_prompt = [`Fg (`Hi `Green) ]
let style_prompt_inactive () = (add_faint [`Fg `Green])
let style_prompt_recording = [`Fg (`Hi `Magenta) ]
let style_prompt_recording_inactive () = (add_faint [`Fg `Magenta])
let pp_error = Fmt.tty style_err Fmt.string
let pp_warn = Fmt.tty  style_warn Fmt.string (* match ocaml *)
let pp_doc_section = Fmt.tty style_doc_section Fmt.string
let pp_code = Fmt.tty style_code Fmt.string
let pp_faint () = Fmt.tty (add_faint []) Fmt.string
let log_error fmt = Fmt.pr ("%a: " ^^ fmt ^^ "@.") pp_error "Error"
let log_warning fmt = Fmt.pr ("%a: " ^^ fmt ^^ "@.") pp_warn "Warning"
let log_on_error ~use = function Error e -> log_error "%s" e; use | Ok v -> v

(* Prompt history *)

module Phistory = struct
  type t = { prev : string list; focus : string; next : string list; }
  let v prev =
    let add acc e = match String.trim e with "" -> acc | e -> e :: acc in
    { prev = List.rev (List.fold_left add [] prev) ; focus = ""; next = [] }

  let empty = v []
  let push e es =
    if e = "" then es else match es with
    | e' :: _ when String.equal e e' -> es
    | es -> e :: es

  let entries h =
    let next = List.filter (fun s -> not (String.equal s "")) h.next in
    List.rev_append (push h.focus next) h.prev

  let add h e = match String.trim e with "" -> h | e -> v (push e (entries h))
  let restart h = v (entries h)
  let prev h current = match h.prev with
  | [] -> None
  | p :: ps ->
      let next = push (String.trim current) (push h.focus h.next) in
      let next = if next = [] then [""] (* bottom can be empty *) else next in
      Some ({ prev = ps; focus = p; next; }, p)

  let next h current = match h.next with
  | [] -> None
  | n :: ns ->
      let prev = push (String.trim current) (push h.focus h.prev) in
      Some ({ prev; focus = n; next = ns }, n)

  let to_string ~sep h = Txt_entries.to_string ~sep (entries h)
  let of_string ~sep s = v (Txt_entries.of_string ~sep s)
end

(* String editor *)

module Pstring = struct
  type t = { s : string; cursor : int; mark : int option }
  let v ?(cursor = 0) ?mark s = { s; cursor; mark }
  let empty = v ""
  let is_empty p = String.equal p.s ""
  let txt p = p.s
  let txt_range ~first:r0 ~last:r1 p = String.sub p.s r0 (r1 - r0 + 1)
  let cursor p = p.cursor
  let set_cursor cursor p = if p.cursor = cursor then p else { p with cursor }
  let set_mark mark p = { p with mark }
  let swap_cursor_and_mark p = match p.mark with
  | None -> p | Some m when m > String.length p.s -> { p with mark = None }
  | Some m  -> { p with cursor = m; mark = Some p.cursor }

  let soi p = set_cursor 0 p
  let eoi p = set_cursor (String.length p.s) p
  let sol p = set_cursor (Txt.find_prev_sol p.s ~start:(p.cursor - 1)) p
  let eol p = set_cursor (Txt.find_next_eol p.s ~start:p.cursor) p
  let next_char p = set_cursor (Txt.find_next_gc p.s ~after:p.cursor) p
  let prev_char p = set_cursor (Txt.find_prev_gc p.s ~before:p.cursor) p
  let next_word p = set_cursor (Txt.find_next_after_eow p.s ~start:p.cursor) p
  let prev_word p = set_cursor (Txt.find_prev_sow p.s ~start:(p.cursor - 1)) p

  let prev_line p =
    let l, w = Txt.find_prev_eol_and_tty_width p.s ~before:p.cursor in
    let pl = Txt.find_prev_eol p.s ~start:(l - 1) in
    let start = if pl = l || not (Txt.is_eol p.s.[pl]) then 0 else pl + 1 in
    let cursor = Txt.find_next_tty_width_or_eol p.s ~start ~w in
    set_cursor cursor p

  let next_line p =
    let l, w = Txt.find_prev_eol_and_tty_width p.s ~before:p.cursor in
    let start = if p.cursor = 0 && w = 0 then 0 else l + 1 in
    let nl = Txt.find_next_eol p.s ~start in
    if nl = String.length p.s then p else
    let cursor = Txt.find_next_tty_width_or_eol p.s ~start:(nl + 1) ~w in
    set_cursor cursor p

  let subst ~start:r0 ~stop:r1 bytes p =
    let slen = String.length p.s in
    let blen = String.length bytes in
    if r0 = slen then { p with s = p.s ^ bytes; cursor = slen + blen } else
    let b = String.sub p.s 0 r0 in
    let a = String.sub p.s r1 (slen - r1) in
    let s = String.concat "" [b; bytes; a] in
    let mark = match p.mark with
    | None -> None | Some m when m <= slen + blen -> p.mark | Some _ -> None
    in
    { s; cursor = r0 + blen; mark }

  let insert bytes p = subst ~start:p.cursor ~stop:p.cursor bytes p
  let delete_next_char p =
    if p.cursor = String.length p.s then p else
    let stop = Txt.find_next_gc p.s ~after:p.cursor in
    subst ~start:p.cursor ~stop "" p

  let delete_prev_char p =
    if p.cursor = 0 then p else
    let prev = Txt.find_prev_gc p.s ~before:p.cursor in
    subst ~start:prev ~stop:p.cursor "" p

  let kill_next_word p =
    let stop = Txt.find_next_after_eow p.s ~start:p.cursor in
    if stop = p.cursor then p, None else
    let kill = txt_range ~first:p.cursor ~last:(stop - 1) p in
    subst ~start:p.cursor ~stop "" p, Some kill

  let kill_prev_word p =
    if p.cursor = 0 then p, None else
    let prev = Txt.find_prev_sow p.s ~start:(p.cursor - 1) in
    let kill = txt_range ~first:prev ~last:(p.cursor - 1) p in
    subst ~start:prev ~stop:p.cursor "" p, Some kill

  let kill_to_sol p =
    let start = Txt.find_prev_sol p.s ~start:(p.cursor - 1) in
    let start = if start = p.cursor then p.cursor - 1 else start in
    let last = p.cursor - 1 in
    if start < 0 || last < 0 then p, None else
    let kill = txt_range ~first:start ~last p in
    subst ~start ~stop:p.cursor "" p, Some kill

  let kill_to_eol p =
    let stop = Txt.find_next_eol p.s ~start:p.cursor in
    let stop = if stop = p.cursor then stop + 1 else stop in
    if stop > String.length p.s then p, None else
    let kill = txt_range ~first:p.cursor ~last:(stop - 1) p in
    subst ~start:p.cursor ~stop "" p, Some kill

  let kill_region p = match p.mark with
  | None -> p, None
  | Some mark ->
      if mark > String.length p.s then { p with mark = None }, None else
      if mark = p.cursor then p, None else
      let min, max = match p.cursor < mark with
      | true -> p.cursor, mark - 1
      | false -> mark, p.cursor - 1
      in
      let kill = txt_range ~first:min ~last:max p in
      let cursor = min and mark = Some min in
      { (subst ~start:min ~stop:(max + 1) "" p) with cursor; mark }, Some kill

  let geometry ~tty_w ~margin_w p =
    (* Returns [rmax], (cr, cc, c_nl). [rmax] and [cr] are zero-based
       row indexes relative to prompt row for: the maximal row and the
       cursor row. [cc] is the cursor column and [c_nl] indicates if a
       newline has to be added for a wrapping cursor. *)
    let rec loop s max cursor cr cc r c i = match i > max with
    | true ->
        if cursor <> String.length s then r, (cr, cc, false) else
        if c mod tty_w = 0 then r + 1, (r + 1, 0, true) else r, (r, c, false)
    | false ->
        let r, c = if c mod tty_w = 0 then (* wrap *) r + 1, 0 else r, c in
        let cr, cc = if i = cursor then (r, c) else (cr, cc) in
        let nl = s.[i] = '\n' in
        let i, gc_w = Txt.find_next_gc_and_tty_width s ~after:i in
        let r, c = if nl then r + 1, margin_w else r, c + gc_w in
        loop s max cursor cr cc r c i
    in
    loop p.s (String.length p.s - 1) p.cursor 0 margin_w 0 margin_w 0
end

(* OCaml history *)

module History = struct
  let sep = "(**)"
  let h = ref (Phistory.v [])
  let add txt = h := Phistory.add !h txt
  let restart () = h := Phistory.restart !h
  let prev current = match Phistory.prev !h current with
  | None -> None | Some (h', txt) -> h := h'; Some txt

  let next current = match Phistory.next !h current with
  | None -> None | Some (h', txt) -> h := h'; Some txt

  let file () =
    Result.bind (Dir.config ()) @@ fun dir ->
    Ok (Filename.concat dir (Filename.concat "ocaml" "history.ml"))

  let load () =
    log_on_error ~use:() @@
    Result.map_error (Fmt.str "history load failed: %s") @@
    Result.bind (file ()) @@ fun file ->
    Result.bind (File.exists file) @@ function
    | false -> Ok ()
    | true ->
        Result.bind (File.read file) @@ fun hstr ->
        Ok (h := Phistory.of_string ~sep hstr;)

  let save () =
    log_on_error ~use:() @@
    Result.map_error (Fmt.str "history save failed: %s") @@
    Result.bind (file ()) @@ fun file ->
    File.set_content ~file (Phistory.to_string ~sep !h)

  let edit () =
    log_on_error ~use:() @@
    Result.map_error (Fmt.str "history edit failed: %s") @@
    Result.bind (file ()) @@ fun file ->
    let hstr = Phistory.to_string ~sep !h in
    Result.bind (File.set_content ~file hstr) @@ fun () ->
    Result.bind (Editor.edit_file file) @@ fun () ->
    Result.bind (File.read file) @@ fun hstr ->
    Ok (h := Phistory.of_string ~sep hstr)

  let clear () = h := Phistory.v []; save ()
end

(* Sessions *)

module Session = struct
  type name = string
  let dir () =
    Result.bind (Dir.config ()) @@ fun dir ->
    Ok (Filename.concat dir (Filename.concat "ocaml" "session"))

  let dir_file fn = Result.bind (dir ()) @@ fun d -> Ok (Filename.concat d fn)
  let last_session_file () = dir_file "last"
  let unsaved_file () = dir_file "unsaved"
  let session_file = function
  | "" -> Error "Session name cannot be empty."
  | n -> dir_file (n ^ ".ml")

  let session_of_path p =
    if not (Filename.check_suffix p ".ml") then None else
    Some (Filename.(basename (chop_extension p)), p)

  let sessions_of_dir dir =
    Result.bind (Dir.exists dir) @@ function
    | false -> Ok []
    | true ->
        Result.bind (Dir.contents dir) @@ fun paths ->
        let rec add_session acc p = match session_of_path p with
        | None -> acc | Some (n, p) -> (n, p) :: acc
        in
        Ok (List.sort compare (List.fold_left add_session [] paths))

  let last_session () =
    Result.bind (last_session_file ()) @@ fun file ->
    Result.bind (File.exists file) @@ function
    | false -> Ok None
    | true ->
        Result.bind (File.read file) @@ fun n ->
        let name = String.trim n in
        Result.bind (session_file name) @@ fun file ->
        Result.bind (File.exists file) @@ function
        | false -> Ok None
        | true -> Ok (Some (name, file))

  let set_last_session n =
    Result.bind (last_session_file ()) @@ fun file -> File.set_content ~file n

  let get_session n =
    let find_session n = match n with
    | "" -> last_session ()
    | n -> Result.bind (session_file n) @@ fun f -> Ok (Some (n, f))
    in
    Result.bind (find_session n) @@ function
    | None -> Error "No existing last session found."
    | Some (name, file) ->
        log_on_error ~use:() (set_last_session name); Ok (name, file)

  let get_existing_session n =
    Result.bind (get_session n) @@ fun (n, file as s) ->
    Result.bind (File.exists file) @@ function
    | true -> Ok s
    | false ->
        Error (Fmt.str "No session %a found, \
                        see '%a'" pp_code n pp_code "Down.Session.list ()")

  let last_name () =
    log_on_error ~use:None @@
    Result.bind (last_session ()) @@ function
    | None -> Ok None | Some (n, _) -> Ok (Some n)

  let list () =
    let pp_last ppf last =
      if not last then () else
      Fmt.pf ppf "(%a) " (Fmt.tty style_last_indicator Fmt.string) "last"
    in
    let pp_session ~last ppf (n, p) =
      Fmt.pf ppf "@[<h>%a %a%a@]" pp_code n pp_last (last = n) (pp_faint ()) p
    in
    let pp_session_list ~last ppf ss =
      Fmt.pf ppf "  @[<v>@,%a@,@]" (Fmt.list (pp_session ~last)) ss
    in
    let pp_none ppf dir =
      Fmt.pf ppf "  @[<v>@,No session found in %a@,@]" (pp_faint ()) dir
    in
    log_on_error ~use:() @@
    Result.bind (dir ()) @@ fun dir ->
    Result.bind (last_session ()) @@ fun last ->
    Result.bind (sessions_of_dir dir) @@ function
    | [] -> Ok (Fmt.pr "%a@." pp_none dir)
    | ss ->
        let last = match last with None -> "" | Some (last, _) -> last in
        Ok (Fmt.pr "%a@." (pp_session_list ~last) ss)

  let load ?silent n =
    log_on_error ~use:() @@
    Result.bind (get_existing_session n) @@ fun (n, file) ->
    if (use_file ?silent file) then Ok () else
    Error
      (Fmt.str "Use '%a' to correct errors." pp_code "Down.Session.edit \"\"")

  let edit n =
    log_on_error ~use:() @@
    Result.bind (get_session n) @@ fun (_, file) ->
    Result.bind (File.exists file) @@ function
    | true -> Editor.edit_file file
    | false ->
        (* create path *)
        Result.bind (File.set_content ~file "") @@ fun () ->
        Editor.edit_file file

  let err_exists n =
    Fmt.str "Session %a exists, specify '%a' to overwrite."
      pp_code n pp_code "~replace:true"

  let of_file ?(replace = false) ~file n =
    log_on_error ~use:() @@
    Result.bind (get_session n) @@ fun (n, session_file) ->
    Result.bind (File.exists session_file) @@ function
    | true when not replace -> Error (err_exists n)
    | true | false ->
        Result.bind (File.read file) @@ fun contents ->
        File.set_content ~file:session_file contents

  let delete n =
    log_on_error ~use:() @@
    Result.bind (get_existing_session n) @@ fun (_, f) -> File.delete f

  (* Recording. *)

  let sep = "(**)"
  let to_string phrases = Txt_entries.to_string ~sep phrases
  let of_string s = (Txt_entries.of_string ~sep s)

  let recording : bool ref = ref false
  let set_recording v = recording := v
  let recording () = !recording

  let record : string list ref = ref []
  let set_record phrases = record := List.rev phrases
  let rem_last_recorded () = match !record with
  | [] -> () | _ :: rs -> record := rs

  let add_recorded s = match String.trim s with
  | s when String.length s >= 5 && String.sub s 0 5 = "#quit" -> ()
  | s -> record := s :: !record

  let add_if_recording s = if recording () then add_recorded s
  let recorded () = List.rev !record
  let record () =
    match !Toploop.read_interactive_input == !original_ocaml_readline with
    | true -> log_error "Sorry, recording needs Down's line edition."
    | false -> (* That could still not be down's readline but, unlikely *)
        if recording () then rem_last_recorded () else set_recording true

  let stop () = if recording () then (rem_last_recorded (); set_recording false)
  let revise () =
    if recording () then rem_last_recorded ();
    log_on_error ~use:() @@
    let s = to_string (recorded ()) in
    Result.bind (Editor.edit_string ~ext:".ml" s) @@ fun s ->
    Ok (set_record (of_string s))

  let save ?(replace = false) n =
    stop (); log_on_error ~use:() @@
    Result.bind (get_session n) @@ fun (n, file) ->
    match recorded () with
    | [] -> Error "No phrase to save."
    | ps ->
        Result.bind (File.exists file) @@ function
        | true when not replace -> Error (err_exists n)
        | true | false ->
            Result.bind (File.set_content ~file (to_string ps)) @@ fun () ->
            Ok (set_record [])

  let append n =
    stop (); log_on_error ~use:() @@
    Result.bind (get_session n) @@ fun (_, file) ->
    match recorded () with
    | [] -> Error "No phrase to append."
    | ps ->
        Result.bind (File.exists file) @@ function
        | false ->
            Result.bind (File.set_content ~file (to_string ps)) @@ fun () ->
            Ok (set_record [])
        | true ->
            Result.bind (File.read file) @@ fun contents ->
            let ps = of_string contents @ ps in
            Result.bind (File.set_content ~file (to_string ps)) @@ fun () ->
            Ok (set_record [])

  (* The idea of the following is to avoid a dialog to confirm losing
     existing recorded phrases. Though similar to history, it may be
     confusing on parallel ocaml processes. *)

  let load_unsaved_record () =
    log_on_error ~use:() @@
    Result.bind (unsaved_file ()) @@ fun file ->
    Result.bind (File.exists file) @@ function
    | false -> Ok ()
    | true ->
        Result.bind (File.read file) @@ fun contents ->
        set_record (of_string contents); File.set_content ~file ""

  let save_unsaved_record () =
    log_on_error ~use:() @@
    match recorded () with
    | [] -> Ok ()
    | ps ->
        Result.bind (unsaved_file ()) @@ fun file ->
        Result.bind (File.exists file) @@ function
        | false -> File.set_content ~file (to_string ps)
        | true ->
            Result.bind (File.read file) @@ fun contents ->
            (* Another toplevel process may have written meanwhile... *)
            File.set_content ~file (to_string (of_string contents @ ps))

  (* Stepping. *)

  let steps : string array ref = ref [||]
  let step = ref (-1)

  let step_next () = match !step with
  | s when s >= Array.length !steps - 1 -> None
  | s -> incr step; (Some !steps.(!step))

  let step_prev () = match !step with
  | s when s <= 0 -> None
  | s -> decr step; (Some !steps.(!step))

  let steps n =
    log_on_error ~use:() @@
    Result.bind (get_existing_session n) @@ fun (_, file) ->
    Result.bind (File.read file) @@ fun contents ->
    steps := Array.of_list (of_string contents);
    step := (-1); Ok ()

  let next_step () = ignore (step_next ())
  let prev_step () = ignore (step_prev ())
end

(* Ocaml syntax munging *)

module Ocaml = struct
  let id_path_char = function
  | '0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' | '.' | '\'' | '_' -> true
  | _ -> false

  let id_span s ~start =
    if s = "" then None else
    let id_char = Txt.find_prev ~sat:id_path_char s ~start in
    if not (id_path_char s.[id_char]) then None else
    let keep_prev = Txt.keep_prev_len ~sat:id_path_char s ~start:id_char in
    let id_start = id_char - keep_prev + 1 in
    let id_len = Txt.keep_next_len ~sat:id_path_char s ~start:id_start in
    let id_end = id_start + id_len - 1 in
    if id_end < id_start then None else
    Some (String.sub s id_start (id_end - id_start + 1))
end

(* Prompting *)

module Prompt = struct
  module I = struct type t = Tty.input let compare = compare end
  module Itrie = Trie.Make (I)
  type cmd = t -> [`Eoi | `Kont | `Break]
  and t =
    { mutable tty_w : int;
      readc : unit -> int option;
      output : string -> unit;
      has_answer : Tty.input -> t -> string option;
      id_complete : string -> (string * string list, string) result;
      id_info : string -> ((string * string * string) option, string) result;
      mutable clipboard : string;
      mutable txt : Pstring.t;
      (* These are zero-based rows relat. to the prompt line for clearing. *)
      mutable last_cr : int; (* last cursor render row *)
      mutable last_max_r : int; (* last max render row *) }

  let has_answer input p =
    (* FIXME ocaml and utop are a bit weird. Try to sort that out.
       Notably is there does seem to be any good reason not to input
       successive ;; separated phrases, ocaml does that on .ml files.
       Cf. https://github.com/ocaml/ocaml/issues/8813 *)
    let ends_with_semisemi s =
      let rec loop s i = match i < 0 with
      | true -> false
      | false ->
          if Txt.is_white s.[i] then loop s (i - 1) else
          if s.[i] <> ';' then false else
          if i = 0 then false else s.[i - 1] = ';'
      in
      loop s (String.length s - 1)
    in
    match input with
    | `Enter ->
        let txt = Pstring.txt p.txt in
        if ends_with_semisemi txt
        then Some ((String.trim txt) ^ "\n") (* trim is for a cleaner hist. *)
        else None
    | _ -> None

  let create
      ?(id_complete = fun w -> Ok (w, [])) ?(id_info = fun id -> Ok None)
      ?(output = Tty.output) ~readc ()
    =
    { tty_w = 80; readc; output; has_answer; id_complete; id_info;
      clipboard = ""; txt = Pstring.empty; last_cr = 0; last_max_r = 0; }

  (* Rendering *)

  let ding p = p.output Tty.ding
  let newline p = p.output Tty.newline
  let error p fmt =
    let error = Tty.styled_str Tty.cap style_err "Error" in
    let k msg = p.output (Printf.sprintf "\r\n%s: %s\r\n" error msg) in
    Format.kasprintf k fmt

  let clear_screen p =
    p.output (String.concat "" Tty.[clear_screen; cursor_origin])

  let clear_ui p =
    (* Go from cursor to max row and back to prompt row clearing lines. *)
    let rec go acc = function
    | 0 -> acc | up -> go (Tty.clear_row :: Tty.cursor_up 1 :: acc) (up - 1)
    in
    let down = p.last_max_r - p.last_cr and up = p.last_max_r in
    let acc = go (Tty.clear_row :: Tty.cursor_down down :: []) up in
    p.output (String.concat "" (List.rev ("\r" :: acc)));
    p.last_cr <- 0; p.last_max_r <- 0

  let prompt = "# "
  let margin = "  "
  let nl_margin = "\r\n  "
  let render_prompt ~active =
    let style = match Session.recording () with
    | false -> if active then style_prompt else style_prompt_inactive ()
    | true ->
        if active then style_prompt_recording else
        style_prompt_recording_inactive ()
    in
    Tty.styled_str Tty.cap style prompt

  let render_ui ?(active = true) p =
    let tty_w = p.tty_w and margin_w = String.length margin in
    let max_r, (cr, cc, c_nl) = Pstring.geometry ~tty_w ~margin_w p.txt in
    let add_line acc l = nl_margin :: l :: acc in
    let acc = [render_prompt ~active] in
    let acc = List.fold_left add_line acc (Txt.lines (Pstring.txt p.txt)) in
    let acc = "\r" :: List.tl acc (* remove exceeding nl_margin *) in
    let acc = if c_nl (* cursor wrapped *) then "\n" :: acc else acc in
    let acc = match active with
    | true -> Tty.cursor_forward cc :: Tty.cursor_up (max_r - cr) :: acc
    | false -> acc
    in
    let ui = String.concat "" (List.rev acc) in
    p.output Tty.cursor_hide;
    clear_ui p; p.output ui;
    p.output Tty.cursor_show;
    if active then (p.last_cr <- cr; p.last_max_r <- max_r)

  let render_id_complete p prefix candidates =
    let render_candidate prefix c = match String.length c with
    | 0 -> ""
    | blen ->
        let styled sty s = Tty.styled_str Tty.cap sty s in
        match c.[0] = ' ' with
        | true ->
            (* Hackish. E.g. we don't actually get candidates one per line
               in case of module types. *)
            styled (style_id_complete_info ()) c
        | false ->
            match String.index c '\t' with
            | exception Not_found -> c (* should not happen but be robust *)
            | tab ->
                let rst_start = tab + 1 in
                let suf_start = String.length prefix in
                let pre = String.sub c 0 suf_start in
                let suf = String.sub c suf_start (tab - suf_start) in
                let rst = ":" ^ String.sub c rst_start (blen - rst_start) in
                Printf.sprintf "  %s%s%s"
                  pre (styled style_id_complete_suff suf)
                  (styled (style_id_complete_info ()) rst)
    in
    let candidates = List.map (render_candidate prefix) candidates in
    render_ui ~active:false p; newline p;
    p.output (String.concat Tty.newline candidates); newline p

  let render_id_info p id typ doc =
    let render_id id = Tty.styled_str Tty.cap (style_id_info_id) id in
    let render_type t = Tty.styled_str Tty.cap (style_id_info_type) t in
    let typ = match Txt.lines typ with
    | [""] | [] -> ""
    | t :: ts ->
        Printf.sprintf ":%s" @@
          render_type (String.concat Tty.newline @@
                       t :: List.map (Printf.sprintf "%s%s" margin) ts)
    in
    let acc = [Printf.sprintf "\r\n  %s%s" (render_id id) typ] in
    let acc = List.rev_append (Txt.lines doc) acc in
    let acc = List.rev_map (Printf.sprintf "%s%s" margin) acc in
    render_ui ~active:false p; newline p;
    p.output (String.concat Tty.newline acc); newline p

  (* Commands *)

  let set_txt_value p txt = p.txt <- Pstring.eoi (Pstring.v txt)
  let set_txt_with_history op p = match op (Pstring.txt p.txt) with
  | None -> ding p
  | Some txt -> set_txt_value p txt

  let update op p =
    let txt = op p.txt in
    if txt == p.txt (* bof *) then ding p else p.txt <- txt

  let update_with_kill op p =
    let txt, kill = op p.txt in
    let clipboard = match kill with None -> ding p; p.clipboard | Some s -> s in
    p.txt <- txt; p.clipboard <- clipboard

  let soi = update Pstring.soi
  let eoi = update Pstring.eoi
  let sol = update Pstring.sol
  let eol = update Pstring.eol
  let prev_char = update Pstring.prev_char
  let next_char = update Pstring.next_char
  let prev_word = update Pstring.prev_word
  let next_word = update Pstring.next_word
  let prev_line = update Pstring.prev_line
  let next_line = update Pstring.next_line
  let insert bytes = update (Pstring.insert bytes)
  let delete_next_char = update Pstring.delete_next_char
  let delete_prev_char = update Pstring.delete_prev_char
  let set_mark = update (fun p -> Pstring.set_mark (Some (Pstring.cursor p)) p)
  let swap_cursor_and_mark = update Pstring.swap_cursor_and_mark
  let kill_prev_word = update_with_kill Pstring.kill_prev_word
  let kill_next_word = update_with_kill Pstring.kill_next_word
  let kill_to_sol = update_with_kill Pstring.kill_to_sol
  let kill_to_eol = update_with_kill Pstring.kill_to_eol
  let kill_region = update_with_kill Pstring.kill_region
  let yank p =
    if p.clipboard = "" then ding p else
    let mark = Some (Pstring.cursor p.txt) and clip = p.clipboard in
    update (fun p -> Pstring.set_mark mark (Pstring.insert clip p)) p

  let edit p = match Editor.edit_string ~ext:".ml" (Pstring.txt p.txt) with
  | Error e -> error p "%s" e
  | Ok txt -> set_txt_value p txt

  let id_complete p =
    let completion_start p =
      let rec loop s i =
        if i >= 0 && Ocaml.id_path_char s.[i] then loop s (i - 1) else
        let ret = i + 1 in if ret = (Pstring.cursor p) then None else Some ret
      in
      loop (Pstring.txt p) (Pstring.cursor p - 1)
    in
    match completion_start p.txt with
    | None -> ding p
    | Some start ->
        let set_subst p start old w =
          let stop = start + String.length old in
          p.txt <- Pstring.subst ~start ~stop w p.txt
        in
        let last = Pstring.cursor p.txt - 1 in
        let word = Pstring.txt_range ~first:start ~last p.txt in
        match p.id_complete word with
        | Error e -> error p "%s" e
        | Ok (_, []) -> ding p
        | Ok (w, [_]) -> set_subst p start word w
        | Ok (w, cs) -> render_id_complete p w cs; set_subst p start word w

  let id_info p =
    match Ocaml.id_span (Pstring.txt p.txt) ~start:(Pstring.cursor p.txt) with
    | None -> ding p
    | Some id ->
        match p.id_info id with
        | Error e -> error p "%s" e
        | Ok None -> ding p;
        | Ok (Some (id, typ, doc)) -> render_id_info p id typ doc

  let ctrl_d p =
    if Pstring.txt p.txt = "" then `Eoi else (delete_next_char p; `Kont)

  let session_next_step p = match Session.step_next () with
  | None -> ding p | Some s -> set_txt_value p s

  let session_prev_step p = match Session.step_prev () with
  | None -> ding p | Some s -> set_txt_value p s

  let prev_history = set_txt_with_history History.prev
  let next_history = set_txt_with_history History.next
  let break p = `Break
  let kont f p = f p; `Kont
  let cmds : (Tty.input list * cmd * string) list = [
    (**)
    [`Home], kont soi, "move to start of input";
    [`End], kont eoi, "move to end of input";
    (**)
    [`Ctrl (`Key 0x61) (* a *)], kont sol, "move to start of line";
    [`Ctrl (`Key 0x65) (* e *)], kont eol, "move to end of line";
    (**)
    [`Ctrl (`Key 0x62) (* b *)], kont prev_char, "move to previous character";
    [`Ctrl (`Key 0x66) (* f *)], kont next_char, "move to next character";
    [`Arrow `Left], kont prev_char, "move to previous character";
    [`Arrow `Right], kont next_char, "move to next character";
    (**)
    [`Meta 0x62 (* b *)], kont prev_word, "move to start of previous word";
    [`Meta 0x66 (* f *)], kont next_word, "move after the end of next word";
    [`Ctrl (`Arrow `Left)], kont prev_word, "move to start of previous word";
    [`Ctrl (`Arrow `Right)], kont next_word, "move after the end of next word";
    (**)
    [`Ctrl (`Key 0x70) (* p *)], kont prev_line, "move to previous line";
    [`Ctrl (`Key 0x6E) (* n *)], kont next_line, "move to next line";
    (**)
    [`Arrow `Up], kont prev_history, "previous history entry";
    [`Arrow `Down], kont next_history, "next history entry";
    (**)
    [`Backspace], kont delete_prev_char, "delete previous character";
    [`Delete], kont delete_next_char, "delete next character";
    [`Ctrl (`Key 0x64) (* d *)], ctrl_d,
    "delete next character or exit if input is empty";
    [`Ctrl (`Key 0x63) (* c *)], break, "abandon input";
    (**)
    [`Ctrl (`Key 0x60) (* space ? *)], kont set_mark, "set the mark";
    [`Ctrl (`Key 0x78) (* x *); `Ctrl (`Key 0x78 )(* x *)],
    kont swap_cursor_and_mark, "swap cursor and mark";
    [`Ctrl (`Key 0x79) (* y *)], kont yank, "yank";
    (**)
    [`Ctrl (`Key 0x6B) (* k *)], kont kill_to_eol, "kill to end of line";
    [`Ctrl (`Key 0x75) (* k *)], kont kill_to_sol, "kill to start of line";
    [`Meta 0x7F ], kont kill_prev_word, "kill to start of previous word";
    [`Meta 0x64 (* d *)], kont kill_next_word, "kill to end of next word";
    [`Ctrl (`Key 0x77) (* w *)], kont kill_region, "kill region";
    (**)
    [`Shift (`Arrow `Up)], kont session_prev_step, "previous session step";
    [`Shift (`Arrow `Down)], kont session_next_step, "next session step";
    [`Ctrl (`Key 0x78) (* x *); `Ctrl (`Key 0x70) (* p *)],
    kont session_prev_step, "previous session step";
    [`Ctrl (`Key 0x78) (* x *); `Ctrl (`Key 0x6E) (* n *)],
    kont session_next_step, "next session step";
    (**)
    [`Ctrl (`Key 0x6C) (* l *)], kont clear_screen, "clear screen";
    [`Tab], kont id_complete, "complete identifier";
    [`Ctrl (`Key 0x74 )(* t *)], kont id_info,
    "show identifier type and documentation";
    [`Ctrl (`Key 0x78) (* x *); `Ctrl (`Key 0x65) (* e *)], kont edit,
    "edit input with external program (VISUAL or EDITOR env var)" ]

  let pp_cmd ppf (is, _, doc) =
    let pp_is = Fmt.tty style_key (Fmt.(list ~sep:sp Tty.pp_input)) in
    Fmt.pf ppf "@[%a  @[%a@]@]" pp_is is Fmt.text doc

  let cmd_trie =
    let add t (is, cmd, _doc) = Itrie.add is (Some cmd) t in
    List.fold_left add Itrie.empty cmds

  (* Event loop *)

  let ask p =
    let reset p = p.last_cr <- 0; p.last_max_r <- 0; p.txt <- Pstring.empty in
    let resize p = p.tty_w <- Tty.width p.readc in
    let return p = render_ui ~active:false p; newline p in
    let rec loop p input_state =
      render_ui p;
      match Tty.input p.readc with
      | None -> (* EINTR (and thus SIGWINCH) *) resize p; loop p input_state
      | Some i ->
          match p.has_answer i p with
          | Some a ->
              (History.add a; Session.add_if_recording a; return p; `Answer a)
          | None ->
              let input_state = Itrie.find [i] input_state in
              match Itrie.value input_state with
              | None when Itrie.is_empty input_state ->
                  begin match i with
                  | `Bytes bytes -> insert bytes p; loop p cmd_trie
                  | `Enter -> insert "\n" p; loop p cmd_trie
                  | _ -> ding p; loop p cmd_trie
                  end
              | None -> loop p input_state
              | Some cmd ->
                  match cmd p with
                  | `Kont -> loop p cmd_trie
                  | `Break -> History.restart (); return p; `Break
                  | `Eoi -> `Eoi
    in
    (reset p; resize p; loop p cmd_trie)
end

(* Help *)

let help () =
  let pp_manual ppf () =
    Fmt.pf ppf "@[Consult '%a' for the manual and API.@]"
      pp_code "odig doc down"
  in
  let pp_session ppf () =
    Fmt.pf ppf
      "%a:@,Support for sessions is in the %a module.@,\
            Use '%a' to list sessions."
      pp_doc_section "Sessions" pp_code "Down.Session"
      pp_code "Down.Session.list ()"
  in
  let pp_key_bindings ppf () =
    Fmt.pf ppf "%a:@,@[<v>%a@]" pp_doc_section "Key bindings"
      (Fmt.list Prompt.pp_cmd) Prompt.cmds
  in
  let pp_help ppf () =
    Fmt.pf ppf "  @[<v>@,%a@,%a@,@,%a@,@,%a@,@]@."
      pp_doc_section "Welcome to Down!" pp_manual () pp_session ()
      pp_key_bindings ()
  in
  pp_help Format.std_formatter ()

(* Completion and doc lookup via ocp-index *)

module Ocp_index = struct
  (* FIXME. POC hack via ocp-index, we likely want to that ourselves since we
     also need to peek in the OCaml toplevel symtable to be able to
     complete what the user defined and keep track of [open]s. *)

  module Ctrie = Trie.Make (Char)

  let string_to_list s =
    let rec go s i acc = if i < 0 then acc else go s (i - 1) (s.[i] :: acc) in
    go s (String.length s - 1) []

  let string_of_list l =
    let b = Buffer.create 255 in
    List.iter (Buffer.add_char b) l; (Buffer.contents b)

  let has_ocp_index =
    lazy begin match Cmd.exists ["ocp-index"] with
    | Error _ as e -> e
    | Ok true -> Ok ()
    | Ok false ->
        Error (Fmt.str "Completion and doc lookup needs ocp-index. Try '%a'."
                 pp_code "opam install ocp-index")
    end

  let complete_cmd token = ["ocp-index"; "complete"; "-f"; "%q \t %t"; token ]
  let complete_word word results =
    let add_id acc r =
      let id = String.trim (List.hd (String.split_on_char '\t' r)) in
      if id = "" then acc else Ctrie.add (string_to_list id) (Some ()) acc
    in
    let ids = List.fold_left add_id Ctrie.empty results in
    let word, _ = Ctrie.find_fork (string_to_list word) ids in
    (string_of_list word, results)

  let finish_single_complete = function
  | "" -> ""
  | w when w.[String.length w - 1] = '.' -> w
  | w ->
      let path_start = match String.rindex w '.' with
      | exception Not_found -> 0 | i -> i + 1
      in
      if Char.uppercase_ascii w.[path_start] = w.[path_start]
      then w ^ "." (* Likely Module name path segment. *)
      else w ^ " " (* Likely Module structure item segment. *)

  let id_complete = function
  | "" -> Ok ("", [])
  | w ->
      Result.bind (Lazy.force has_ocp_index) @@ fun () ->
      Result.bind (Result.map_error snd @@ Cmd.read (complete_cmd w)) @@
      fun s -> match List.rev (Txt.lines s) with
      | [] | [""] | [""; ""] -> Ok (w, [])
      | "" :: rlines | rlines ->
          match complete_word w (List.rev rlines) with
          | w, ([_] as cs) -> Ok (finish_single_complete w, cs)
          | _ as ret -> Ok ret

  let print_cmd id = ["ocp-index"; "print"; id; "%q \\t %t\\n(**)\\n%d" ]
  let parse_id_info = function
  | "" -> None
  | o ->
      match Txt_entries.of_string ~sep:"(**)" o with
      | [] -> None
      | [v] -> Some (v, "", "")
      | (id_sig :: doc :: _) ->
          match String.index id_sig '\t' with
          | exception Not_found -> Some (o, "", doc)
          | i ->
              let len = String.length id_sig in
              let id = String.sub id_sig 0 i in
              let typ =
                if i + 1 = len then "" else
                String.sub id_sig (i + 1) (len - (i + 1))
              in
              Some (id, typ, doc)

  let id_info = function
  | "" -> Ok None
  | id ->
      Result.bind (Lazy.force has_ocp_index) @@ fun () ->
      match (Cmd.read (print_cmd id)) with
      | Error (2, _) -> Ok None
      | Error (n, e) -> Error e
      | Ok o -> Ok (parse_id_info o)
end

(* Toplevel readline *)

let blit_toploop_buf s i b blen =
  let slen = String.length s in
  let slen_to_write = slen - i in
  let len = min blen slen_to_write in
  let snext = i + len in
  Bytes.blit_string s i b 0 len;
  len, (if snext < slen then Some (s, snext) else None)

let down_readline p =
  let rem = ref None in
  fun prompt b len -> match !rem with
  | Some (s, i) ->
      let len, rem' = blit_toploop_buf s i b len in
      rem := rem'; (len, false)
  | None ->
      let rec loop p = match Prompt.ask p with
      | `Eoi -> (0, true)
      | `Break -> Tty.output "Interrupted.\r\n"; loop p
      | `Answer ans ->
          let len, rem' = blit_toploop_buf ans 0 b len in
          rem := rem'; (len, false)
      in
      match Stdin.set_raw_mode true with
      | false -> !original_ocaml_readline prompt b len
      | true -> let r = loop p in ignore (Stdin.set_raw_mode false); r

external sigwinch : unit -> int = "ocaml_down_sigwinch"
let install_sigwinch_interrupt () =
  (* Sufficient to interrupt the event loop on window size changes. *)
  if Sys.unix then Sys.set_signal (sigwinch ()) (Sys.Signal_handle (fun _ -> ()))

let pp_announce ppf () =
  Fmt.pf ppf "%a v0.4.0 loaded. Type %a for more info."
    pp_doc_section "Down" pp_code "Down.help ()"

let err_no_ansi = "no ANSI terminal capability detected."
let err_no_raw = "failed to set stdin in raw mode."
let install_down () =
  let line_edition = match Tty.cap with
  | `None -> Error err_no_ansi
  | `Ansi ->
      match Stdin.set_raw_mode true with
      | false -> Error err_no_raw
      | true -> ignore (Stdin.set_raw_mode false); Ok ()
  in
  let announce () = Fmt.pr "%a@." pp_announce () in
  History.load (); at_exit History.save;
  Session.load_unsaved_record (); at_exit Session.save_unsaved_record;
  original_ocaml_readline := !Toploop.read_interactive_input;
  match line_edition with
  | Ok () ->
      let id_complete = Ocp_index.id_complete in
      let id_info = Ocp_index.id_info in
      let p = Prompt.create ~id_complete ~id_info ~readc:Stdin.readc () in
      Toploop.read_interactive_input := down_readline p;
      install_sigwinch_interrupt ();
      Stdin.enable_bracketed_paste stdout;
      announce ()
  | Error err ->
      announce (); log_warning "Down line edition disabled: %s" err

let () = if !Sys.interactive then install_down ()

(* Private *)

module Private = struct
  let unicode_version = Down_tty_width.unicode_version
  let tty_test () = match Tty.cap with
  | `None -> print_endline err_no_ansi
  | `Ansi ->
      match Stdin.set_raw_mode true with
      | false -> print_endline err_no_raw
      | true ->
          let w = Tty.width Stdin.readc in
          let welcome =
            Fmt.str
              "\r\nWelcome to Down's TTY test! Your width is %d. Ding!\r\n\
               Hit your keyboard. C-{c,d} stops the test.\r\n\r\n" w
          in
          Tty.output welcome;
          Tty.output Tty.ding;
          let rec loop () = match Tty.input Stdin.readc with
          | None ->
              let w = Tty.width Stdin.readc in
              Tty.output (Fmt.str "Your width is %d.\r\n" w); loop ()
          | Some i ->
              match i with
              | `Ctrl (`Key 0x63) (* c *) -> print_endline "Bye.\r"
              | `Ctrl (`Key 0x64) (* d *) -> print_endline "EOF Bye.\r"
              | _ ->
                  print_endline (Format.asprintf "%a\r" Tty.pp_input i);
                  loop ()
          in
          loop ()
end