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