haskal
/
utop
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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 2012-02-11 10:21:07 +01:00
parent 5deae637a0
commit 4a43491f55
32 changed files with 1486 additions and 1285 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
_oasis
View File

@ -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
View File

@ -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
View File

@ -2,3 +2,4 @@
^utop-.*\.tar\.gz$
^setup\.data$
^setup\.log$
^src/lib/uTop_version.ml$

22
myocamlbuild.ml
View File

@ -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
(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;
tag_file
"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/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))]))
| _ ->
())

62
src/camlp4/uTop_camlp4.ml Normal file
View File

@ -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 _ ->
()

99
src/common/uTop.mli
View File

@ -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. *)

276
src/console/uTop_console.ml
View File

@ -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 ();
]

5
src/console/uTop_console_top.mltop
View File

@ -1,5 +0,0 @@
UTop_console
UTop_lexer
UTop_token
UTop_complete
UTop_styles

218
src/emacs/uTop_emacs.ml
View File

@ -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"]

4
src/emacs/uTop_emacs_top.mltop
View File

@ -1,4 +0,0 @@
UTop_emacs
UTop_lexer
UTop_token
UTop_complete

485
src/gtk/uTop_gtk.ml
View File

@ -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

5
src/gtk/uTop_gtk_top.mltop
View File

@ -1,5 +0,0 @@
UTop_gtk
UTop_lexer
UTop_token
UTop_complete
UTop_styles

3
src/lib/errors.mli Normal file
View File

@ -0,0 +1,3 @@
(* Must be the same as driver/errors.mli from ocaml sources. *)
open Format
val report_error : formatter -> exn -> unit

273
src/common/uTop.ml → src/lib/uTop.ml
View File

@ -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 [| |])

182
src/lib/uTop.mli Normal file
View File

@ -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

4
src/common/uTop_complete.ml → src/lib/uTop_complete.ml
View File

@ -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
src/common/uTop_complete.mli → src/lib/uTop_complete.mli
View File

15
src/lib/uTop_lexer.mli Normal file
View File

@ -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. *)

79
src/common/uTop_lexer.mll → src/lib/uTop_lexer.mll
View File

@ -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

685
src/lib/uTop_main.ml Normal file
View File

@ -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

11
src/lib/uTop_main.mli Normal file
View File

@ -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. *)

8
src/common/uTop_private.ml → src/lib/uTop_private.ml
View File

@ -11,16 +11,16 @@ 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
(S.switch (S.const ([] : LTerm_key.t list)) ev, set_key_sequence)
let count, set_count = S.create(-1)
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

1
src/common/uTop_styles.ml → src/lib/uTop_styles.ml
View File

@ -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
src/common/uTop_styles.mli → src/lib/uTop_styles.mli
View File

0
src/common/uTop_token.ml → src/lib/uTop_token.ml
View File

10
src/lib/uTop_version.ml.ab Normal file
View File

@ -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)"

10
src/top/uTop_start.ml Normal file
View File

@ -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 ()

1
src/top/uTop_top.mltop Normal file
View File

@ -0,0 +1 @@
UTop_start

249
src/emacs/utop.el → src/top/utop.el
View File

@ -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."
(interactive)
(with-current-buffer utop-buffer-name
(when (eq utop-state 'edit)
(utop-perform
;; 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")
(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"))))))))
(defun utop-eval-input (&optional allow-incomplete auto-end)
"Send the current input to the utop process and let ocaml
evaluate it.
(defun utop-end-phrase-and-send-input ()
"End the current phrase and send it to ocaml."
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)
(goto-char (point-max))
(when (= utop-prompt-max (point-max)) (insert "()"))
(insert ";;")
(utop-send-input))))
;; 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)
;; Send all lines to utop
(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")))))
(defun utop-eval-input-or-newline ()
"Same as (`utop-eval-input' t nil)."
(interactive)
(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)

2
syntax/pa_optcomp.ml
View File

@ -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

2
utoprc-dark
View File

@ -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

2
utoprc-light
View File

@ -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