(* 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 "")) | { 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))))