next gen utop
Ignore-this: c0e7aa3db012df3af520003d99403929 - reimplement the toplevel loop without using the standard one - handle ocaml parsing/typing/compilation error messages to correctly highlight error locations in the console and in emacs - detect incomplete input and don't try to evaluate it - automatically run with Lwt_main.run values with type _ Lwt.t - colorize values darcs-hash:20120211092107-c41ad-de115ed1ec0806b4261a3182f58fb2498e040d9d
This commit is contained in:
Jeremie Dimino
parent
5deae637a0
commit
4a43491f55
53
_oasis
53
_oasis
|
|
@ -14,14 +14,7 @@ BuildTools: ocamlbuild
|
|||
Plugins: DevFiles (0.2), META (0.2)
|
||||
Synopsis: utop
|
||||
Description: Universal toplevel for OCaml
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
# | Flags |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
||||
Flag gtk
|
||||
Description: Build the GTK interface
|
||||
Default: false
|
||||
FilesAB: src/lib/uTop_version.ml.ab
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
# | The toplevel |
|
||||
|
|
@ -35,36 +28,38 @@ Library "optcomp"
|
|||
CompiledObject: byte
|
||||
|
||||
Library utop
|
||||
Path: src/common
|
||||
Modules: UTop
|
||||
InternalModules: UTop_private
|
||||
BuildDepends: findlib, lambda-term (>= 1.1), lwt.syntax
|
||||
Path: src/lib
|
||||
Modules:
|
||||
UTop,
|
||||
UTop_main
|
||||
InternalModules:
|
||||
UTop_private,
|
||||
UTop_version,
|
||||
UTop_lexer,
|
||||
UTop_token,
|
||||
UTop_complete,
|
||||
UTop_styles
|
||||
BuildDepends: findlib, lambda-term (>= 1.1), lwt.syntax, threads
|
||||
XMETADescription: utop configuration
|
||||
XMETARequires: findlib, lambda-term
|
||||
|
||||
Library "utop-camlp4"
|
||||
FindlibName: camlp4
|
||||
FindlibParent: utop
|
||||
Path: src/camlp4
|
||||
InternalModules: UTop_camlp4
|
||||
BuildDepends: utop, camlp4
|
||||
XMETAType: syntax
|
||||
XMETADescription: Camlp4 integration
|
||||
|
||||
Executable utop
|
||||
Install: true
|
||||
Path: src/console
|
||||
Path: src/top
|
||||
CompiledObject: byte
|
||||
MainIs: uTop_console_top.ml
|
||||
BuildDepends: utop, findlib, lambda-term, lwt.syntax
|
||||
|
||||
Executable "utop-emacs"
|
||||
Install: true
|
||||
Path: src/emacs
|
||||
CompiledObject: byte
|
||||
MainIs: uTop_emacs_top.ml
|
||||
MainIs: uTop_top.ml
|
||||
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads
|
||||
DataFiles: utop.el ($datadir/emacs/site-lisp)
|
||||
|
||||
Executable "utop-gtk"
|
||||
Install$: flag(gtk)
|
||||
Build$: flag(gtk)
|
||||
Path: src/gtk
|
||||
CompiledObject: byte
|
||||
MainIs: uTop_gtk_top.ml
|
||||
BuildDepends: utop, findlib, lambda-term, lwt.syntax, threads, lablgtk2, lwt.glib
|
||||
|
||||
# +-------------------------------------------------------------------+
|
||||
# | Doc |
|
||||
# +-------------------------------------------------------------------+
|
||||
|
|
|
|||
4
_tags
4
_tags
|
|
@ -6,8 +6,8 @@
|
|||
# Do not use optcomp on syntax extensions
|
||||
<syntax/*.ml>: -pa_optcomp
|
||||
|
||||
# Completion needs compiler interfaces
|
||||
<src/common/*.ml>: use_compiler_libs
|
||||
# Use compiler interfaces
|
||||
<src/**/*.ml{,i}>: use_compiler_libs
|
||||
|
||||
# OASIS_START
|
||||
# OASIS_STOP
|
||||
|
|
|
|||
1
boring
1
boring
|
|
@ -2,3 +2,4 @@
|
|||
^utop-.*\.tar\.gz$
|
||||
^setup\.data$
|
||||
^setup\.log$
|
||||
^src/lib/uTop_version.ml$
|
||||
|
|
|
|||
|
|
@ -10,9 +10,6 @@
|
|||
(* OASIS_START *)
|
||||
(* OASIS_STOP *)
|
||||
|
||||
(* List of toplevels. *)
|
||||
let toplevels = ["console"; "emacs"; "gtk"]
|
||||
|
||||
let () =
|
||||
dispatch
|
||||
(fun hook ->
|
||||
|
|
@ -23,17 +20,12 @@ let () =
|
|||
|
||||
| After_rules ->
|
||||
(* Copy tags from *.byte to *.top *)
|
||||
List.iter
|
||||
(fun name ->
|
||||
let src = "src" / name / ("uTop_" ^ name ^ "_top.byte")
|
||||
and dst = "src" / name / ("uTop_" ^ name ^ "_top.top") in
|
||||
tag_file
|
||||
dst
|
||||
"src/top/uTop_top.top"
|
||||
(List.filter
|
||||
(* Remove the "file:..." tag and syntax extensions. *)
|
||||
(fun tag -> not (String.is_prefix "file:" tag) && not (String.is_suffix tag ".syntax"))
|
||||
(Tags.elements (tags_of_pathname src))))
|
||||
toplevels;
|
||||
(Tags.elements (tags_of_pathname "src/top/uTop_top.byte")));
|
||||
|
||||
(* Use -linkpkg for creating toplevels *)
|
||||
flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg";
|
||||
|
|
@ -95,6 +87,6 @@ let () =
|
|||
Cmd (S [A (stdlib / "expunge");
|
||||
A (env "%.top");
|
||||
A (env "%.byte");
|
||||
A "UTop"; S(List.map (fun x -> A x) (StringSet.elements modules))]))
|
||||
A "UTop"; A "UTop_private"; S(List.map (fun x -> A x) (StringSet.elements modules))]))
|
||||
| _ ->
|
||||
())
|
||||
|
|
|
|||
|
|
@ -0,0 +1,62 @@
|
|||
(*
|
||||
* uTop_camlp4.ml
|
||||
* --------------
|
||||
* Copyright : (c) 2012, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
open Lexing
|
||||
open Camlp4
|
||||
open Camlp4.PreCast
|
||||
|
||||
module Ast2pt = Camlp4.Struct.Camlp4Ast2OCamlAst.Make(Ast)
|
||||
|
||||
external cast_toplevel_phrase : Camlp4_import.Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase = "%identity"
|
||||
|
||||
let print_camlp4_error pp exn =
|
||||
Format.fprintf pp "@[<0>%a@]" Camlp4.ErrorHandler.print exn;
|
||||
Format.pp_print_flush pp ()
|
||||
|
||||
let parse_toplevel_phrase_camlp4 str eos_is_error =
|
||||
let eof = ref false in
|
||||
try
|
||||
let token_stream = Gram.filter (Gram.lex_string (Loc.mk UTop.input_name) str) in
|
||||
let token_stream =
|
||||
Stream.from
|
||||
(fun _ ->
|
||||
match Stream.next token_stream with
|
||||
| (EOI, _) as x ->
|
||||
eof := true;
|
||||
Some x
|
||||
| x ->
|
||||
Some x)
|
||||
in
|
||||
match Gram.parse_tokens_after_filter Syntax.top_phrase token_stream with
|
||||
| Some str_item ->
|
||||
let str_item = AstFilters.fold_topphrase_filters (fun t filter -> filter t) str_item in
|
||||
UTop.Value (cast_toplevel_phrase (Ast2pt.phrase str_item))
|
||||
| None ->
|
||||
raise UTop.Need_more
|
||||
with exn ->
|
||||
if !eof && not eos_is_error then
|
||||
raise UTop.Need_more
|
||||
else
|
||||
let locs, exn =
|
||||
match exn with
|
||||
| Loc.Exc_located (loc, exn) ->
|
||||
([(Loc.start_off loc,Loc.stop_off loc)], exn)
|
||||
| exn ->
|
||||
([], exn)
|
||||
in
|
||||
UTop.Error (locs, UTop.get_message print_camlp4_error exn)
|
||||
|
||||
let () =
|
||||
UTop.set_camlp4 true;
|
||||
UTop.parse_toplevel_phrase := parse_toplevel_phrase_camlp4;
|
||||
(* Force camlp4 to display its error message. *)
|
||||
try
|
||||
ignore (!Toploop.parse_toplevel_phrase (Lexing.from_string ""))
|
||||
with _ ->
|
||||
()
|
||||
|
|
@ -1,99 +0,0 @@
|
|||
(*
|
||||
* uTop.mli
|
||||
* --------
|
||||
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
(** UTop configuration. *)
|
||||
|
||||
val count : int React.signal
|
||||
(** The number of commands already executed. *)
|
||||
|
||||
val keywords : Set.Make(String).t ref
|
||||
(** The set of OCaml keywords. *)
|
||||
|
||||
val add_keyword : string -> unit
|
||||
(** Add a new OCaml keyword. *)
|
||||
|
||||
type ui = Console | GTK | Emacs
|
||||
(** The user interface in use. *)
|
||||
|
||||
val get_ui : unit -> ui
|
||||
(** Returns the user interface in use. *)
|
||||
|
||||
(** {6 GTK specific utilities} *)
|
||||
|
||||
val exec_in_gui : (unit -> unit) -> unit
|
||||
(** [exec_in_gui f] executes [f] in the thread that handle the
|
||||
UI. The only use of this function is to call [window#show ()] on
|
||||
Windows:
|
||||
|
||||
Since windows are attached to a thread on Windows and utop
|
||||
handle the UI in a separate thread, doing [window#show ()] in
|
||||
the toplevel UI will not work. *)
|
||||
|
||||
(** {6 Console/GTK specific configuration} *)
|
||||
|
||||
type profile = Dark | Light
|
||||
(** Profile for colors. *)
|
||||
|
||||
val profile : profile React.signal
|
||||
(** The color profile. It defaults to {!Dark}. This is used by the
|
||||
default prompt to choose colors. *)
|
||||
|
||||
val set_profile : profile -> unit
|
||||
(** Sets the color profile. *)
|
||||
|
||||
val smart_accept : bool ref
|
||||
(** If [true], then only lines terminated with ";;" will be sent to
|
||||
ocaml, otherwise the input will always be sent to ocaml when the
|
||||
user press Enter. It default to [true]. *)
|
||||
|
||||
val size : LTerm_geom.size React.signal
|
||||
(** The current size of the terminal. This is used only in the
|
||||
console UI. *)
|
||||
|
||||
val key_sequence : LTerm_key.t list React.signal
|
||||
(** The current key sequence entered by the user. This is used only
|
||||
in the console UI. *)
|
||||
|
||||
val time : float ref
|
||||
(** The time of the beginning of the current command. *)
|
||||
|
||||
val prompt : LTerm_text.t React.signal ref
|
||||
(** The current prompt.
|
||||
|
||||
For compatibility with ocaml error printing, it must ends with a
|
||||
line of length 2 in the console UI. *)
|
||||
|
||||
val prompt_continue : LTerm_text.t React.signal ref
|
||||
(** The prompt used to continue unterminated phrase.
|
||||
|
||||
For compatibility with ocaml error printing, it must ends with a
|
||||
line of length 2 in the console UI. *)
|
||||
|
||||
val prompt_comment : LTerm_text.t React.signal ref
|
||||
(** The prompt used to continue unterminated comments.
|
||||
|
||||
For compatibility with ocaml error printing, it must ends with a
|
||||
line of length 2 in the console UI. *)
|
||||
|
||||
(** {6 Hooks} *)
|
||||
|
||||
val new_command_hooks : (unit -> unit) Lwt_sequence.t
|
||||
(** Functions called before each new command. *)
|
||||
|
||||
val at_new_command : (unit -> unit) -> unit
|
||||
(** [at_new_command f] adds [f] to the hooks executed before each
|
||||
new commands. *)
|
||||
|
||||
val new_prompt_hooks : (unit -> unit) Lwt_sequence.t
|
||||
(** Functions executed before each new prompt, including
|
||||
continuation prompts. *)
|
||||
|
||||
val at_new_prompt : (unit -> unit) -> unit
|
||||
(** [at_new_prompt f] adds [f] to the hooks executed before each new
|
||||
prompt. *)
|
||||
|
|
@ -1,276 +0,0 @@
|
|||
(*
|
||||
* 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
|
||||
open UTop_styles
|
||||
|
||||
module String_set = Set.Make(String)
|
||||
|
||||
let () = UTop_private.set_ui UTop_private.Console
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| History |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let history = ref []
|
||||
|
||||
let init_history () =
|
||||
let hist_name = Filename.concat LTerm_resources.home ".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
|
||||
UTop_styles.stylise stylise (UTop_lexer.lex_string (pending ^ LTerm_text.to_string styled));
|
||||
|
||||
(* 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 () =
|
||||
(* Open the standard terminal. *)
|
||||
lwt term = Lazy.force LTerm.stdout in
|
||||
(* If standard channels are connected to a tty, use interactive
|
||||
read-line and display a welcome message: *)
|
||||
if LTerm.incoming_is_a_tty term && LTerm.outgoing_is_a_tty term then begin
|
||||
Toploop.read_interactive_input := (read_input term);
|
||||
|
||||
(* Create a context to render the welcome message. *)
|
||||
let size = LTerm.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]);
|
||||
|
||||
(* On Windows we must make sure we are not at the end of screen. *)
|
||||
lwt () =
|
||||
if LTerm.windows term then
|
||||
LTerm.fprint term "\n\n\n\n"
|
||||
else
|
||||
return ()
|
||||
in
|
||||
|
||||
(* Render to the screen. *)
|
||||
lwt () = LTerm.print_box term ~delta:(if LTerm.windows term then -4 else 0) 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 ();
|
||||
UTop_styles.load ();
|
||||
init_read_interactive_input ();
|
||||
LTerm_inputrc.load ();
|
||||
]
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
UTop_console
|
||||
UTop_lexer
|
||||
UTop_token
|
||||
UTop_complete
|
||||
UTop_styles
|
||||
|
|
@ -1,218 +0,0 @@
|
|||
(*
|
||||
* uTop_emacs.ml
|
||||
* -------------
|
||||
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
(* Main for emacs mode. *)
|
||||
|
||||
open Lwt
|
||||
|
||||
let () = UTop_private.set_ui UTop_private.Emacs
|
||||
|
||||
(* Copy standard output, which will be used to send commands. *)
|
||||
let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Sending commands to Emacs |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* Mutex used to send commands to Emacs. *)
|
||||
let command_mutex = Mutex.create ()
|
||||
|
||||
let send command argument =
|
||||
Mutex.lock command_mutex;
|
||||
output_string command_oc command;
|
||||
output_char command_oc ':';
|
||||
output_string command_oc argument;
|
||||
output_char command_oc '\n';
|
||||
flush command_oc;
|
||||
Mutex.unlock command_mutex
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Standard outputs redirection |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* The output of ocaml (stdout and stderr) is redirected so the emacs
|
||||
parts of celtop can recognize it. *)
|
||||
|
||||
(* Continuously copy the output of ocaml to Emacs. *)
|
||||
let rec copy_output which ic =
|
||||
let line = input_line ic in
|
||||
send which line;
|
||||
copy_output which ic
|
||||
|
||||
(* Create a thread which redirect the given output: *)
|
||||
let redirect which fd =
|
||||
let fdr, fdw = Unix.pipe () in
|
||||
Unix.dup2 fdw fd;
|
||||
Unix.close fdw;
|
||||
Thread.create (copy_output which) (Unix.in_channel_of_descr fdr)
|
||||
|
||||
(* Redirects stdout and stderr: *)
|
||||
let _ = redirect "stdout" Unix.stdout
|
||||
let _ = redirect "stderr" Unix.stderr
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Input |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* The text typed by the user. *)
|
||||
let input = ref ""
|
||||
|
||||
(* The position of the text already sent to ocaml in {!input}. *)
|
||||
let pos = ref 0
|
||||
|
||||
let read_line () =
|
||||
let behavior = Sys.signal Sys.sigint Sys.Signal_ignore in
|
||||
try
|
||||
let line = Lwt_main.run (Lwt_io.read_line_opt Lwt_io.stdin) in
|
||||
Sys.set_signal Sys.sigint behavior;
|
||||
line
|
||||
with exn ->
|
||||
Sys.set_signal Sys.sigint behavior;
|
||||
raise exn
|
||||
|
||||
let read_command () =
|
||||
match read_line () with
|
||||
| None ->
|
||||
None
|
||||
| Some line ->
|
||||
match try Some (String.index line ':') with Not_found -> None with
|
||||
| None ->
|
||||
send "stderr" "':' missing!";
|
||||
exit 1
|
||||
| Some idx ->
|
||||
Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1)))
|
||||
|
||||
let read_data ?(final_newline = true) () =
|
||||
let buf = Buffer.create 1024 in
|
||||
let rec loop first =
|
||||
match read_command () with
|
||||
| None ->
|
||||
send "stderr" "'end' command missing!";
|
||||
exit 1
|
||||
| Some ("data", data) ->
|
||||
if not first then Buffer.add_char buf '\n';
|
||||
Buffer.add_string buf data;
|
||||
loop false
|
||||
| Some ("end", _) ->
|
||||
if final_newline then Buffer.add_char buf '\n';
|
||||
Buffer.contents buf
|
||||
| Some (command, argument) ->
|
||||
Printf.ksprintf (send "stderr") "'data' or 'end' command expected, got %S!" command;
|
||||
exit 1
|
||||
in
|
||||
loop true
|
||||
|
||||
let rec read_input prompt buffer length =
|
||||
if !pos = String.length !input then begin
|
||||
(match prompt with
|
||||
| "# " ->
|
||||
(* New phrase. *)
|
||||
|
||||
(* Reset completion. *)
|
||||
UTop_complete.reset ();
|
||||
|
||||
(* Increment the command counter. *)
|
||||
UTop_private.set_count (React.S.value UTop_private.count + 1);
|
||||
|
||||
(* Call hooks. *)
|
||||
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks;
|
||||
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
|
||||
|
||||
send "prompt" "";
|
||||
|
||||
| "* " | " " ->
|
||||
(* Continuation of the current phrase. *)
|
||||
|
||||
(* Call hooks. *)
|
||||
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
|
||||
|
||||
send "continue" ""
|
||||
| _ ->
|
||||
Printf.ksprintf (send "stderr") "unrecognized prompt %S!" prompt;
|
||||
exit 1);
|
||||
loop prompt buffer length
|
||||
end else begin
|
||||
(* There is still some pending input. *)
|
||||
let i = ref 0 in
|
||||
while !i < length && !pos < String.length !input do
|
||||
buffer.[!i] <- (!input).[!pos];
|
||||
incr i;
|
||||
incr pos
|
||||
done;
|
||||
(!i, false)
|
||||
end
|
||||
|
||||
and process prompt buffer length command argument =
|
||||
match command with
|
||||
| "input" ->
|
||||
input := read_data ();
|
||||
pos := 0;
|
||||
read_input prompt buffer length
|
||||
| "complete" ->
|
||||
let input = read_data ~final_newline:false () in
|
||||
let start, words = UTop_complete.complete input in
|
||||
let words = List.map fst words in
|
||||
let prefix = LTerm_read_line.common_prefix words in
|
||||
let index = String.length input - start in
|
||||
let suffix =
|
||||
if index > 0 && index <= String.length prefix then
|
||||
String.sub prefix index (String.length prefix - index)
|
||||
else
|
||||
""
|
||||
in
|
||||
if suffix = "" then begin
|
||||
send "completion-start" "";
|
||||
List.iter (fun word -> send "completion" word) words;
|
||||
send "completion-stop" "";
|
||||
end else
|
||||
send "completion-word" suffix;
|
||||
loop prompt buffer length
|
||||
| command ->
|
||||
Printf.ksprintf (send "stderr") "unrecognized command %S!" command;
|
||||
exit 1
|
||||
|
||||
and loop prompt buffer length =
|
||||
match read_command () with
|
||||
| None ->
|
||||
(0, true)
|
||||
| Some (command, argument) ->
|
||||
process prompt buffer length command argument
|
||||
|
||||
let () = Toploop.read_interactive_input := read_input
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Hacks |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* Force camlp4 to display its welcome message when it is loaded. *)
|
||||
|
||||
let () =
|
||||
List.iter
|
||||
(fun directive ->
|
||||
let orig =
|
||||
try
|
||||
match Hashtbl.find Toploop.directive_table directive with
|
||||
| Toploop.Directive_none func ->
|
||||
func
|
||||
| _ ->
|
||||
ignore
|
||||
with Not_found ->
|
||||
ignore
|
||||
in
|
||||
Hashtbl.replace Toploop.directive_table directive
|
||||
(Toploop.Directive_none
|
||||
(fun () ->
|
||||
orig ();
|
||||
(* Parse something so camlp4 will display its welcome
|
||||
message. *)
|
||||
try
|
||||
ignore (!Toploop.parse_toplevel_phrase (Lexing.from_string ""))
|
||||
with _ ->
|
||||
())))
|
||||
["camlp4o"; "camlp4r"]
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
UTop_emacs
|
||||
UTop_lexer
|
||||
UTop_token
|
||||
UTop_complete
|
||||
|
|
@ -1,485 +0,0 @@
|
|||
(*
|
||||
* uTop_gtk.ml
|
||||
* -----------
|
||||
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
open Lwt
|
||||
open Lwt_react
|
||||
open UTop_styles
|
||||
|
||||
let () = UTop_private.set_ui UTop_private.GTK
|
||||
|
||||
(* Copy stderr for errors. *)
|
||||
let stderr_fd = Unix.dup Unix.stderr
|
||||
let stderr = Unix.out_channel_of_descr stderr_fd
|
||||
|
||||
(* Logs to the original stderr: *)
|
||||
let () =
|
||||
Lwt_log.default := Lwt_log.channel ~close_mode:`Close ~channel:(Lwt_io.of_fd ~mode:Lwt_io.output (Lwt_unix.of_unix_file_descr ~blocking:true ~set_flags:false stderr_fd)) ()
|
||||
|
||||
(* Just to prevent ocaml from doing stuppid things with the
|
||||
terminal. *)
|
||||
let () = Unix.putenv "TERM" "dumb"
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Utils |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let colors_16 = [|
|
||||
(0x00, 0x00, 0x00);
|
||||
(0xcd, 0x00, 0x00);
|
||||
(0x00, 0xcd, 0x00);
|
||||
(0xcd, 0xcd, 0x00);
|
||||
(0x00, 0x00, 0xee);
|
||||
(0xcd, 0x00, 0xcd);
|
||||
(0x00, 0xcd, 0xcd);
|
||||
(0xe5, 0xe5, 0xe5);
|
||||
(0x7f, 0x7f, 0x7f);
|
||||
(0xff, 0x00, 0x00);
|
||||
(0x00, 0xff, 0x00);
|
||||
(0xff, 0xff, 0x00);
|
||||
(0x5c, 0x5c, 0xff);
|
||||
(0xff, 0x00, 0xff);
|
||||
(0x00, 0xff, 0xff);
|
||||
(0xff, 0xff, 0xff);
|
||||
|]
|
||||
|
||||
let color_of_term_color default = function
|
||||
| LTerm_style.Default ->
|
||||
default ()
|
||||
| LTerm_style.Index n ->
|
||||
if n >= 0 && n <= 15 then
|
||||
let r, g, b = colors_16.(n) in
|
||||
`RGB (r * 65535 / 255, g * 65535 / 255, b * 65535 / 255)
|
||||
else
|
||||
default ()
|
||||
| LTerm_style.RGB (r, g, b) ->
|
||||
`RGB (r * 65535 / 255, g * 65535 / 255, b * 65535 / 255)
|
||||
|
||||
let default_foreground () =
|
||||
match S.value UTop.profile with
|
||||
| UTop.Dark -> `WHITE
|
||||
| UTop.Light -> `BLACK
|
||||
|
||||
let default_background () =
|
||||
match S.value UTop.profile with
|
||||
| UTop.Dark -> `BLACK
|
||||
| UTop.Light -> `WHITE
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| History |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let history = ref []
|
||||
|
||||
let init_history () =
|
||||
let hist_name = Filename.concat LTerm_resources.home ".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 ()
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Glib main loop |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* Initializes GTK. *)
|
||||
let _ = GMain.init ~setlocale:false ()
|
||||
|
||||
let () =
|
||||
UTop_private.exec_in_gui :=
|
||||
(fun job ->
|
||||
ignore (Glib.Timeout.add ~ms:0 ~callback:(fun () -> job (); false)))
|
||||
|
||||
(* The glib main loop. *)
|
||||
let main () =
|
||||
while true do
|
||||
Lwt_glib.iter true
|
||||
done
|
||||
|
||||
(* Start the glib main loop in another thread. *)
|
||||
let _ = Thread.create main ()
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| GTK ui |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* Create the main window. *)
|
||||
let window = GWindow.window ~title:"utop" ~width:800 ~height:600 ~allow_shrink:true ()
|
||||
|
||||
(* The scrolled window which contains the edition widget. *)
|
||||
let scrolled_window = GBin.scrolled_window ~packing:window#add ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()
|
||||
|
||||
(* Create the edition widget which will contains ocaml output. *)
|
||||
let edit = GText.view ~packing:scrolled_window#add ~editable:false ()
|
||||
|
||||
(* The edition buffer. *)
|
||||
let edit_buffer = edit#buffer
|
||||
|
||||
(* Uneditable text tag. *)
|
||||
let frozen = edit#buffer#create_tag [`EDITABLE false]
|
||||
|
||||
(* Start of prompt. *)
|
||||
let prompt_start = ref 0
|
||||
|
||||
(* End of prompt. *)
|
||||
let prompt_stop = ref 0
|
||||
|
||||
(* Mutex used to protect access to [edit#buffer], [prompt_start] and
|
||||
[prompt_stop]. *)
|
||||
let edit_mutex = Mutex.create ()
|
||||
|
||||
(* [true] iff the current insertion is done by the computer and not by
|
||||
the user. *)
|
||||
let computer_insertion = ref false
|
||||
|
||||
(* Exit when the window is closed. *)
|
||||
let _ =
|
||||
window#connect#destroy (fun () ->
|
||||
(* Destroy the main window immedlatly,
|
||||
because the saving of history may take
|
||||
a while. *)
|
||||
window#destroy ();
|
||||
exit 0)
|
||||
|
||||
(* Condition which is signaled when the user press Return. *)
|
||||
let accept_cond = Lwt_condition.create ()
|
||||
|
||||
(* Notification used to notify the main thread that input is
|
||||
available. *)
|
||||
let notification = Lwt_unix.make_notification (Lwt_condition.signal accept_cond)
|
||||
|
||||
(* Accept current input when the user press Return. *)
|
||||
let _ =
|
||||
edit#event#connect#key_press
|
||||
(fun ev ->
|
||||
if GdkEvent.Key.keyval ev = GdkKeysyms._Return then
|
||||
Lwt_unix.send_notification notification;
|
||||
false)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Styling |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* Is there pending data ? *)
|
||||
let pending = ref false
|
||||
|
||||
(* Input sent to ocaml but not yet finished. *)
|
||||
let pending_string = ref ""
|
||||
|
||||
(* Length of pending input, in unicode characters. *)
|
||||
let pending_length = ref 0
|
||||
|
||||
let gdk_color spec = Gdk.Color.alloc ~colormap:edit#misc#colormap spec
|
||||
|
||||
let tag_of_term_style style =
|
||||
let props = [] in
|
||||
let props = if LTerm_style.bold style = Some true then `WEIGHT `BOLD :: props else props in
|
||||
let props = if LTerm_style.underline style = Some true then `UNDERLINE `SINGLE :: props else props in
|
||||
let props =
|
||||
if LTerm_style.reverse style = Some true then
|
||||
let props =
|
||||
match LTerm_style.foreground style with
|
||||
| Some color -> `BACKGROUND_GDK (gdk_color (color_of_term_color default_foreground color)) :: props
|
||||
| None -> `BACKGROUND_GDK (gdk_color (default_foreground ())) :: props
|
||||
in
|
||||
let props =
|
||||
match LTerm_style.background style with
|
||||
| Some color -> `FOREGROUND_GDK (gdk_color (color_of_term_color default_background color)) :: props
|
||||
| None -> `FOREGROUND_GDK (gdk_color (default_background ())) :: props
|
||||
in
|
||||
props
|
||||
else
|
||||
let props =
|
||||
match LTerm_style.foreground style with
|
||||
| Some color -> `FOREGROUND_GDK (gdk_color (color_of_term_color default_foreground color)) :: props
|
||||
| None -> props
|
||||
in
|
||||
let props =
|
||||
match LTerm_style.background style with
|
||||
| Some color -> `BACKGROUND_GDK (gdk_color (color_of_term_color default_background color)) :: props
|
||||
| None -> props
|
||||
in
|
||||
props
|
||||
in
|
||||
edit_buffer#create_tag props
|
||||
|
||||
(* Handle buffer modifications. *)
|
||||
let changed argv =
|
||||
if not !computer_insertion then begin
|
||||
Mutex.lock edit_mutex;
|
||||
let start = edit_buffer#get_iter (`OFFSET !prompt_stop) and stop = edit_buffer#end_iter in
|
||||
(* First remove all tags from the input. *)
|
||||
edit_buffer#remove_all_tags ~start ~stop;
|
||||
(* Syntax highlighting. *)
|
||||
let stylise start stop style =
|
||||
let start = !prompt_stop + max 0 (start - !pending_length) and stop = !prompt_stop + stop - !pending_length in
|
||||
if start < stop then begin
|
||||
let start = edit_buffer#get_iter (`OFFSET start) and stop = edit_buffer#get_iter (`OFFSET stop) in
|
||||
edit_buffer#apply_tag ~start ~stop (tag_of_term_style style)
|
||||
end
|
||||
in
|
||||
UTop_styles.stylise stylise (UTop_lexer.lex_string (!pending_string ^ edit_buffer#get_text ~start ~stop ()));
|
||||
Mutex.unlock edit_mutex
|
||||
end
|
||||
|
||||
let _ =
|
||||
GtkSignal.connect_by_name
|
||||
edit_buffer#as_buffer
|
||||
~name:"changed"
|
||||
~callback:(Gobject.Closure.create changed)
|
||||
~after:false
|
||||
|
||||
(* Insert the prompt. *)
|
||||
let insert_prompt ?(locked = true) prompt =
|
||||
if locked then Mutex.lock edit_mutex;
|
||||
computer_insertion := true;
|
||||
let iter = edit_buffer#get_iter (`OFFSET !prompt_start) in
|
||||
(* Remove the previous prompt. *)
|
||||
if !prompt_start < !prompt_stop then begin
|
||||
edit_buffer#delete ~start:iter ~stop:(edit_buffer#get_iter (`OFFSET !prompt_stop))
|
||||
end;
|
||||
(* Insert the text of the new one. *)
|
||||
edit_buffer#insert ~iter ~tags:[frozen] (LTerm_text.to_string prompt);
|
||||
(* Update the end of prompt. *)
|
||||
prompt_stop := iter#offset;
|
||||
(* Stylise it. *)
|
||||
let stylise start stop style =
|
||||
if start < stop then begin
|
||||
let start = edit_buffer#get_iter (`OFFSET (start + !prompt_start)) and stop = edit_buffer#get_iter (`OFFSET (stop + !prompt_start)) in
|
||||
edit_buffer#apply_tag ~start ~stop (tag_of_term_style style)
|
||||
end
|
||||
in
|
||||
let rec loop i j style =
|
||||
if j = Array.length prompt then
|
||||
stylise i j style
|
||||
else begin
|
||||
let _, style' = prompt.(j) in
|
||||
if LTerm_style.equal style style' then
|
||||
loop i (j + 1) style
|
||||
else begin
|
||||
stylise i j style;
|
||||
loop j (j + 1) style'
|
||||
end
|
||||
end
|
||||
in
|
||||
loop 0 0 LTerm_style.none;
|
||||
computer_insertion := false;
|
||||
if locked then Mutex.unlock edit_mutex
|
||||
|
||||
(* The current prompt. *)
|
||||
let current_prompt, set_current_prompt = S.create ~eq:(==) (S.const [||])
|
||||
|
||||
(* Update the prompt when it change. *)
|
||||
let () =
|
||||
E.keep
|
||||
(E.map
|
||||
(fun prompt ->
|
||||
(* Update it only if we are editing. *)
|
||||
if edit#editable then insert_prompt ~locked:true prompt)
|
||||
(S.changes (S.switch (S.value current_prompt) (S.changes current_prompt))))
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Standard outputs redirections |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let copy ic =
|
||||
while true do
|
||||
let line = input_line ic in
|
||||
Mutex.lock edit_mutex;
|
||||
(* Insert the line before the prompt. *)
|
||||
let iter = edit_buffer#get_iter (`OFFSET !prompt_start) in
|
||||
computer_insertion := true;
|
||||
edit_buffer#insert ~iter ~tags:[frozen] line;
|
||||
edit_buffer#insert ~iter ~tags:[frozen] "\n";
|
||||
computer_insertion := false;
|
||||
(* Advance the prompt. *)
|
||||
let delta = iter#offset - !prompt_start in
|
||||
prompt_start := !prompt_start + delta;
|
||||
prompt_stop := !prompt_stop + delta;
|
||||
Mutex.unlock edit_mutex
|
||||
done
|
||||
|
||||
let redirect fd =
|
||||
let fdr, fdw = Unix.pipe () in
|
||||
Unix.dup2 fdw fd;
|
||||
Unix.close fdw;
|
||||
Thread.create copy (Unix.in_channel_of_descr fdr)
|
||||
|
||||
let _ = redirect Unix.stdout
|
||||
let _ = redirect Unix.stderr
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| OCaml 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
|
||||
|
||||
let rec read_input prompt buffer length =
|
||||
if !pos = String.length !input then begin
|
||||
(match prompt with
|
||||
| "# " ->
|
||||
(* New phrase. *)
|
||||
|
||||
(* Reset completion. *)
|
||||
UTop_complete.reset ();
|
||||
|
||||
(* Increment the command counter. *)
|
||||
UTop_private.set_count (React.S.value UTop_private.count + 1);
|
||||
|
||||
(* Call hooks. *)
|
||||
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks;
|
||||
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
|
||||
|
||||
Mutex.lock edit_mutex;
|
||||
|
||||
(* Add the previous line to the history. *)
|
||||
if !pending then begin
|
||||
history := LTerm_read_line.add_entry !pending_string !history;
|
||||
pending := false;
|
||||
pending_string := "";
|
||||
pending_length := 0
|
||||
end;
|
||||
|
||||
(* Insert the prompt. *)
|
||||
let offset = edit_buffer#end_iter#offset in
|
||||
prompt_start := offset;
|
||||
prompt_stop := offset;
|
||||
insert_prompt ~locked:false (S.value !UTop.prompt);
|
||||
|
||||
Mutex.unlock edit_mutex;
|
||||
|
||||
set_current_prompt !UTop.prompt
|
||||
|
||||
| " " ->
|
||||
(* Continuation of the current phrase. *)
|
||||
|
||||
(* Call hooks. *)
|
||||
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
|
||||
|
||||
(* Insert the prompt. *)
|
||||
Mutex.lock edit_mutex;
|
||||
let offset = edit_buffer#end_iter#offset in
|
||||
prompt_start := offset;
|
||||
prompt_stop := offset;
|
||||
insert_prompt ~locked:false (S.value !UTop.prompt_continue);
|
||||
Mutex.unlock edit_mutex;
|
||||
|
||||
set_current_prompt !UTop.prompt_continue
|
||||
|
||||
| "* " ->
|
||||
(* Continuation of the current phrase (in a comment). *)
|
||||
|
||||
(* Call hooks. *)
|
||||
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_prompt_hooks;
|
||||
|
||||
(* Insert the prompt. *)
|
||||
Mutex.lock edit_mutex;
|
||||
let offset = edit_buffer#end_iter#offset in
|
||||
prompt_start := offset;
|
||||
prompt_stop := offset;
|
||||
insert_prompt ~locked:false (S.value !UTop.prompt_comment);
|
||||
Mutex.unlock edit_mutex;
|
||||
|
||||
set_current_prompt !UTop.prompt_comment
|
||||
|
||||
| _ ->
|
||||
(* Unknown prompt: error. *)
|
||||
|
||||
let dialog = GWindow.dialog ~title:"error" () in
|
||||
ignore (GMisc.label ~text:(Printf.sprintf "unrecognized prompt %S!" prompt) ~packing:dialog#vbox#add ());
|
||||
dialog#add_button_stock `OK `OK;
|
||||
ignore (dialog#run ());
|
||||
exit 1);
|
||||
|
||||
(* Make the buffer editable. *)
|
||||
edit#set_editable true;
|
||||
|
||||
(* Wait for the user to press Return. *)
|
||||
let () = Lwt_main.run (Lwt_condition.wait accept_cond) in
|
||||
|
||||
(* Make the buffer uneditable while ocaml is executing things. *)
|
||||
edit#set_editable false;
|
||||
|
||||
Mutex.lock edit_mutex;
|
||||
(* Get the user input. *)
|
||||
let start = edit_buffer#get_iter (`OFFSET !prompt_stop) and stop = edit_buffer#end_iter in
|
||||
let text = edit_buffer#get_text ~start ~stop () in
|
||||
(* Froze the input. *)
|
||||
edit_buffer#apply_tag ~start ~stop frozen;
|
||||
(* Advance the prompt. *)
|
||||
let offset = stop#offset in
|
||||
prompt_start := offset;
|
||||
prompt_stop := offset;
|
||||
Mutex.unlock edit_mutex;
|
||||
|
||||
input := text;
|
||||
pos := 0;
|
||||
|
||||
(* Add current input to pending input. *)
|
||||
if !pending then begin
|
||||
pending_string := !pending_string ^ "\n" ^ text;
|
||||
pending_length := !pending_length + 1 + Zed_utf8.length text
|
||||
end else begin
|
||||
pending := true;
|
||||
pending_string := text;
|
||||
pending_length := Zed_utf8.length text
|
||||
end;
|
||||
|
||||
read_input prompt buffer length
|
||||
end else begin
|
||||
(* There is still some pending input. *)
|
||||
let i = ref 0 in
|
||||
while !i < length && !pos < String.length !input do
|
||||
buffer.[!i] <- (!input).[!pos];
|
||||
incr i;
|
||||
incr pos
|
||||
done;
|
||||
(!i, false)
|
||||
end
|
||||
|
||||
let () = Toploop.read_interactive_input := read_input
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Initialization |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
lwt () = join [
|
||||
init_history ();
|
||||
UTop_styles.load ();
|
||||
]
|
||||
|
||||
(* Set the font of the edition buffer. *)
|
||||
let () =
|
||||
match styles.style_font with
|
||||
| Some font -> edit#misc#modify_font_by_name font
|
||||
| None -> ()
|
||||
|
||||
(* Set foreground color. *)
|
||||
let () =
|
||||
match styles.style_foreground with
|
||||
| Some color ->
|
||||
edit#misc#modify_text [(`NORMAL, color_of_term_color default_foreground color)]
|
||||
| None ->
|
||||
edit#misc#modify_text [(`NORMAL, default_foreground ())]
|
||||
|
||||
(* Set background color. *)
|
||||
let () =
|
||||
match styles.style_background with
|
||||
| Some color ->
|
||||
edit#misc#modify_base [(`NORMAL, color_of_term_color default_background color)]
|
||||
| None ->
|
||||
edit#misc#modify_base [(`NORMAL, default_background ())]
|
||||
|
||||
(* Show the window in the GUI thread, this is needed for windows. *)
|
||||
let () = UTop.exec_in_gui window#show
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
UTop_gtk
|
||||
UTop_lexer
|
||||
UTop_token
|
||||
UTop_complete
|
||||
UTop_styles
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
(* Must be the same as driver/errors.mli from ocaml sources. *)
|
||||
open Format
|
||||
val report_error : formatter -> exn -> unit
|
||||
|
|
@ -15,15 +15,44 @@ open LTerm_style
|
|||
|
||||
module String_set = Set.Make(String)
|
||||
|
||||
let version = UTop_version.version
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| UI |
|
||||
| Hooks |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type ui = UTop_private.ui = Console | GTK | Emacs
|
||||
let new_command_hooks = Lwt_sequence.create ()
|
||||
let at_new_command f = ignore (Lwt_sequence.add_l f new_command_hooks)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Config |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type ui = UTop_private.ui = Console | Emacs
|
||||
|
||||
let get_ui () = S.value UTop_private.ui
|
||||
|
||||
let exec_in_gui f = !UTop_private.exec_in_gui f
|
||||
type profile = Dark | Light
|
||||
|
||||
let profile, set_profile = S.create Dark
|
||||
|
||||
let size = UTop_private.size
|
||||
|
||||
let key_sequence = UTop_private.key_sequence
|
||||
|
||||
let count = UTop_private.count
|
||||
|
||||
let time = ref 0.
|
||||
|
||||
let () = at_new_command (fun () -> time := Unix.time ())
|
||||
|
||||
let make_variable ?eq x =
|
||||
let signal, set = S.create ?eq x in
|
||||
(signal, (fun () -> S.value signal), set)
|
||||
|
||||
let camlp4, get_camlp4, set_camlp4 = make_variable true
|
||||
let phrase_terminator, get_phrase_terminator, set_phrase_terminator = make_variable ";;"
|
||||
let auto_run_lwt, get_auto_run_lwt, set_auto_run_lwt = make_variable true
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Keywords |
|
||||
|
|
@ -43,33 +72,167 @@ let keywords = ref (List.fold_left (fun set kwd -> String_set.add kwd set) Strin
|
|||
let add_keyword kwd = keywords := String_set.add kwd !keywords
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Hooks |
|
||||
| Error reporting |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let new_command_hooks = Lwt_sequence.create ()
|
||||
let at_new_command f = ignore (Lwt_sequence.add_l f new_command_hooks)
|
||||
let new_prompt_hooks = Lwt_sequence.create ()
|
||||
let at_new_prompt f = ignore (Lwt_sequence.add_l f new_prompt_hooks)
|
||||
let get_message func x =
|
||||
let buffer = Buffer.create 1024 in
|
||||
let pp = Format.formatter_of_buffer buffer in
|
||||
Format.pp_set_margin pp (S.value size).cols;
|
||||
func pp x;
|
||||
Format.pp_print_flush pp ();
|
||||
Buffer.contents buffer
|
||||
|
||||
let get_ocaml_error_message exn =
|
||||
let buffer = Buffer.create 1024 in
|
||||
let pp = Format.formatter_of_buffer buffer in
|
||||
Format.pp_set_margin pp (S.value size).cols;
|
||||
Errors.report_error pp exn;
|
||||
Format.pp_print_flush pp ();
|
||||
let str = Buffer.contents buffer in
|
||||
try
|
||||
Scanf.sscanf
|
||||
str
|
||||
"Characters %d-%d:\n%[\000-\255]"
|
||||
(fun start stop msg -> ((start, stop), msg))
|
||||
with _ ->
|
||||
((0, 0), str)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Prompts |
|
||||
| Parsing |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
type profile = Dark | Light
|
||||
type location = int * int
|
||||
|
||||
let profile, set_profile = S.create Dark
|
||||
type 'a result =
|
||||
| Value of 'a
|
||||
| Error of location list * string
|
||||
|
||||
let smart_accept = ref true
|
||||
exception Need_more
|
||||
|
||||
let size = UTop_private.size
|
||||
#if ocaml_version <= (3, 12, 1)
|
||||
let input_name = ""
|
||||
#else
|
||||
let input_name = "//toplevel//"
|
||||
#endif
|
||||
|
||||
let key_sequence = UTop_private.key_sequence
|
||||
let lexbuf_of_string eof str =
|
||||
let pos = ref 0 in
|
||||
Lexing.from_function
|
||||
(fun buf len ->
|
||||
if !pos = String.length str then begin
|
||||
eof := true;
|
||||
0
|
||||
end else begin
|
||||
let len = min len (String.length str - !pos) in
|
||||
String.blit str !pos buf 0 len;
|
||||
pos := !pos + len;
|
||||
len
|
||||
end)
|
||||
|
||||
let count = UTop_private.count
|
||||
let mkloc loc =
|
||||
(loc.Location.loc_start.Lexing.pos_cnum,
|
||||
loc.Location.loc_end.Lexing.pos_cnum)
|
||||
|
||||
let time = ref 0.
|
||||
let parse_toplevel_phrase_default str eos_is_error =
|
||||
let eof = ref false in
|
||||
let lexbuf = lexbuf_of_string eof str in
|
||||
try
|
||||
(* Try to parse the phrase. *)
|
||||
let phrase = Parse.toplevel_phrase lexbuf in
|
||||
Value phrase
|
||||
with
|
||||
| _ when !eof && not eos_is_error ->
|
||||
(* This is not an error, we just need more input. *)
|
||||
raise Need_more
|
||||
| End_of_file ->
|
||||
(* If the string is empty, do not report an error. *)
|
||||
raise Need_more
|
||||
| Lexer.Error (error, loc) ->
|
||||
Error ([mkloc loc], get_message Lexer.report_error error)
|
||||
| Syntaxerr.Error (Syntaxerr.Unclosed (opening_loc, opening, closing_loc, closing)) ->
|
||||
Error ([mkloc opening_loc; mkloc closing_loc],
|
||||
Printf.sprintf "Syntax error: '%s' expected, the highlighted '%s' might be unmatched" closing opening)
|
||||
| Syntaxerr.Error (Syntaxerr.Applicative_path loc) ->
|
||||
Error ([mkloc loc],
|
||||
"Syntax error: applicative paths of the form F(X).t are not supported when the option -no-app-funct is set.")
|
||||
| Syntaxerr.Error (Syntaxerr.Other loc) ->
|
||||
Error ([mkloc loc],
|
||||
"Syntax error")
|
||||
| Syntaxerr.Escape_error | Parsing.Parse_error ->
|
||||
Error ([mkloc (Location.curr lexbuf)],
|
||||
"Syntax error")
|
||||
| exn ->
|
||||
Error ([], "Unknown parsing error (please report it to the utop project): " ^ Printexc.to_string exn)
|
||||
|
||||
let () = at_new_prompt (fun () -> time := Unix.time ())
|
||||
let parse_toplevel_phrase = ref parse_toplevel_phrase_default
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Safety checking |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let null = Format.make_formatter (fun str ofs len -> ()) ignore
|
||||
|
||||
let rec last head tail =
|
||||
match tail with
|
||||
| [] ->
|
||||
head
|
||||
| head :: tail ->
|
||||
last head tail
|
||||
|
||||
(* Check that the given phrase can be evaluated without typing/compile
|
||||
errors. *)
|
||||
let check_phrase phrase =
|
||||
match phrase with
|
||||
| Parsetree.Ptop_dir _ ->
|
||||
None
|
||||
| Parsetree.Ptop_def [] ->
|
||||
None
|
||||
| Parsetree.Ptop_def (item :: items) ->
|
||||
let loc = {
|
||||
Location.loc_start = item.Parsetree.pstr_loc.Location.loc_start;
|
||||
Location.loc_end = (last item items).Parsetree.pstr_loc.Location.loc_end;
|
||||
Location.loc_ghost = false;
|
||||
} in
|
||||
(* Backup. *)
|
||||
let snap = Btype.snapshot () in
|
||||
let env = !Toploop.toplevel_env in
|
||||
(* Construct "module _(_ : sig end) = struct <items> end" in
|
||||
order to test the typing and compilation of [items] without
|
||||
evaluating them. *)
|
||||
let wrapped_items = {
|
||||
Parsetree.pmod_loc = loc;
|
||||
Parsetree.pmod_desc = Parsetree.Pmod_structure (item :: items);
|
||||
} in
|
||||
let empty_sig = {
|
||||
Parsetree.pmty_loc = loc;
|
||||
Parsetree.pmty_desc = Parsetree.Pmty_signature [];
|
||||
} in
|
||||
let funct = {
|
||||
Parsetree.pmod_loc = loc;
|
||||
Parsetree.pmod_desc = Parsetree.Pmod_functor ("_", empty_sig, wrapped_items);
|
||||
} in
|
||||
let top_def = {
|
||||
Parsetree.pstr_loc = loc;
|
||||
Parsetree.pstr_desc = Parsetree.Pstr_module ("_", funct);
|
||||
} in
|
||||
let check_phrase = Parsetree.Ptop_def [top_def] in
|
||||
try
|
||||
let _ = Toploop.execute_phrase false null check_phrase in
|
||||
(* The phrase is safe. *)
|
||||
Toploop.toplevel_env := env;
|
||||
Btype.backtrack snap;
|
||||
None
|
||||
with exn ->
|
||||
(* The phrase contains errors. *)
|
||||
Toploop.toplevel_env := env;
|
||||
Btype.backtrack snap;
|
||||
let loc, msg = get_ocaml_error_message exn in
|
||||
Some ([loc], msg)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Prompt |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let make_prompt ui profile count size key_sequence (recording, macro_count, macro_counter) =
|
||||
let tm = Unix.localtime !time in
|
||||
|
|
@ -81,9 +244,6 @@ let make_prompt ui profile count size key_sequence (recording, macro_count, macr
|
|||
match ui with
|
||||
| Emacs ->
|
||||
[||]
|
||||
| GTK ->
|
||||
eval [B_fg (color lcyan blue);
|
||||
S (Printf.sprintf "utop[%d]> " count)]
|
||||
| Console ->
|
||||
let bold = profile = Dark in
|
||||
let txta =
|
||||
|
|
@ -130,6 +290,16 @@ let make_prompt ui profile count size key_sequence (recording, macro_count, macr
|
|||
S " }─";
|
||||
]
|
||||
in
|
||||
let second_line =
|
||||
eval [
|
||||
S "\n";
|
||||
B_bold bold;
|
||||
B_fg (rgb 0xe3 0xaa 0x73);
|
||||
S "utop";
|
||||
B_fg (color lgreen green);
|
||||
S " $ ";
|
||||
]
|
||||
in
|
||||
Array.append (
|
||||
if Array.length txta + Array.length txtb > size.cols then
|
||||
Array.sub (Array.append txta txtb) 0 size.cols
|
||||
|
|
@ -141,7 +311,7 @@ let make_prompt ui profile count size key_sequence (recording, macro_count, macr
|
|||
(UChar.of_int 0x2500, { none with foreground = Some (color lcyan blue); bold = Some bold });
|
||||
txtb;
|
||||
]
|
||||
) [|(UChar.of_char '#', { none with foreground = Some (color lgreen green) }); (UChar.of_char ' ', none)|]
|
||||
) second_line
|
||||
|
||||
let prompt = ref (
|
||||
S.l6 make_prompt
|
||||
|
|
@ -156,9 +326,6 @@ let prompt = ref (
|
|||
(Zed_macro.counter LTerm_read_line.macro))
|
||||
)
|
||||
|
||||
let prompt_continue = ref (S.map (fun profile -> [|(UChar.of_char '>', { none with foreground = Some (if profile = Dark then lgreen else green) }); (UChar.of_char ' ', LTerm_style.none)|]) profile)
|
||||
let prompt_comment = ref (S.map (fun profile -> [|(UChar.of_char '*', { none with foreground = Some (if profile = Dark then lgreen else green) }); (UChar.of_char ' ', LTerm_style.none)|]) profile)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Help |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
|
@ -252,14 +419,72 @@ For a complete description of utop, look at the utop(1) manual page."));
|
|||
macro;
|
||||
flush stdout))
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Camlp4 |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let print_error msg =
|
||||
lwt term = Lazy.force LTerm.stdout in
|
||||
lwt () = LTerm.set_style term !UTop_private.error_style in
|
||||
lwt () = Lwt_io.print msg in
|
||||
lwt () = LTerm.set_style term LTerm_style.none in
|
||||
LTerm.flush term
|
||||
|
||||
let handle_findlib_error = function
|
||||
| Failure msg ->
|
||||
Lwt_main.run (print_error msg)
|
||||
| Fl_package_base.No_such_package(pkg, reason) ->
|
||||
Lwt_main.run (print_error (Printf.sprintf "No such package: %s%S\n" pkg (if reason <> "" then " - " ^ reason else "")))
|
||||
| Fl_package_base.Package_loop pkg ->
|
||||
Lwt_main.run (print_error (Printf.sprintf "Package requires itself: %s\n" pkg))
|
||||
| exn ->
|
||||
raise exn
|
||||
|
||||
let () =
|
||||
Hashtbl.add
|
||||
Toploop.directive_table
|
||||
"camlp4o"
|
||||
(Toploop.Directive_none
|
||||
(fun () ->
|
||||
set_phrase_terminator ";;";
|
||||
try
|
||||
Topfind.syntax "camlp4o";
|
||||
Topfind.load_deeply ["utop.camlp4"]
|
||||
with exn ->
|
||||
handle_findlib_error exn));
|
||||
|
||||
Hashtbl.add
|
||||
Toploop.directive_table
|
||||
"camlp4r"
|
||||
(Toploop.Directive_none
|
||||
(fun () ->
|
||||
set_phrase_terminator ";";
|
||||
try
|
||||
Topfind.syntax "camlp4r";
|
||||
Topfind.load_deeply ["utop.camlp4"]
|
||||
with exn ->
|
||||
handle_findlib_error exn))
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Initialization |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let () =
|
||||
(* "utop" is an internal library so it is not passed as "-package"
|
||||
to "ocamlfind ocamlmktop". *)
|
||||
Topfind.don't_load ["utop"];
|
||||
(* Add findlib path so Topfind is available and it won't be
|
||||
initialized twice if the user does [#use "topfind"]. *)
|
||||
Topdirs.dir_directory (Findlib.package_directory "findlib");
|
||||
(* Make UTop accessible. *)
|
||||
Topdirs.dir_directory (Findlib.package_directory "utop")
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Deprecated |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let smart_accept = ref true
|
||||
let new_prompt_hooks = Lwt_sequence.create ()
|
||||
let at_new_prompt f = ignore (Lwt_sequence.add_l f new_prompt_hooks)
|
||||
let prompt_continue = ref (S.const [| |])
|
||||
let prompt_comment = ref (S.const [| |])
|
||||
|
|
@ -0,0 +1,182 @@
|
|||
(*
|
||||
* uTop.mli
|
||||
* --------
|
||||
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
(** UTop configuration. *)
|
||||
|
||||
open React
|
||||
|
||||
val version : string
|
||||
(** Version of utop. *)
|
||||
|
||||
val count : int React.signal
|
||||
(** The number of commands already executed. *)
|
||||
|
||||
val keywords : Set.Make(String).t ref
|
||||
(** The set of OCaml keywords. *)
|
||||
|
||||
val add_keyword : string -> unit
|
||||
(** Add a new OCaml keyword. *)
|
||||
|
||||
type ui = Console | Emacs
|
||||
(** The user interface in use. *)
|
||||
|
||||
val get_ui : unit -> ui
|
||||
(** Returns the user interface in use. *)
|
||||
|
||||
val camlp4 : bool signal
|
||||
(** [true] if the lexer should recognize camlp4 quotations. This
|
||||
variable is automatically set to [true] when you type [#camlp4o]
|
||||
or [#camlp4r]. *)
|
||||
|
||||
val get_camlp4 : unit -> bool
|
||||
(** Returns the current value of {!camlp4}. *)
|
||||
|
||||
val set_camlp4 : bool -> unit
|
||||
(** Modifies {!camlp4}. *)
|
||||
|
||||
val phrase_terminator : string signal
|
||||
(** The phrase terminator. It is ";;" by default and ";" when you
|
||||
use revised syntax. *)
|
||||
|
||||
val get_phrase_terminator : unit -> string
|
||||
(** Returns the value of {!phrase_terminator}. *)
|
||||
|
||||
val set_phrase_terminator : string -> unit
|
||||
(** Modifies {!phrase_terminator}. *)
|
||||
|
||||
val auto_run_lwt : bool signal
|
||||
(** If [true] (the default) toplevel lwt expressions are
|
||||
automatically run with [Lwt_main.run]. i.e. if you type:
|
||||
|
||||
{[
|
||||
Lwt_io.printl "Hello, world"
|
||||
]}
|
||||
|
||||
this will be replaced by:
|
||||
|
||||
{[
|
||||
Lwt_main.run (Lwt_io.printl "Hello, world")
|
||||
]}
|
||||
*)
|
||||
|
||||
val get_auto_run_lwt : unit -> bool
|
||||
(** Returns the value of {!auto_run_lwt}. *)
|
||||
|
||||
val set_auto_run_lwt : bool -> unit
|
||||
(** Modifies {!auto_run_lwt}. *)
|
||||
|
||||
(** {6 Console specific configuration} *)
|
||||
|
||||
type profile = Dark | Light
|
||||
(** Profile for colors. *)
|
||||
|
||||
val profile : profile React.signal
|
||||
(** The color profile. It defaults to {!Dark}. This is used by the
|
||||
default prompt to choose colors. *)
|
||||
|
||||
val set_profile : profile -> unit
|
||||
(** Sets the color profile. *)
|
||||
|
||||
val size : LTerm_geom.size React.signal
|
||||
(** The current size of the terminal. This is used only in the
|
||||
console UI. *)
|
||||
|
||||
val key_sequence : LTerm_key.t list React.signal
|
||||
(** The current key sequence entered by the user. This is used only
|
||||
in the console UI. *)
|
||||
|
||||
val time : float ref
|
||||
(** The time of the beginning of the current command. *)
|
||||
|
||||
val prompt : LTerm_text.t React.signal ref
|
||||
(** The prompt. *)
|
||||
|
||||
(** {6 Hooks} *)
|
||||
|
||||
val new_command_hooks : (unit -> unit) Lwt_sequence.t
|
||||
(** Functions called before each new command. *)
|
||||
|
||||
val at_new_command : (unit -> unit) -> unit
|
||||
(** [at_new_command f] adds [f] to the hooks executed before each
|
||||
new commands. *)
|
||||
|
||||
(** {6 Parsing} *)
|
||||
|
||||
type location = int * int
|
||||
(** Type of a string-location. It is composed of a start and stop
|
||||
offsets (in bytes). *)
|
||||
|
||||
(** Result of a function processing a programx. *)
|
||||
type 'a result =
|
||||
| Value of 'a
|
||||
(** The function succeeded and returned this value. *)
|
||||
| Error of location list * string
|
||||
(** The function failed. Arguments are a list of locations to
|
||||
highlight in the source and an error message. *)
|
||||
|
||||
exception Need_more
|
||||
(** Exception raised by a parser when it need more data. *)
|
||||
|
||||
val parse_toplevel_phrase : (string -> bool -> Parsetree.toplevel_phrase result) ref
|
||||
(** [parse_toplevel_phrase] is the function used to parse a phrase
|
||||
typed in the toplevel.
|
||||
|
||||
Its arguments are:
|
||||
- [input]: the string to parse
|
||||
- [eos_is_error]
|
||||
|
||||
If [eos_is_error] is [true] and the parser reach the end of
|
||||
input, then {!Parse_failure} should be returned.
|
||||
|
||||
If [eos_is_error] is [false] and the parser reach the end of
|
||||
input, the exception {!Need_more} must be thrown.
|
||||
|
||||
Except for {!Need_more}, the function must not raise any
|
||||
exception. *)
|
||||
|
||||
val parse_toplevel_phrase_default : string -> bool -> Parsetree.toplevel_phrase result
|
||||
(** The default parser. It uses the standard ocaml parser. *)
|
||||
|
||||
val input_name : string
|
||||
(** The name you must use in location to let ocaml know that it is
|
||||
from the toplevel. *)
|
||||
|
||||
val lexbuf_of_string : bool ref -> string -> Lexing.lexbuf
|
||||
(** [lexbuf_of_string eof str] is the same as [Lexing.from_string
|
||||
str] except that if the lexer reach the end of [str] then [eof] is
|
||||
set to [true]. *)
|
||||
|
||||
(** {6 Helpers} *)
|
||||
|
||||
val get_message : (Format.formatter -> 'a -> unit) -> 'a -> string
|
||||
(** [get_message printer x] applies [printer] on [x] and
|
||||
returns everything it prints as a string. *)
|
||||
|
||||
val get_ocaml_error_message : exn -> location * string
|
||||
(** [get_ocaml_error_message exn] returns the location and error
|
||||
message for the exception [exn] which must be an exception from
|
||||
the compiler. *)
|
||||
|
||||
val check_phrase : Parsetree.toplevel_phrase -> (location list * string) option
|
||||
(** [check_phrase phrase] checks that [phrase] can be executed
|
||||
without typing or compilation errors. It returns [None] if
|
||||
[phrase] is OK and an error message otherwise.
|
||||
|
||||
If the result is [None] it is guaranteed that
|
||||
[Toploop.execute_phrase] won't raise any exception. *)
|
||||
|
||||
(**/**)
|
||||
|
||||
(* These variables are not used and deprecated: *)
|
||||
|
||||
val prompt_continue : LTerm_text.t React.signal ref
|
||||
val prompt_comment : LTerm_text.t React.signal ref
|
||||
val smart_accept : bool ref
|
||||
val new_prompt_hooks : (unit -> unit) Lwt_sequence.t
|
||||
val at_new_prompt : (unit -> unit) -> unit
|
||||
|
|
@ -344,7 +344,7 @@ let add_fields_of_type decl acc =
|
|||
let add_names_of_type decl acc =
|
||||
match decl.type_kind with
|
||||
| Type_variant constructors ->
|
||||
#if ocaml_version >= (3, 13)
|
||||
#if ocaml_version >= (3, 13, 0)
|
||||
List.fold_left (fun acc (name, _, _) -> add name acc) acc constructors
|
||||
#else
|
||||
List.fold_left (fun acc (name, _) -> add name acc) acc constructors
|
||||
|
|
@ -644,7 +644,7 @@ let rec filter tokens =
|
|||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let complete str =
|
||||
let tokens = UTop_lexer.lex_string str in
|
||||
let tokens = UTop_lexer.lex_string ~camlp4:(UTop.get_camlp4 ()) str in
|
||||
(* Filter blanks and comments. *)
|
||||
let tokens = filter tokens in
|
||||
match tokens with
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
(*
|
||||
* uTop_lexer.mli
|
||||
* --------------
|
||||
* Copyright : (c) 2012, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
val lex_string : ?camlp4 : bool -> string -> (UTop_token.t * int * int * string) list
|
||||
(** [lex_string str] returns all the tokens contained in [str]. It
|
||||
returns a list of [(token, start_index, stop_index,
|
||||
contents)]. Indexes are in unicode characters.
|
||||
|
||||
If [camlp4] is [true] then quotations are parsed. *)
|
||||
|
|
@ -19,13 +19,10 @@ let blank = [' ' '\009' '\012']
|
|||
let lowercase = ['a'-'z' '_']
|
||||
let uppercase = ['A'-'Z']
|
||||
let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
|
||||
let lident = lowercase identchar*
|
||||
let uident = uppercase identchar*
|
||||
let ident = (lowercase|uppercase) identchar*
|
||||
let locname = ident
|
||||
let not_star_symbolchar =
|
||||
['$' '!' '%' '&' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~' '\\']
|
||||
let symbolchar = '*' | not_star_symbolchar
|
||||
let quotchar =
|
||||
['!' '%' '&' '+' '-' '.' '/' ':' '=' '?' '@' '^' '|' '~' '\\' '*']
|
||||
|
||||
let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f']
|
||||
let decimal_literal =
|
||||
['0'-'9'] ['0'-'9' '_']*
|
||||
|
|
@ -42,37 +39,19 @@ let float_literal =
|
|||
('.' ['0'-'9' '_']* )?
|
||||
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
|
||||
|
||||
let safe_delimchars = ['%' '&' '/' '@' '^']
|
||||
let symbolchar =
|
||||
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
|
||||
|
||||
let delimchars = safe_delimchars | ['|' '<' '>' ':' '=' '.']
|
||||
|
||||
let left_delims = ['(' '[' '{']
|
||||
let right_delims = [')' ']' '}']
|
||||
|
||||
let left_delimitor =
|
||||
left_delims delimchars* safe_delimchars (delimchars|left_delims)*
|
||||
| '(' (['|' ':'] delimchars*)?
|
||||
| '[' ['|' ':']?
|
||||
| ['[' '{'] delimchars* '<'
|
||||
| '{' (['|' ':'] delimchars*)?
|
||||
|
||||
let right_delimitor =
|
||||
(delimchars|right_delims)* safe_delimchars (delimchars|right_delims)* right_delims
|
||||
| (delimchars* ['|' ':'])? ')'
|
||||
| ['|' ':']? ']'
|
||||
| '>' delimchars* [']' '}']
|
||||
| (delimchars* ['|' ':'])? '}'
|
||||
|
||||
rule token = parse
|
||||
rule token fallback = parse
|
||||
| ('\n' | blank)+
|
||||
{ Blanks }
|
||||
| "true"
|
||||
{ Constant }
|
||||
| "false"
|
||||
{ Constant }
|
||||
| lowercase identchar*
|
||||
| lident
|
||||
{ Lident }
|
||||
| uppercase identchar*
|
||||
| uident
|
||||
{ Uident }
|
||||
| int_literal "l"
|
||||
{ Constant }
|
||||
|
|
@ -104,24 +83,37 @@ rule token = parse
|
|||
{ Doc (comment 0 lexbuf) }
|
||||
| "(*"
|
||||
{ Comment (comment 0 lexbuf) }
|
||||
| '<' (':' ident)? ('@' locname)? '<'
|
||||
{ Quotation (quotation lexbuf) }
|
||||
| ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::"
|
||||
| ":=" | ":>" | ";" | ";;" | "_"
|
||||
| left_delimitor | right_delimitor )
|
||||
{ Symbol }
|
||||
| ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%' '\\' '$'] symbolchar*
|
||||
| ""
|
||||
{ fallback lexbuf }
|
||||
|
||||
and token_fallback = parse
|
||||
| "(" | ")"
|
||||
| "[" | "]"
|
||||
| "{" | "}"
|
||||
| "`"
|
||||
| "#"
|
||||
| ","
|
||||
| ";" | ";;"
|
||||
| symbolchar+
|
||||
{ Symbol }
|
||||
| uchar
|
||||
{ Error }
|
||||
| eof
|
||||
{ raise End_of_file }
|
||||
|
||||
and token_fallback_camlp4 = parse
|
||||
| '<' (':' ident)? ('@' lident)? '<'
|
||||
{ Quotation (quotation lexbuf) }
|
||||
| ""
|
||||
{ token_fallback lexbuf }
|
||||
|
||||
and comment depth = parse
|
||||
| "(*"
|
||||
{ comment (depth + 1) lexbuf }
|
||||
| "*)"
|
||||
{ if depth > 0 then comment (depth - 1) lexbuf else true }
|
||||
| '"'
|
||||
{ string lexbuf && comment depth lexbuf }
|
||||
| uchar
|
||||
{ comment depth lexbuf }
|
||||
| eof
|
||||
|
|
@ -140,16 +132,27 @@ and string = parse
|
|||
and quotation = parse
|
||||
| ">>"
|
||||
{ true }
|
||||
| '$'
|
||||
{ antiquotation lexbuf }
|
||||
| uchar
|
||||
{ quotation lexbuf }
|
||||
| eof
|
||||
{ false }
|
||||
|
||||
and antiquotation = parse
|
||||
| '$'
|
||||
{ quotation lexbuf }
|
||||
| eof
|
||||
{ false }
|
||||
| ""
|
||||
{ ignore (token token_fallback_camlp4 lexbuf); antiquotation lexbuf }
|
||||
|
||||
{
|
||||
let lex_string str =
|
||||
let lex_string ?(camlp4=false) str =
|
||||
let fallback = if camlp4 then token_fallback_camlp4 else token_fallback in
|
||||
let lexbuf = Lexing.from_string str in
|
||||
let rec loop idx ofs_a =
|
||||
match try Some (token lexbuf) with End_of_file -> None with
|
||||
match try Some (token fallback lexbuf) with End_of_file -> None with
|
||||
| Some token ->
|
||||
let ofs_b = Lexing.lexeme_end lexbuf in
|
||||
let src = String.sub str ofs_a (ofs_b - ofs_a) in
|
||||
|
|
@ -0,0 +1,685 @@
|
|||
(*
|
||||
* uTop_main.ml
|
||||
* ------------
|
||||
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
open CamomileLibraryDyn.Camomile
|
||||
open Lwt
|
||||
open Lwt_react
|
||||
open LTerm_text
|
||||
open LTerm_geom
|
||||
open UTop_token
|
||||
open UTop_styles
|
||||
open UTop_private
|
||||
|
||||
module String_set = Set.Make(String)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| History |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let history = ref []
|
||||
|
||||
let init_history () =
|
||||
let hist_name = Filename.concat LTerm_resources.home ".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 ()
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| offset --> index |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
(* Return the index (in unicode characters) of the character starting
|
||||
a offset (in bytes) [ofs] in [str]. *)
|
||||
let index_of_offset src ofs =
|
||||
let rec aux idx ofs' =
|
||||
if ofs' = ofs then
|
||||
idx
|
||||
else if ofs' > ofs then
|
||||
idx - 1
|
||||
else if ofs' = String.length src then
|
||||
-1
|
||||
else
|
||||
aux (idx + 1) (Zed_utf8.unsafe_next src ofs')
|
||||
in
|
||||
aux 0 0
|
||||
|
||||
let convert_locs str locs = List.map (fun (a, b) -> (index_of_offset str a, index_of_offset str b)) locs
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| The read-line class |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let parse_and_check input eos_is_error =
|
||||
match !UTop.parse_toplevel_phrase input eos_is_error with
|
||||
| UTop.Error (locs, msg) ->
|
||||
UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n")
|
||||
| UTop.Value phrase ->
|
||||
match UTop.check_phrase phrase with
|
||||
| None ->
|
||||
UTop.Value phrase
|
||||
| Some (locs, msg) ->
|
||||
UTop.Error (convert_locs input locs, msg)
|
||||
|
||||
(* Read a phrase. If the result is a value, it is guaranteed to by a
|
||||
valid phrase (i.e. typable and compilable). *)
|
||||
class read_phrase ~term = object(self)
|
||||
inherit [Parsetree.toplevel_phrase UTop.result] LTerm_read_line.engine ~history:!history () as super
|
||||
inherit [Parsetree.toplevel_phrase UTop.result] LTerm_read_line.term term as super_term
|
||||
|
||||
val mutable return_value = None
|
||||
|
||||
method eval =
|
||||
match return_value with
|
||||
| Some x ->
|
||||
x
|
||||
| None ->
|
||||
assert false
|
||||
|
||||
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;
|
||||
(* Try to parse the input. *)
|
||||
let input = Zed_rope.to_string (Zed_edit.text self#edit) in
|
||||
(* Toploop does that: *)
|
||||
Location.reset ();
|
||||
try
|
||||
let result = parse_and_check input false in
|
||||
return_value <- Some result;
|
||||
history := LTerm_read_line.add_entry input !history;
|
||||
return result
|
||||
with UTop.Need_more ->
|
||||
(* Input not finished, continue. *)
|
||||
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 = start to stop - 1 do
|
||||
let ch, style = styled.(i) in
|
||||
styled.(i) <- (ch, LTerm_style.merge token_style style)
|
||||
done
|
||||
in
|
||||
UTop_styles.stylise stylise (UTop_lexer.lex_string ~camlp4:(UTop.get_camlp4 ()) (LTerm_text.to_string styled));
|
||||
|
||||
if not last then
|
||||
(* Parenthesis matching. *)
|
||||
LTerm_text.stylise_parenthesis styled position styles.style_paren
|
||||
else begin
|
||||
match return_value with
|
||||
| Some (UTop.Error (locs, _)) ->
|
||||
(* Highlight error locations. *)
|
||||
List.iter
|
||||
(fun (start, stop) ->
|
||||
for i = start to stop - 1 do
|
||||
let ch, style = styled.(i) in
|
||||
styled.(i) <- (ch, { style with LTerm_style.underline = Some true })
|
||||
done)
|
||||
locs
|
||||
| _ ->
|
||||
()
|
||||
end;
|
||||
|
||||
(styled, position)
|
||||
|
||||
method completion =
|
||||
let pos, words = UTop_complete.complete (Zed_rope.to_string self#input_prev) in
|
||||
self#set_completion pos 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 !UTop.prompt
|
||||
end
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Out phrase printing |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let print_out_phrase term printer pp out_phrase =
|
||||
flush stdout;
|
||||
flush stderr;
|
||||
(match out_phrase with
|
||||
| Outcometree.Ophr_exception _ ->
|
||||
if Printexc.backtrace_status () then begin
|
||||
Printexc.print_backtrace stdout;
|
||||
flush stdout
|
||||
end
|
||||
| _ ->
|
||||
());
|
||||
let buffer = Buffer.create 1024 in
|
||||
let pp = Format.formatter_of_buffer buffer in
|
||||
Format.pp_set_margin pp (LTerm.size term).cols;
|
||||
printer pp out_phrase;
|
||||
Format.pp_print_flush pp ();
|
||||
let string = Buffer.contents buffer in
|
||||
let styled = LTerm_text.of_string string in
|
||||
let stylise start stop token_style =
|
||||
for i = start to stop - 1 do
|
||||
let ch, style = styled.(i) in
|
||||
styled.(i) <- (ch, LTerm_style.merge token_style style)
|
||||
done
|
||||
in
|
||||
UTop_styles.stylise stylise (UTop_lexer.lex_string string);
|
||||
Lwt_main.run (LTerm.fprints term styled)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Lwt_main.run auto-insertion |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let longident_lwt_main_run = Longident.Ldot (Longident.Lident "Lwt_main", "run")
|
||||
|
||||
let is_eval = function
|
||||
| { Parsetree.pstr_desc = Parsetree.Pstr_eval _ } -> true
|
||||
| _ -> false
|
||||
|
||||
let insert_lwt_main_run phrase =
|
||||
match phrase with
|
||||
| Parsetree.Ptop_def pstr ->
|
||||
let env = !Toploop.toplevel_env in
|
||||
let lwt_main_run_is_the_real_one =
|
||||
try
|
||||
match Env.lookup_value longident_lwt_main_run env with
|
||||
| Path.Pdot (Path.Pident id, "run", 0), _ ->
|
||||
Ident.persistent id
|
||||
| _ ->
|
||||
false
|
||||
with Not_found ->
|
||||
false
|
||||
in
|
||||
if lwt_main_run_is_the_real_one && List.exists is_eval pstr then
|
||||
let tstr, _, _ = Typemod.type_structure env pstr Location.none in
|
||||
Parsetree.Ptop_def
|
||||
(List.map2
|
||||
(fun pstr_item tstr_item ->
|
||||
match pstr_item, tstr_item with
|
||||
| { Parsetree.pstr_desc = Parsetree.Pstr_eval e; Parsetree.pstr_loc = loc },
|
||||
Typedtree.Tstr_eval {
|
||||
Typedtree.exp_type = {
|
||||
Types.desc =
|
||||
Types.Tconstr (Path.Pdot (Path.Pident id, "t", -1), _, _)
|
||||
}
|
||||
} ->
|
||||
if Ident.persistent id && Ident.name id = "Lwt" then {
|
||||
Parsetree.pstr_desc =
|
||||
Parsetree.Pstr_eval {
|
||||
Parsetree.pexp_desc =
|
||||
Parsetree.Pexp_apply
|
||||
({ Parsetree.pexp_desc = Parsetree.Pexp_ident longident_lwt_main_run; Parsetree.pexp_loc = loc },
|
||||
[("", e)]);
|
||||
Parsetree.pexp_loc = loc;
|
||||
};
|
||||
Parsetree.pstr_loc = loc;
|
||||
} else
|
||||
pstr_item
|
||||
| _ ->
|
||||
pstr_item)
|
||||
pstr tstr)
|
||||
else
|
||||
phrase
|
||||
| Parsetree.Ptop_dir _ ->
|
||||
phrase
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Main loop |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let rec read_phrase term =
|
||||
try_lwt
|
||||
(new read_phrase ~term)#run
|
||||
with Sys.Break ->
|
||||
lwt () = LTerm.fprintl term "Interrupted." in
|
||||
read_phrase term
|
||||
|
||||
let update_margin pp cols =
|
||||
if Format.pp_get_margin pp () <> cols then
|
||||
Format.pp_set_margin pp cols
|
||||
|
||||
let print_error msg =
|
||||
lwt term = Lazy.force LTerm.stdout in
|
||||
lwt () = LTerm.set_style term styles.style_error in
|
||||
lwt () = Lwt_io.print msg in
|
||||
lwt () = LTerm.set_style term LTerm_style.none in
|
||||
LTerm.flush term
|
||||
|
||||
let rec loop term =
|
||||
(* Reset completion. *)
|
||||
UTop_complete.reset ();
|
||||
|
||||
(* increment the command counter. *)
|
||||
UTop_private.set_count (S.value UTop_private.count + 1);
|
||||
|
||||
(* Call hooks. *)
|
||||
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks;
|
||||
|
||||
(* Read interactively user input. *)
|
||||
let phrase_opt =
|
||||
Lwt_main.run (
|
||||
try_lwt
|
||||
match_lwt read_phrase term with
|
||||
| UTop.Value phrase ->
|
||||
return (Some phrase)
|
||||
| UTop.Error (_, msg) ->
|
||||
lwt () = print_error msg in
|
||||
return None
|
||||
finally
|
||||
LTerm.flush term
|
||||
)
|
||||
in
|
||||
|
||||
match phrase_opt with
|
||||
| Some phrase ->
|
||||
(* Add Lwt_main.run to toplevel evals. *)
|
||||
let phrase = if UTop.get_auto_run_lwt () then insert_lwt_main_run phrase else phrase in
|
||||
(* Set the margin of standard formatters. *)
|
||||
let cols = (LTerm.size term).cols in
|
||||
update_margin Format.std_formatter cols;
|
||||
update_margin Format.err_formatter cols;
|
||||
(* No exception can be raised at this stage. *)
|
||||
ignore (Toploop.execute_phrase true Format.std_formatter phrase);
|
||||
loop term
|
||||
| None ->
|
||||
loop term
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Welcome message |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let welcome term =
|
||||
(* Create a context to render the welcome message. *)
|
||||
let size = LTerm.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 = Printf.sprintf "Welcome to utop version %s (using OCaml version %s)!" UTop.version Sys.ocaml_version 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
|
||||
|
||||
(* Move to after the box. *)
|
||||
lwt () = LTerm.fprint term "\n" in
|
||||
|
||||
LTerm.flush term
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Classic mode |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let read_input_classic 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)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Emacs mode |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
module Emacs(M : sig end) = struct
|
||||
|
||||
(* Copy standard output, which will be used to send commands. *)
|
||||
let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout)
|
||||
|
||||
let split_lines str =
|
||||
let rec aux i j =
|
||||
if j = String.length str then
|
||||
[]
|
||||
else if str.[j] = '\n' then
|
||||
String.sub str i (j - i) :: aux (j + 1) (j + 1)
|
||||
else
|
||||
aux i (j + 1)
|
||||
in
|
||||
aux 0 0
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Sending commands to Emacs |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
(* Mutex used to send commands to Emacs. *)
|
||||
let command_mutex = Mutex.create ()
|
||||
|
||||
let send command argument =
|
||||
Mutex.lock command_mutex;
|
||||
output_string command_oc command;
|
||||
output_char command_oc ':';
|
||||
output_string command_oc argument;
|
||||
output_char command_oc '\n';
|
||||
flush command_oc;
|
||||
Mutex.unlock command_mutex
|
||||
|
||||
(* Keep the [utop-phrase-terminator] variable of the emacs part in sync. *)
|
||||
let () =
|
||||
S.keep (S.map (send "phrase-terminator") UTop.phrase_terminator)
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Standard outputs redirection |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
(* The output of ocaml (stdout and stderr) is redirected so the
|
||||
emacs parts of utop can recognize it. *)
|
||||
|
||||
(* Continuously copy the output of ocaml to Emacs. *)
|
||||
let rec copy_output which ic =
|
||||
let line = input_line ic in
|
||||
send which line;
|
||||
copy_output which ic
|
||||
|
||||
(* Create a thread which redirect the given output: *)
|
||||
let redirect which fd =
|
||||
let fdr, fdw = Unix.pipe () in
|
||||
Unix.dup2 fdw fd;
|
||||
Unix.close fdw;
|
||||
Thread.create (copy_output which) (Unix.in_channel_of_descr fdr)
|
||||
|
||||
(* Redirects stdout and stderr: *)
|
||||
let _ = redirect "stdout" Unix.stdout
|
||||
let _ = redirect "stderr" Unix.stderr
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Loop |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
let read_line () =
|
||||
let behavior = Sys.signal Sys.sigint Sys.Signal_ignore in
|
||||
try
|
||||
let line = Lwt_main.run (Lwt_io.read_line_opt Lwt_io.stdin) in
|
||||
Sys.set_signal Sys.sigint behavior;
|
||||
line
|
||||
with exn ->
|
||||
Sys.set_signal Sys.sigint behavior;
|
||||
raise exn
|
||||
|
||||
let read_command () =
|
||||
match read_line () with
|
||||
| None ->
|
||||
None
|
||||
| Some line ->
|
||||
match try Some (String.index line ':') with Not_found -> None with
|
||||
| None ->
|
||||
send "stderr" "':' missing!";
|
||||
exit 1
|
||||
| Some idx ->
|
||||
Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1)))
|
||||
|
||||
let read_data ?(final_newline = true) () =
|
||||
let buf = Buffer.create 1024 in
|
||||
let rec loop first =
|
||||
match read_command () with
|
||||
| None ->
|
||||
send "stderr" "'end' command missing!";
|
||||
exit 1
|
||||
| Some ("data", data) ->
|
||||
if not first then Buffer.add_char buf '\n';
|
||||
Buffer.add_string buf data;
|
||||
loop false
|
||||
| Some ("end", _) ->
|
||||
if final_newline then Buffer.add_char buf '\n';
|
||||
Buffer.contents buf
|
||||
| Some (command, argument) ->
|
||||
Printf.ksprintf (send "stderr") "'data' or 'end' command expected, got %S!" command;
|
||||
exit 1
|
||||
in
|
||||
loop true
|
||||
|
||||
let process_input eos_is_error =
|
||||
match parse_and_check (read_data ()) eos_is_error with
|
||||
| UTop.Value phrase ->
|
||||
send "accept" "";
|
||||
(* Add Lwt_main.run to toplevel evals. *)
|
||||
let phrase = if UTop.get_auto_run_lwt () then insert_lwt_main_run phrase else phrase in
|
||||
(* No exception can be raised at this stage. *)
|
||||
ignore (Toploop.execute_phrase true Format.std_formatter phrase)
|
||||
| UTop.Error (locs, msg) ->
|
||||
send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs));
|
||||
List.iter (send "stderr") (split_lines msg)
|
||||
|
||||
let rec loop () =
|
||||
(* Reset completion. *)
|
||||
UTop_complete.reset ();
|
||||
|
||||
(* Increment the command counter. *)
|
||||
UTop_private.set_count (S.value UTop_private.count + 1);
|
||||
|
||||
(* Call hooks. *)
|
||||
Lwt_sequence.iter_l (fun f -> f ()) UTop.new_command_hooks;
|
||||
|
||||
(* Tell emacs we are ready. *)
|
||||
send "prompt" "";
|
||||
|
||||
loop_commands ()
|
||||
|
||||
and loop_commands () =
|
||||
match read_command () with
|
||||
| None ->
|
||||
()
|
||||
| Some ("input", "allow-incomplete") ->
|
||||
let continue =
|
||||
try
|
||||
process_input false;
|
||||
false
|
||||
with UTop.Need_more ->
|
||||
send "continue" "";
|
||||
true
|
||||
in
|
||||
if continue then
|
||||
loop_commands ()
|
||||
else
|
||||
loop ()
|
||||
| Some ("input", "") ->
|
||||
process_input true;
|
||||
loop ()
|
||||
| Some ("complete", _) ->
|
||||
let input = read_data ~final_newline:false () in
|
||||
let start, words = UTop_complete.complete input in
|
||||
let words = List.map fst words in
|
||||
let prefix = LTerm_read_line.common_prefix words in
|
||||
let index = String.length input - start in
|
||||
let suffix =
|
||||
if index > 0 && index <= String.length prefix then
|
||||
String.sub prefix index (String.length prefix - index)
|
||||
else
|
||||
""
|
||||
in
|
||||
if suffix = "" then begin
|
||||
send "completion-start" "";
|
||||
List.iter (fun word -> send "completion" word) words;
|
||||
send "completion-stop" "";
|
||||
end else
|
||||
send "completion-word" suffix;
|
||||
loop_commands ()
|
||||
| Some (command, _) ->
|
||||
Printf.ksprintf (send "stderr") "unrecognized command %S!" command;
|
||||
exit 1
|
||||
end
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Entry point |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
let emacs_mode = ref false
|
||||
let preload_objects = ref []
|
||||
|
||||
let prepare () =
|
||||
Toploop.set_paths ();
|
||||
try
|
||||
let res = List.for_all (Topdirs.load_file Format.err_formatter) (List.rev !preload_objects) in
|
||||
!Toploop.toplevel_startup_hook ();
|
||||
res
|
||||
with exn ->
|
||||
try
|
||||
Errors.report_error Format.err_formatter exn;
|
||||
false
|
||||
with exn ->
|
||||
Format.eprintf "Uncaught exception: %s\n" (Printexc.to_string exn);
|
||||
false
|
||||
|
||||
let read_script_from_stdin () =
|
||||
let args = Array.sub Sys.argv !Arg.current (Array.length Sys.argv - !Arg.current) in
|
||||
if prepare () && Toploop.run_script Format.err_formatter "" args then
|
||||
exit 0
|
||||
else
|
||||
exit 2
|
||||
|
||||
let file_argument name =
|
||||
if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma" then
|
||||
preload_objects := name :: !preload_objects
|
||||
else begin
|
||||
let args = Array.sub Sys.argv !Arg.current (Array.length Sys.argv - !Arg.current) in
|
||||
if prepare () && Toploop.run_script Format.err_formatter name args then
|
||||
exit 0
|
||||
else
|
||||
exit 2
|
||||
end
|
||||
|
||||
let print_version () =
|
||||
Printf.printf "The universal toplevel for OCaml, version %s, compiled for OCaml version %s\n" UTop.version Sys.ocaml_version;
|
||||
exit 0
|
||||
|
||||
let print_version_num () =
|
||||
Printf.printf "%s\n" UTop.version
|
||||
|
||||
let args = Arg.align [
|
||||
#if ocaml_version >= (3, 13, 0)
|
||||
"-absname", Arg.Set Location.absname, " Show absolute filenames in error message";
|
||||
#endif
|
||||
"-I", Arg.String (fun dir -> Clflags.include_dirs := Misc.expand_directory Config.standard_library dir :: !Clflags.include_dirs), "<dir> Add <dir> to the list of include directories";
|
||||
"-init", Arg.String (fun s -> Clflags.init_file := Some s), "<file> Load <file> instead of default init file";
|
||||
"-labels", Arg.Clear Clflags.classic, " Use commuting label mode";
|
||||
"-no-app-funct", Arg.Clear Clflags.applicative_functors, " Deactivate applicative functors";
|
||||
"-noassert", Arg.Set Clflags.noassert, " Do not compile assertion checks";
|
||||
"-nolabels", Arg.Set Clflags.classic, " Ignore non-optional labels in types";
|
||||
"-nostdlib", Arg.Set Clflags.no_std_include, " Do not add default directory to the list of include directories";
|
||||
"-principal", Arg.Set Clflags.principal, " Check principality of type inference";
|
||||
"-rectypes", Arg.Set Clflags.recursive_types, " Allow arbitrary recursive types";
|
||||
"-stdin", Arg.Unit read_script_from_stdin, " Read script from standard input";
|
||||
"-strict-sequence", Arg.Set Clflags.strict_sequence, " Left-hand part of a sequence must have type unit";
|
||||
"-unsafe", Arg.Set Clflags.fast, " Do not compile bounds checking on array and string access";
|
||||
"-version", Arg.Unit print_version, " Print version and exit";
|
||||
"-vnum", Arg.Unit print_version_num, " Print version number and exit";
|
||||
"-w", Arg.String (Warnings.parse_options false),
|
||||
Printf.sprintf
|
||||
"<list> Enable or disable warnings according to <list>:\n\
|
||||
\ +<spec> enable warnings in <spec>\n\
|
||||
\ -<spec> disable warnings in <spec>\n\
|
||||
\ @<spec> enable warnings in <spec> and treat them as errors\n\
|
||||
\ <spec> can be:\n\
|
||||
\ <num> a single warning number\n\
|
||||
\ <num1>..<num2> a range of consecutive warning numbers\n\
|
||||
\ <letter> a predefined set\n\
|
||||
\ default setting is %S" Warnings.defaults_w;
|
||||
"-warn-error", Arg.String (Warnings.parse_options true),
|
||||
Printf.sprintf
|
||||
"<list> Enable or disable error status for warnings according to <list>\n\
|
||||
\ See option -w for the syntax of <list>.\n\
|
||||
\ Default setting is %S" Warnings.defaults_warn_error;
|
||||
"-warn-help", Arg.Unit Warnings.help_warnings, " Show description of warning numbers";
|
||||
"-emacs", Arg.Set emacs_mode, " Run in emacs mode";
|
||||
]
|
||||
|
||||
let usage = "Usage: utop <options> <object-files> [script-file [arguments]]\noptions are:"
|
||||
|
||||
let common_init () =
|
||||
(* Initializes toplevel environment. *)
|
||||
Toploop.initialize_toplevel_env ();
|
||||
(* Set the global input name. *)
|
||||
Location.input_name := UTop.input_name;
|
||||
(* Make sure SIGINT is catched while executing OCaml code. *)
|
||||
Sys.catch_break true;
|
||||
(* Load user's .ocamlinit file. *)
|
||||
match !Clflags.init_file with
|
||||
| Some fn ->
|
||||
if Sys.file_exists fn then
|
||||
ignore (Toploop.use_silently Format.err_formatter fn)
|
||||
else
|
||||
Printf.eprintf "Init file not found: \"%s\".\n" fn
|
||||
| None ->
|
||||
if Sys.file_exists ".ocamlinit" then
|
||||
ignore (Toploop.use_silently Format.err_formatter ".ocamlinit")
|
||||
else
|
||||
let fn = Filename.concat LTerm_resources.home ".ocamlinit" in
|
||||
if Sys.file_exists fn then
|
||||
ignore (Toploop.use_silently Format.err_formatter fn)
|
||||
|
||||
let main () =
|
||||
Arg.parse args file_argument usage;
|
||||
if not (prepare ()) then exit 2;
|
||||
if !emacs_mode then begin
|
||||
UTop_private.set_ui UTop_private.Emacs;
|
||||
let module Emacs = Emacs (struct end) in
|
||||
Printf.printf "Welcome to utop version %s (using OCaml version %s)!\n\n%!" UTop.version Sys.ocaml_version;
|
||||
common_init ();
|
||||
Emacs.loop ()
|
||||
end else begin
|
||||
UTop_private.set_ui UTop_private.Console;
|
||||
let term = Lwt_main.run (Lazy.force LTerm.stdout) in
|
||||
if LTerm.incoming_is_a_tty term && LTerm.outgoing_is_a_tty term then begin
|
||||
(* Set the initial size. *)
|
||||
UTop_private.set_size (S.const (LTerm.size term));
|
||||
(* Install our out phrase printer. *)
|
||||
Toploop.print_out_phrase := print_out_phrase term !Toploop.print_out_phrase;
|
||||
(* Load user data. *)
|
||||
Lwt_main.run (join [init_history (); UTop_styles.load (); LTerm_inputrc.load ()]);
|
||||
(* Display a welcome message. *)
|
||||
Lwt_main.run (welcome term);
|
||||
(* Common initialization. *)
|
||||
common_init ();
|
||||
(* Print help message. *)
|
||||
print_string "\nType #utop_help for help about using utop.\n\n";
|
||||
flush stdout;
|
||||
(* Main loop. *)
|
||||
try
|
||||
loop term
|
||||
with LTerm_read_line.Interrupt ->
|
||||
()
|
||||
end else begin
|
||||
(* Use the standard toplevel. Just make sure that Lwt threads can
|
||||
run while reading phrases. *)
|
||||
Toploop.read_interactive_input := read_input_classic;
|
||||
Toploop.loop Format.std_formatter
|
||||
end
|
||||
end;
|
||||
(* Don't let the standard toplevel run... *)
|
||||
exit 0
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
(*
|
||||
* uTop_main.mli
|
||||
* -------------
|
||||
* Copyright : (c) 2012, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
val main : unit -> unit
|
||||
(** Start utop. *)
|
||||
|
|
@ -11,7 +11,7 @@ open Lwt_react
|
|||
|
||||
let size, set_size =
|
||||
let ev, set_size = E.create () in
|
||||
(S.switch (S.const { LTerm_geom.rows = 0; LTerm_geom.cols = 0 }) ev, set_size)
|
||||
(S.switch (S.const { LTerm_geom.rows = 25; LTerm_geom.cols = 80 }) ev, set_size)
|
||||
|
||||
let key_sequence, set_key_sequence =
|
||||
let ev, set_key_sequence = E.create () in
|
||||
|
|
@ -19,8 +19,8 @@ let key_sequence, set_key_sequence =
|
|||
|
||||
let count, set_count = S.create (-1)
|
||||
|
||||
type ui = Console | GTK | Emacs
|
||||
type ui = Console | Emacs
|
||||
|
||||
let ui, set_ui = S.create Console
|
||||
|
||||
let exec_in_gui : ((unit -> unit) -> unit) ref = ref (fun f -> f ())
|
||||
let error_style = ref LTerm_style.none
|
||||
|
|
@ -82,6 +82,7 @@ let load () =
|
|||
| "dark" -> UTop.set_profile UTop.Dark
|
||||
| "" -> ()
|
||||
| str -> raise (LTerm_resources.Error (Printf.sprintf "invalid profile %S" str)));
|
||||
UTop_private.error_style := styles.style_error;
|
||||
return ()
|
||||
with Unix.Unix_error(Unix.ENOENT, _, _) ->
|
||||
return ()
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
(*
|
||||
* uTop_version.ml.ab
|
||||
* ------------------
|
||||
* Copyright : (c) 2012, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
let version = "$(pkg_version)"
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
(*
|
||||
* uTop_start.ml
|
||||
* -------------
|
||||
* Copyright : (c) 2012, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of utop.
|
||||
*)
|
||||
|
||||
let () = UTop_main.main ()
|
||||
|
|
@ -0,0 +1 @@
|
|||
UTop_start
|
||||
|
|
@ -48,7 +48,7 @@ with Emacs to provide an enhanced environment."
|
|||
:version "1.0"
|
||||
:group 'applications)
|
||||
|
||||
(defcustom utop-command "utop-emacs"
|
||||
(defcustom utop-command "utop"
|
||||
"The command to execute for utop."
|
||||
:type 'string
|
||||
:group 'utop)
|
||||
|
|
@ -70,7 +70,8 @@ This hook is only run if exiting actually kills the buffer."
|
|||
:group 'utop)
|
||||
|
||||
(defface utop-prompt
|
||||
'((t (:foreground "Cyan1")))
|
||||
'((((background dark)) (:foreground "Cyan1"))
|
||||
(((background light)) (:foreground "blue")))
|
||||
"The face used to highlight the prompt."
|
||||
:group 'utop)
|
||||
|
||||
|
|
@ -81,13 +82,18 @@ This hook is only run if exiting actually kills the buffer."
|
|||
|
||||
(defface utop-stderr
|
||||
nil
|
||||
"The face used to highlight messages commong from stderr."
|
||||
"The face used to highlight messages comming from stderr."
|
||||
:group 'utop)
|
||||
|
||||
(defface utop-frozen
|
||||
'((t (:bold t)))
|
||||
"The face used to highlight text that has been sent to utop.")
|
||||
|
||||
(defface utop-error
|
||||
'((t (:foreground "#ff4040" :bold t :underline t)))
|
||||
"The face used to highlight errors in phrases."
|
||||
:group 'utop)
|
||||
|
||||
;; +-----------------------------------------------------------------+
|
||||
;; | Constants |
|
||||
;; +-----------------------------------------------------------------+
|
||||
|
|
@ -107,9 +113,9 @@ This hook is only run if exiting actually kills the buffer."
|
|||
|
||||
(defvar utop-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [return] 'utop-send-input)
|
||||
(define-key map [(control ?m)] 'utop-send-input)
|
||||
(define-key map [(control ?j)] 'utop-send-input)
|
||||
(define-key map [return] 'utop-eval-input-or-newline)
|
||||
(define-key map [(control ?m)] 'utop-eval-input-or-newline)
|
||||
(define-key map [(control ?j)] 'utop-eval-input-or-newline)
|
||||
(define-key map [home] 'utop-bol)
|
||||
(define-key map [(control ?a)] 'utop-bol)
|
||||
(define-key map [(meta ?p)] 'utop-history-goto-prev)
|
||||
|
|
@ -127,9 +133,6 @@ This hook is only run if exiting actually kills the buffer."
|
|||
(defvar utop-prompt-max 0
|
||||
"The point at the end of the current prompt.")
|
||||
|
||||
(defvar utop-last-prompt 0
|
||||
"The contents of the last displayed prompt.")
|
||||
|
||||
(defvar utop-output ""
|
||||
"The output of the utop sub-process not yet processed.")
|
||||
|
||||
|
|
@ -145,9 +148,6 @@ This hook is only run if exiting actually kills the buffer."
|
|||
(defvar utop-history-next nil
|
||||
"The history after the cursor.")
|
||||
|
||||
(defvar utop-pending nil
|
||||
"The text not yet added to the history.")
|
||||
|
||||
(defvar utop-completion nil
|
||||
"Current completion.")
|
||||
|
||||
|
|
@ -166,6 +166,16 @@ before the end of prompt.")
|
|||
(defvar utop-initial-command nil
|
||||
"Initial phrase to evaluate.")
|
||||
|
||||
(defvar utop-phrase-terminator ";;"
|
||||
"The OCaml phrase terminator.")
|
||||
|
||||
(defvar utop-pending-input nil
|
||||
"The phrase to add to history if it is accepted by OCaml.")
|
||||
|
||||
(defvar utop-pending-position nil
|
||||
"The position of the cursor in the phrase sent to OCaml (where
|
||||
to add the newline character if it is not accepted).")
|
||||
|
||||
;; +-----------------------------------------------------------------+
|
||||
;; | Utils |
|
||||
;; +-----------------------------------------------------------------+
|
||||
|
|
@ -318,6 +328,16 @@ before the end of prompt.")
|
|||
;; Move the point to the end of buffer in all utop windows
|
||||
(utop-goto-point-max-all-windows))
|
||||
|
||||
(defun utop-insert-phrase-terminator ()
|
||||
"Insert the phrase terminator at the end of buffer."
|
||||
;; Search the longest suffix of the input which is a prefix of the
|
||||
;; phrase terminator
|
||||
(let* ((end (point-max)) (pos (max utop-prompt-max (- end (length utop-phrase-terminator)))))
|
||||
(while (not (string-prefix-p (buffer-substring-no-properties pos end) utop-phrase-terminator))
|
||||
(setq pos (1+ pos)))
|
||||
;; Insert only the missing part
|
||||
(insert (substring utop-phrase-terminator (- end pos)))))
|
||||
|
||||
(defun utop-process-line (line)
|
||||
"Process one line from the utop sub-process."
|
||||
;; Extract the command and its argument
|
||||
|
|
@ -330,20 +350,15 @@ before the end of prompt.")
|
|||
;; Output on stderr
|
||||
((string= command "stderr")
|
||||
(utop-insert-output argument 'utop-stderr))
|
||||
;; Synchronisation of the phrase terminator
|
||||
((string= command "phrase-terminator")
|
||||
(setq utop-phrase-terminator argument))
|
||||
;; A new prompt
|
||||
((string= command "prompt")
|
||||
(let ((prompt (apply utop-prompt ())))
|
||||
;; Push pending input to the history if it is different from
|
||||
;; the top of the history
|
||||
(when (and utop-pending (or (null utop-history) (not (string= utop-pending (car utop-history)))))
|
||||
(push utop-pending utop-history))
|
||||
;; Clear pending input
|
||||
(setq utop-pending nil)
|
||||
;; Reset history
|
||||
(setq utop-history-prev utop-history)
|
||||
(setq utop-history-next nil)
|
||||
;; Save current prompt
|
||||
(setq utop-last-prompt prompt)
|
||||
;; Insert the new prompt
|
||||
(utop-insert-prompt prompt)
|
||||
;; Increment the command number
|
||||
|
|
@ -351,16 +366,42 @@ before the end of prompt.")
|
|||
;; Send the initial command if any
|
||||
(when utop-initial-command
|
||||
(goto-char (point-max))
|
||||
(insert utop-initial-command ";;")
|
||||
(insert utop-initial-command)
|
||||
(utop-insert-phrase-terminator)
|
||||
(setq utop-initial-command nil)
|
||||
(utop-send-input))))
|
||||
;; Continuation of previous input
|
||||
(utop-eval-input))))
|
||||
;; Input has been accepted
|
||||
((string= command "accept")
|
||||
;; Push input to the history if it is different from the top
|
||||
;; of the history
|
||||
(when (or (null utop-history) (not (string= utop-pending-input (car utop-history))))
|
||||
(push utop-pending-input utop-history))
|
||||
;; Add a newline character at the end of the buffer
|
||||
(goto-char (point-max))
|
||||
(insert "\n")
|
||||
;; Make input frozen
|
||||
(add-text-properties utop-prompt-max (point-max) '(face utop-frozen))
|
||||
;; Highlight errors
|
||||
(let ((offsets (split-string argument "," t)))
|
||||
(while offsets
|
||||
(let ((a (string-to-int (car offsets)))
|
||||
(b (string-to-int (car (cdr offsets)))))
|
||||
(add-text-properties (+ utop-prompt-max a) (+ utop-prompt-max b) '(face utop-error))
|
||||
(setq offsets (cdr (cdr offsets))))))
|
||||
;; Make everything read-only
|
||||
(add-text-properties (point-min) (point-max) utop-non-editable-properties)
|
||||
;; Advance the prompt
|
||||
(setq utop-prompt-min (point-max))
|
||||
(setq utop-prompt-max (point-max)))
|
||||
;; Continue editiong
|
||||
((string= command "continue")
|
||||
;; Reset history
|
||||
(setq utop-history-prev utop-history)
|
||||
(setq utop-history-next nil)
|
||||
;; Insert the last prompt
|
||||
(utop-insert-prompt utop-last-prompt))
|
||||
;; Add a newline character at the position where the user
|
||||
;; pressed enter
|
||||
(when utop-pending-position
|
||||
(goto-char (+ utop-prompt-max utop-pending-position))
|
||||
(insert "\n"))
|
||||
;; Reset the state
|
||||
(set-utop-state 'edit))
|
||||
;; Complete with a word
|
||||
((string= command "completion-word")
|
||||
(set-utop-state 'edit)
|
||||
|
|
@ -402,53 +443,57 @@ before the end of prompt.")
|
|||
;; | Sending data to the utop sub-process |
|
||||
;; +-----------------------------------------------------------------+
|
||||
|
||||
(defun utop-send-input ()
|
||||
"Send the text typed at current prompt to the utop
|
||||
sub-process."
|
||||
(defun utop-eval-input (&optional allow-incomplete auto-end)
|
||||
"Send the current input to the utop process and let ocaml
|
||||
evaluate it.
|
||||
|
||||
If ALLOW-INCOMPLETE is non-nil and the phrase is not terminated,
|
||||
then a newline character will be inserted and edition will
|
||||
continue.
|
||||
|
||||
If AUTO-END is non-nill then ALLOW-INCOMPLETE is ignored and a
|
||||
phrase terminator (;; or ; if using revised syntax) will be
|
||||
automatically inserted by utop."
|
||||
(interactive)
|
||||
(with-current-buffer utop-buffer-name
|
||||
(when (eq utop-state 'edit)
|
||||
(utop-perform
|
||||
;; Clear saved pending position
|
||||
(setq utop-pending-position nil)
|
||||
;; Insert the phrase terminator if requested
|
||||
(cond
|
||||
(auto-end
|
||||
(utop-insert-phrase-terminator))
|
||||
(allow-incomplete
|
||||
;; Save cursor position
|
||||
(setq utop-pending-position (- (point) utop-prompt-max))
|
||||
;; If the point is before the prompt, insert the newline
|
||||
;; character at the end
|
||||
(when (< utop-pending-position 0)
|
||||
(setq utop-pending-position (- (point) utop-prompt-max)))))
|
||||
(let* ((input (buffer-substring-no-properties utop-prompt-max (point-max)))
|
||||
(lines (split-string input "\n")))
|
||||
;; Save for history
|
||||
(setq utop-pending-input input)
|
||||
;; We are now waiting for ocaml
|
||||
(set-utop-state 'wait)
|
||||
;; Push input to pending input
|
||||
(let ((input (buffer-substring-no-properties utop-prompt-max (point-max))))
|
||||
(if utop-pending
|
||||
(setq utop-pending (concat utop-pending "\n" input))
|
||||
(setq utop-pending input))
|
||||
;; Goto the end of the buffer
|
||||
(goto-char (point-max))
|
||||
;; Terminate input by a newline
|
||||
(insert "\n")
|
||||
;; Move the point to the end of buffer of all utop windows
|
||||
(utop-goto-point-max-all-windows)
|
||||
;; Make everything read-only
|
||||
(add-text-properties (point-min) (point-max) utop-non-editable-properties)
|
||||
(let ((start utop-prompt-max) (stop (point-max)))
|
||||
;; Set the frozen face for the text we just sent.
|
||||
(add-text-properties start stop '(face utop-frozen))
|
||||
;; Move the prompt to the end of the buffer
|
||||
(setq utop-prompt-min stop)
|
||||
(setq utop-prompt-max stop)
|
||||
;; Send all lines to utop
|
||||
(let ((lines (split-string input "\n")))
|
||||
(process-send-string utop-process "input:\n")
|
||||
(process-send-string utop-process (if (and allow-incomplete (not auto-end)) "input:allow-incomplete\n" "input:\n"))
|
||||
(while lines
|
||||
;; Send the line
|
||||
(process-send-string utop-process (concat "data:" (car lines) "\n"))
|
||||
;; Remove it and continue
|
||||
(setq lines (cdr lines)))
|
||||
(process-send-string utop-process "end:\n"))))))))
|
||||
(process-send-string utop-process "end:\n")))))
|
||||
|
||||
(defun utop-end-phrase-and-send-input ()
|
||||
"End the current phrase and send it to ocaml."
|
||||
(defun utop-eval-input-or-newline ()
|
||||
"Same as (`utop-eval-input' t nil)."
|
||||
(interactive)
|
||||
(with-current-buffer utop-buffer-name
|
||||
(when (eq utop-state 'edit)
|
||||
(goto-char (point-max))
|
||||
(when (= utop-prompt-max (point-max)) (insert "()"))
|
||||
(insert ";;")
|
||||
(utop-send-input))))
|
||||
(utop-eval-input t nil))
|
||||
|
||||
(defun utop-eval-input-auto-end ()
|
||||
"Same as (`utop-eval-input' nil t)."
|
||||
(interactive)
|
||||
(utop-eval-input nil t))
|
||||
|
||||
;; +-----------------------------------------------------------------+
|
||||
;; | Completion |
|
||||
|
|
@ -518,9 +563,10 @@ sub-process."
|
|||
((eq utop-state 'edit)
|
||||
;; Insert it at the end of the utop buffer
|
||||
(goto-char (point-max))
|
||||
(insert text ";;")
|
||||
;; Send input to utop now
|
||||
(utop-send-input))
|
||||
(insert text)
|
||||
;; Send input to utop now, telling it to automatically add the
|
||||
;; phrase terminator
|
||||
(utop-eval-input nil t))
|
||||
((eq utop-state 'wait)
|
||||
;; utop is starting, save the initial command to send
|
||||
(setq utop-initial-command text))))))
|
||||
|
|
@ -624,6 +670,54 @@ To automatically do that just add these lines to your .emacs:
|
|||
;; Make the whole buffer read-only
|
||||
(add-text-properties (point-min) (point-max) utop-non-editable-properties)))))))))
|
||||
|
||||
;; +-----------------------------------------------------------------+
|
||||
;; | ocamlfind package loading |
|
||||
;; +-----------------------------------------------------------------+
|
||||
|
||||
(defun utop-ocamlfind-list-packages ()
|
||||
"Return the list of all findlib packages with their version."
|
||||
(let ((lines (split-string (shell-command-to-string "ocamlfind list") "[ \t]*\r?\n")))
|
||||
(let ((packages))
|
||||
;; Split lines and extract package names and versions
|
||||
(mapc
|
||||
(lambda (line)
|
||||
(when (string-match "\\([^ \t(]*\\)[ \t]*(version:[ \t]*\\([^)]*\\))" line)
|
||||
(push (cons (match-string 1 line) (match-string 2 line)) packages)))
|
||||
lines)
|
||||
(nreverse packages))))
|
||||
|
||||
(defun utop-require ()
|
||||
"Show the list of findlib packages."
|
||||
(interactive)
|
||||
;; Get the list of packages
|
||||
(let ((packages (utop-ocamlfind-list-packages)))
|
||||
(save-excursion
|
||||
(with-output-to-temp-buffer "*Findlib packages*"
|
||||
(set-buffer standard-output)
|
||||
(let ((inhibit-read-only t))
|
||||
(insert "Choose a findlib package to load:\n\n")
|
||||
(let ((max-name-length 0))
|
||||
;; Find the longest package name
|
||||
(mapc
|
||||
(lambda (package)
|
||||
(setq max-name-length (max max-name-length (length (car package)))))
|
||||
packages)
|
||||
(setq max-name-length (1+ (max max-name-length 16)))
|
||||
;; Insert headers
|
||||
(insert "Package name")
|
||||
(insert-char 32 (- max-name-length 12))
|
||||
(insert "Version\n")
|
||||
;; Insert buttons
|
||||
(while packages
|
||||
(let* ((package (car packages))
|
||||
(name (car package))
|
||||
(version (cdr package)))
|
||||
(insert-text-button name 'face nil)
|
||||
(insert-char 32 (- max-name-length (length name)))
|
||||
(insert version "\n"))
|
||||
(setq packages (cdr packages)))
|
||||
(goto-char (point-min))))))))
|
||||
|
||||
;; +-----------------------------------------------------------------+
|
||||
;; | Menu |
|
||||
;; +-----------------------------------------------------------------+
|
||||
|
|
@ -649,7 +743,7 @@ To automatically do that just add these lines to your .emacs:
|
|||
["Start OCaml" utop t]
|
||||
["Interrupt OCaml" utop-interrupt :active (utop-is-running)]
|
||||
["Kill OCaml" utop-kill :active (utop-is-running)]
|
||||
["Evaluate Phrase" utop-end-phrase-and-send-input :active (and (utop-is-running) (eq utop-state 'edit))]
|
||||
["Evaluate Phrase" utop-eval-input-auto-end :active (and (utop-is-running) (eq utop-state 'edit))]
|
||||
"---"
|
||||
["Customize utop" (customize-group 'utop) t]
|
||||
"---"
|
||||
|
|
@ -675,7 +769,7 @@ To automatically do that just add these lines to your .emacs:
|
|||
(setq utop-completion nil)
|
||||
|
||||
;; Create the sub-process
|
||||
(setq utop-process (start-process "utop" (current-buffer) utop-command))
|
||||
(setq utop-process (start-process "utop" (current-buffer) utop-command "-emacs"))
|
||||
|
||||
;; Filter the output of the sub-process with our filter function
|
||||
(set-process-filter utop-process 'utop-process-output)
|
||||
|
|
@ -706,6 +800,9 @@ To automatically do that just add these lines to your .emacs:
|
|||
(make-local-variable 'utop-inhibit-check)
|
||||
(make-local-variable 'utop-state)
|
||||
(make-local-variable 'utop-initial-command)
|
||||
(make-local-variable 'utop-phrase-terminator)
|
||||
(make-local-variable 'utop-pending-input)
|
||||
(make-local-variable 'utop-pending-position)
|
||||
|
||||
;; Set the major mode
|
||||
(setq major-mode 'utop-mode)
|
||||
|
|
@ -70,7 +70,7 @@ let env = ref Env.empty
|
|||
let define id value = env := Env.add id value !env
|
||||
|
||||
let _ =
|
||||
define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> Tuple [Int major; Int minor]))
|
||||
define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel -> Tuple [Int major; Int minor; Int patchlevel]))
|
||||
|
||||
let dirs = ref []
|
||||
let add_include_dir dir = dirs := dir :: !dirs
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ symbol.foreground: x-cyan1
|
|||
string.foreground: x-light-salmon
|
||||
char.foreground: x-light-salmon
|
||||
quotation.foreground: x-purple
|
||||
error.foreground: x-red
|
||||
error.foreground: red
|
||||
directive.foreground: x-lightsteelblue
|
||||
parenthesis.background: blue
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ symbol.foreground: x-purple
|
|||
string.foreground: x-violetred4
|
||||
char.foreground: x-violetred4
|
||||
quotation.foreground: x-purple
|
||||
error.foreground: x-red
|
||||
error.foreground: red
|
||||
directive.foreground: x-mediumorchid4
|
||||
parenthesis.background: light-blue
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue