536 lines
19 KiB
OCaml
536 lines
19 KiB
OCaml
(*
|
|
* uTop_console.ml
|
|
* ---------------
|
|
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
|
* Licence : BSD3
|
|
*
|
|
* This file is a part of utop.
|
|
*)
|
|
|
|
(* Main for console mode. *)
|
|
|
|
open CamomileLibraryDyn.Camomile
|
|
open Lwt
|
|
open Lwt_react
|
|
open LTerm_text
|
|
open LTerm_geom
|
|
open UTop_token
|
|
|
|
module String_set = Set.Make(String)
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Resources |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
type styles = {
|
|
mutable style_keyword : LTerm_style.t;
|
|
mutable style_symbol : LTerm_style.t;
|
|
mutable style_ident : LTerm_style.t;
|
|
mutable style_module : LTerm_style.t;
|
|
mutable style_constant : LTerm_style.t;
|
|
mutable style_char : LTerm_style.t;
|
|
mutable style_string : LTerm_style.t;
|
|
mutable style_quotation : LTerm_style.t;
|
|
mutable style_comment : LTerm_style.t;
|
|
mutable style_doc : LTerm_style.t;
|
|
mutable style_blanks : LTerm_style.t;
|
|
mutable style_error : LTerm_style.t;
|
|
mutable style_directive : LTerm_style.t;
|
|
mutable style_paren : LTerm_style.t;
|
|
}
|
|
|
|
let styles = {
|
|
style_keyword = LTerm_style.none;
|
|
style_symbol = LTerm_style.none;
|
|
style_ident = LTerm_style.none;
|
|
style_module = LTerm_style.none;
|
|
style_constant = LTerm_style.none;
|
|
style_char = LTerm_style.none;
|
|
style_string = LTerm_style.none;
|
|
style_quotation = LTerm_style.none;
|
|
style_comment = LTerm_style.none;
|
|
style_doc = LTerm_style.none;
|
|
style_blanks = LTerm_style.none;
|
|
style_error = LTerm_style.none;
|
|
style_directive = LTerm_style.none;
|
|
style_paren = LTerm_style.none;
|
|
}
|
|
|
|
let init_resources () =
|
|
try_lwt
|
|
lwt res = LTerm_resources.load (Filename.concat (try Sys.getenv "HOME" with Not_found -> "") ".utoprc") in
|
|
styles.style_keyword <- LTerm_resources.get_style "keyword" res;
|
|
styles.style_symbol <- LTerm_resources.get_style "symbol" res;
|
|
styles.style_ident <- LTerm_resources.get_style "identifier" res;
|
|
styles.style_module <- LTerm_resources.get_style "module" res;
|
|
styles.style_constant <- LTerm_resources.get_style "constant" res;
|
|
styles.style_char <- LTerm_resources.get_style "char" res;
|
|
styles.style_string <- LTerm_resources.get_style "string" res;
|
|
styles.style_quotation <- LTerm_resources.get_style "quotation" res;
|
|
styles.style_comment <- LTerm_resources.get_style "comment" res;
|
|
styles.style_doc <- LTerm_resources.get_style "doc" res;
|
|
styles.style_blanks <- LTerm_resources.get_style "blanks" res;
|
|
styles.style_error <- LTerm_resources.get_style "error" res;
|
|
styles.style_directive <- LTerm_resources.get_style "directive" res;
|
|
styles.style_paren <- LTerm_resources.get_style "parenthesis" res;
|
|
(match String.lowercase (LTerm_resources.get "profile" res) with
|
|
| "light" -> UTop.set_profile UTop.Light
|
|
| "dark" -> UTop.set_profile UTop.Dark
|
|
| "" -> ()
|
|
| str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str)));
|
|
return ()
|
|
with Unix.Unix_error(Unix.ENOENT, _, _) ->
|
|
return ()
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| History |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
let history = ref []
|
|
|
|
let init_history () =
|
|
let hist_name = Filename.concat (try Sys.getenv "HOME" with Not_found -> "") ".utop-history" in
|
|
(* Save history on exit. *)
|
|
Lwt_main.at_exit (fun () -> LTerm_read_line.save_history hist_name !history);
|
|
(* Load history. *)
|
|
lwt h = LTerm_read_line.load_history hist_name in
|
|
history := h;
|
|
return ()
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| The read-line class |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
(* The pending line to add to the history. *)
|
|
let pending = ref None
|
|
|
|
let lparen = UChar.of_char '('
|
|
let rparen = UChar.of_char ')'
|
|
let lbrace = UChar.of_char '{'
|
|
let rbrace = UChar.of_char '}'
|
|
let lbracket = UChar.of_char '['
|
|
let rbracket = UChar.of_char ']'
|
|
|
|
let rec last = function
|
|
| [] -> None
|
|
| [x] -> Some x
|
|
| _ :: l -> last l
|
|
|
|
class read_line ~term ~prompt =
|
|
let pending =
|
|
match !pending with
|
|
| None -> ""
|
|
| Some line -> line ^ "\n"
|
|
in
|
|
let pending_length = Zed_utf8.length pending in
|
|
object(self)
|
|
inherit LTerm_read_line.read_line ~history:!history () as super
|
|
inherit [Zed_utf8.t] LTerm_read_line.term term as super_term
|
|
|
|
method exec = function
|
|
| LTerm_read_line.Accept :: actions when !UTop.smart_accept && S.value self#mode = LTerm_read_line.Edition -> begin
|
|
Zed_macro.add self#macro LTerm_read_line.Accept;
|
|
let tokens = UTop_lexer.lex_string (pending ^ Zed_rope.to_string (Zed_edit.text self#edit)) in
|
|
match last tokens with
|
|
| Some (Symbol, _, _, ";;") ->
|
|
return self#eval
|
|
| _ ->
|
|
self#insert (UChar.of_char '\n');
|
|
self#exec actions
|
|
end
|
|
| actions ->
|
|
super_term#exec actions
|
|
|
|
method stylise last =
|
|
let styled, position = super#stylise last in
|
|
|
|
(* Syntax highlighting *)
|
|
let stylise start stop token_style =
|
|
for i = max 0 (start - pending_length) to stop - pending_length - 1 do
|
|
let ch, style = styled.(i) in
|
|
styled.(i) <- (ch, LTerm_style.merge token_style style)
|
|
done
|
|
in
|
|
let rec loop tokens =
|
|
match tokens with
|
|
| [] ->
|
|
()
|
|
| (token, start, stop, src) :: rest ->
|
|
match token with
|
|
| Symbol ->
|
|
stylise start stop styles.style_symbol;
|
|
loop rest
|
|
| Lident ->
|
|
stylise start stop
|
|
(if String_set.mem src !UTop.keywords then
|
|
styles.style_keyword
|
|
else
|
|
styles.style_ident);
|
|
loop rest
|
|
| Uident ->
|
|
if String_set.mem src !UTop.keywords then begin
|
|
stylise start stop styles.style_keyword;
|
|
loop rest
|
|
end else
|
|
loop_after_uident start stop rest
|
|
| Constant ->
|
|
stylise start stop styles.style_constant;
|
|
loop rest
|
|
| Char ->
|
|
stylise start stop styles.style_char;
|
|
loop rest
|
|
| String _ ->
|
|
stylise start stop styles.style_string;
|
|
loop rest
|
|
| Quotation _ ->
|
|
stylise start stop styles.style_quotation;
|
|
loop rest
|
|
| Comment _ ->
|
|
stylise start stop styles.style_comment;
|
|
loop rest
|
|
| Doc _ ->
|
|
stylise start stop styles.style_doc;
|
|
loop rest
|
|
| Blanks ->
|
|
stylise start stop styles.style_blanks;
|
|
loop rest
|
|
| Error ->
|
|
stylise start stop styles.style_error;
|
|
loop rest
|
|
and loop_after_uident uid_start uid_stop tokens =
|
|
match tokens with
|
|
| [] ->
|
|
()
|
|
| (token, start, stop, src) :: rest ->
|
|
match token with
|
|
| Symbol ->
|
|
if src = "." then
|
|
stylise uid_start uid_stop styles.style_module
|
|
else
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
stylise start stop styles.style_symbol;
|
|
loop rest
|
|
| Lident ->
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
stylise start stop
|
|
(if String_set.mem src !UTop.keywords then
|
|
styles.style_keyword
|
|
else
|
|
styles.style_ident);
|
|
loop rest
|
|
| Uident ->
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
if String_set.mem src !UTop.keywords then begin
|
|
stylise start stop styles.style_keyword;
|
|
loop rest
|
|
end else
|
|
loop_after_uident start stop rest
|
|
| Constant ->
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
stylise start stop styles.style_constant;
|
|
loop rest
|
|
| Char ->
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
stylise start stop styles.style_char;
|
|
loop rest
|
|
| String _ ->
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
stylise start stop styles.style_string;
|
|
loop rest
|
|
| Quotation _ ->
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
stylise start stop styles.style_quotation;
|
|
loop rest
|
|
| Comment _ ->
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
stylise start stop styles.style_comment;
|
|
loop_after_uident uid_start uid_stop rest
|
|
| Doc _ ->
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
stylise start stop styles.style_doc;
|
|
loop_after_uident uid_start uid_stop rest
|
|
| Blanks ->
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
stylise start stop styles.style_blanks;
|
|
loop_after_uident uid_start uid_stop rest
|
|
| Error ->
|
|
stylise uid_start uid_stop styles.style_ident;
|
|
stylise start stop styles.style_error;
|
|
loop rest
|
|
and loop_sharp tokens =
|
|
match tokens with
|
|
| [] ->
|
|
()
|
|
| (token, start, stop, src) :: rest ->
|
|
match token with
|
|
| Symbol ->
|
|
if src = "#" then begin
|
|
stylise start stop styles.style_directive;
|
|
loop_directive rest
|
|
end else begin
|
|
stylise start stop styles.style_symbol;
|
|
loop rest
|
|
end
|
|
| Lident ->
|
|
stylise start stop
|
|
(if String_set.mem src !UTop.keywords then
|
|
styles.style_keyword
|
|
else
|
|
styles.style_ident);
|
|
loop rest
|
|
| Uident ->
|
|
if String_set.mem src !UTop.keywords then begin
|
|
stylise start stop styles.style_keyword;
|
|
loop rest
|
|
end else
|
|
loop_after_uident start stop rest
|
|
| Constant ->
|
|
stylise start stop styles.style_constant;
|
|
loop rest
|
|
| Char ->
|
|
stylise start stop styles.style_char;
|
|
loop rest
|
|
| String _ ->
|
|
stylise start stop styles.style_string;
|
|
loop rest
|
|
| Quotation _ ->
|
|
stylise start stop styles.style_quotation;
|
|
loop rest
|
|
| Comment _ ->
|
|
stylise start stop styles.style_comment;
|
|
loop_sharp rest
|
|
| Doc _ ->
|
|
stylise start stop styles.style_doc;
|
|
loop_sharp rest
|
|
| Blanks ->
|
|
stylise start stop styles.style_blanks;
|
|
loop_sharp rest
|
|
| Error ->
|
|
stylise start stop styles.style_error;
|
|
loop rest
|
|
and loop_directive tokens =
|
|
match tokens with
|
|
| [] ->
|
|
()
|
|
| (token, start, stop, src) :: rest ->
|
|
match token with
|
|
| Symbol ->
|
|
stylise start stop styles.style_symbol;
|
|
loop rest
|
|
| Lident ->
|
|
stylise start stop
|
|
(if String_set.mem src !UTop.keywords then
|
|
styles.style_keyword
|
|
else
|
|
styles.style_directive);
|
|
loop rest
|
|
| Uident ->
|
|
if String_set.mem src !UTop.keywords then begin
|
|
stylise start stop styles.style_keyword;
|
|
loop rest
|
|
end else
|
|
loop_after_uident start stop rest
|
|
| Constant ->
|
|
stylise start stop styles.style_constant;
|
|
loop rest
|
|
| Char ->
|
|
stylise start stop styles.style_char;
|
|
loop rest
|
|
| String _ ->
|
|
stylise start stop styles.style_string;
|
|
loop rest
|
|
| Quotation _ ->
|
|
stylise start stop styles.style_quotation;
|
|
loop rest
|
|
| Comment _ ->
|
|
stylise start stop styles.style_comment;
|
|
loop_directive rest
|
|
| Doc _ ->
|
|
stylise start stop styles.style_doc;
|
|
loop_directive rest
|
|
| Blanks ->
|
|
stylise start stop styles.style_blanks;
|
|
loop_directive rest
|
|
| Error ->
|
|
stylise start stop styles.style_error;
|
|
loop rest
|
|
in
|
|
let tokens = UTop_lexer.lex_string (pending ^ LTerm_text.to_string styled) in
|
|
loop_sharp tokens;
|
|
|
|
(* Parenthesis matching. *)
|
|
if not last then LTerm_text.stylise_parenthesis styled position styles.style_paren;
|
|
|
|
(styled, position)
|
|
|
|
method completion =
|
|
let pos, words = UTop_complete.complete (pending ^ Zed_rope.to_string self#input_prev) in
|
|
if pos < pending_length then self#set_completion 0 [] else self#set_completion (pos - pending_length) words
|
|
|
|
initializer
|
|
(* Set the source signal for the size of the terminal. *)
|
|
UTop_private.set_size self#size;
|
|
(* Set the source signal for the key sequence. *)
|
|
UTop_private.set_key_sequence self#key_sequence;
|
|
(* Set the prompt. *)
|
|
self#set_prompt prompt;
|
|
(* Call hooks. *)
|
|
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks
|
|
end
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Toplevel integration |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
(* The text typed by the user. *)
|
|
let input = ref ""
|
|
|
|
(* The position of the text already sent to ocaml in {!input}. *)
|
|
let pos = ref 0
|
|
|
|
(* Is it the first time [read_input] is called ? *)
|
|
let first_run = ref true
|
|
|
|
(* The read function given to ocaml. *)
|
|
let rec read_input term prompt buffer len =
|
|
try
|
|
if !pos = String.length !input then begin
|
|
(* We need to get more input from the user. *)
|
|
|
|
let prompt_to_display =
|
|
match prompt with
|
|
| "# " ->
|
|
(* Reset completion. *)
|
|
UTop_complete.reset ();
|
|
|
|
(* increment the command counter. *)
|
|
UTop_private.set_count (S.value UTop_private.count + 1);
|
|
|
|
(* Add the previous line to the history. *)
|
|
(match !pending with
|
|
| None ->
|
|
()
|
|
| Some line ->
|
|
history := LTerm_read_line.add_entry line !history;
|
|
pending := None);
|
|
|
|
(* Call hooks. *)
|
|
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks;
|
|
|
|
!UTop.prompt
|
|
|
|
| "* " ->
|
|
!UTop.prompt_comment
|
|
|
|
| " " ->
|
|
!UTop.prompt_continue
|
|
|
|
| _ ->
|
|
Printf.ksprintf failwith "unknown prompt %S" prompt
|
|
in
|
|
|
|
(* Read interactively user input. *)
|
|
let txt = Lwt_main.run (
|
|
try_lwt
|
|
lwt () =
|
|
if !first_run then begin
|
|
first_run := false;
|
|
LTerm.fprint term "Type #utop_help for help about using utop.\n\n"
|
|
end else
|
|
return ()
|
|
in
|
|
(new read_line ~term ~prompt:prompt_to_display)#run
|
|
finally
|
|
LTerm.flush term
|
|
) in
|
|
|
|
pending := Some (match !pending with
|
|
| None -> txt
|
|
| Some line -> line ^ "\n" ^ txt);
|
|
|
|
(* Add a newline character at the end. *)
|
|
input := txt ^ "\n";
|
|
pos := 0;
|
|
|
|
read_input term prompt buffer len
|
|
end else begin
|
|
(* There is still some pending input. *)
|
|
let i = ref 0 in
|
|
while !i < len && !pos < String.length !input do
|
|
buffer.[!i] <- (!input).[!pos];
|
|
incr i;
|
|
incr pos
|
|
done;
|
|
(!i, false)
|
|
end
|
|
with LTerm_read_line.Interrupt ->
|
|
(0, true)
|
|
|
|
let read_input_non_interactive prompt buffer len =
|
|
let rec loop i =
|
|
if i = len then
|
|
return (i, false)
|
|
else
|
|
Lwt_io.read_char_opt Lwt_io.stdin >>= function
|
|
| Some c ->
|
|
buffer.[i] <- c;
|
|
if c = '\n' then
|
|
return (i + 1, false)
|
|
else
|
|
loop (i + 1)
|
|
| None ->
|
|
return (i, true)
|
|
in
|
|
Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >> loop 0)
|
|
|
|
let init_read_interactive_input () =
|
|
(* If standard channels are connected to a tty, use interactive
|
|
read-line and display a welcome message: *)
|
|
if Unix.isatty Unix.stdin && Unix.isatty Unix.stdout then begin
|
|
(* Open the standard terminal. *)
|
|
lwt term = Lazy.force LTerm.stdout in
|
|
|
|
Toploop.read_interactive_input := (read_input term);
|
|
|
|
(* Create a context to render the welcome message. *)
|
|
lwt size = LTerm.get_size term in
|
|
let size = { rows = 3; cols = size.cols } in
|
|
let matrix = LTerm_draw.make_matrix size in
|
|
let ctx = LTerm_draw.context matrix size in
|
|
|
|
(* Draw the message in a box. *)
|
|
|
|
let message = "Welcome to utop!" in
|
|
|
|
LTerm_draw.fill_style ctx LTerm_style.({ none with foreground = Some lcyan });
|
|
|
|
LTerm_draw.draw_hline ctx 0 0 size.cols LTerm_draw.Light;
|
|
LTerm_draw.draw_frame ctx {
|
|
row1 = 0;
|
|
row2 = 3;
|
|
col1 = (size.cols - (String.length message + 4)) / 2;
|
|
col2 = (size.cols + (String.length message + 4)) / 2;
|
|
} LTerm_draw.Light;
|
|
|
|
LTerm_draw.draw_styled ctx 1 ((size.cols - String.length message) / 2) (eval [B_fg LTerm_style.yellow; S message]);
|
|
|
|
(* Render to the screen. *)
|
|
lwt () = LTerm.print_box term matrix in
|
|
LTerm.flush term
|
|
end else begin
|
|
(* Otherwise fallback to classic non-interactive mode: *)
|
|
Toploop.read_interactive_input := read_input_non_interactive;
|
|
return ()
|
|
end
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
| Initialization |
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
lwt () = join [
|
|
init_history ();
|
|
init_resources ();
|
|
init_read_interactive_input ();
|
|
LTerm_inputrc.load ();
|
|
]
|