2011-07-26 18:43:10 +00:00
|
|
|
(*
|
|
|
|
* uTop.ml
|
|
|
|
* -------
|
|
|
|
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
|
|
|
* Licence : BSD3
|
|
|
|
*
|
|
|
|
* This file is a part of utop.
|
|
|
|
*)
|
|
|
|
|
|
|
|
open CamomileLibraryDyn.Camomile
|
|
|
|
open Lwt_react
|
|
|
|
open LTerm_text
|
|
|
|
open LTerm_geom
|
|
|
|
open LTerm_style
|
|
|
|
|
2014-10-18 16:35:39 +00:00
|
|
|
let (>>=) = Lwt.(>>=)
|
|
|
|
|
2011-07-26 22:11:46 +00:00
|
|
|
module String_set = Set.Make(String)
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
let version = UTop_version.version
|
|
|
|
|
2012-02-12 19:37:12 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| History |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2012-02-12 19:04:32 +00:00
|
|
|
let history = LTerm_history.create []
|
2012-02-12 19:37:12 +00:00
|
|
|
let history_file_name = ref (Some (Filename.concat LTerm_resources.home ".utop-history"))
|
|
|
|
let history_file_max_size = ref None
|
|
|
|
let history_file_max_entries = ref None
|
2012-02-12 19:04:32 +00:00
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Hooks |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
|
|
|
let new_command_hooks = Lwt_sequence.create ()
|
|
|
|
let at_new_command f = ignore (Lwt_sequence.add_l f new_command_hooks)
|
|
|
|
|
2011-09-21 04:26:50 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
2012-02-11 09:21:07 +00:00
|
|
|
| Config |
|
2011-09-21 04:26:50 +00:00
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
type ui = UTop_private.ui = Console | Emacs
|
2011-09-21 04:26:50 +00:00
|
|
|
|
|
|
|
let get_ui () = S.value UTop_private.ui
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
type profile = Dark | Light
|
|
|
|
|
|
|
|
let profile, set_profile = S.create Dark
|
2014-05-02 09:58:05 +00:00
|
|
|
let set_profile p = set_profile p
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
let size = UTop_private.size
|
|
|
|
|
|
|
|
let key_sequence = UTop_private.key_sequence
|
|
|
|
|
|
|
|
let count = UTop_private.count
|
|
|
|
|
2014-07-28 09:18:45 +00:00
|
|
|
let time = ref (Unix.time ())
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
let () = at_new_command (fun () -> time := Unix.time ())
|
|
|
|
|
|
|
|
let make_variable ?eq x =
|
|
|
|
let signal, set = S.create ?eq x in
|
2014-03-27 12:58:45 +00:00
|
|
|
let set v = set v in
|
2012-02-11 09:21:07 +00:00
|
|
|
(signal, (fun () -> S.value signal), set)
|
|
|
|
|
2012-02-22 15:59:31 +00:00
|
|
|
type syntax =
|
|
|
|
| Normal
|
|
|
|
| Camlp4o
|
|
|
|
| Camlp4r
|
|
|
|
|
2013-02-06 22:22:03 +00:00
|
|
|
let hide_reserved, get_hide_reserved, set_hide_reserved = make_variable true
|
2013-04-26 08:53:59 +00:00
|
|
|
let show_box, get_show_box, set_show_box = make_variable true
|
2012-02-22 15:59:31 +00:00
|
|
|
let syntax, get_syntax, set_syntax = make_variable Normal
|
2012-02-11 09:21:07 +00:00
|
|
|
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
|
2012-10-15 06:02:59 +00:00
|
|
|
let auto_run_async, get_auto_run_async, set_auto_run_async = make_variable true
|
2013-08-07 15:57:28 +00:00
|
|
|
let topfind_verbose, get_topfind_verbose, set_topfind_verbose = make_variable false
|
2015-10-29 10:07:28 +00:00
|
|
|
let external_editor, get_external_editor, set_external_editor =
|
|
|
|
make_variable
|
2016-04-08 08:31:37 +00:00
|
|
|
(try
|
|
|
|
Sys.getenv "EDITOR"
|
|
|
|
with Not_found ->
|
|
|
|
"vi")
|
2011-09-21 13:09:11 +00:00
|
|
|
|
2015-05-12 15:46:24 +00:00
|
|
|
(* Ugly hack until the action system of lambda-term is improved *)
|
|
|
|
let end_and_accept_current_phrase : LTerm_read_line.action =
|
|
|
|
Edit (Custom (fun () -> assert false))
|
|
|
|
|
2015-08-04 10:44:36 +00:00
|
|
|
let set_margin_function f = UTop_private.set_margin_function f
|
|
|
|
|
2011-08-01 15:42:13 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Keywords |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2011-07-26 22:11:46 +00:00
|
|
|
let default_keywords = [
|
|
|
|
"and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
|
|
|
|
"done"; "downto"; "else"; "end"; "exception"; "external";
|
|
|
|
"for"; "fun"; "function"; "functor"; "if"; "in"; "include";
|
|
|
|
"inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module";
|
|
|
|
"mutable"; "new"; "object"; "of"; "open"; "private"; "rec"; "sig";
|
|
|
|
"struct"; "then"; "to"; "try"; "type"; "val"; "virtual";
|
|
|
|
"when"; "while"; "with"; "try_lwt"; "finally"; "for_lwt"; "lwt";
|
|
|
|
]
|
|
|
|
|
2012-03-15 03:20:47 +00:00
|
|
|
let keywords = ref (List.fold_right String_set.add default_keywords String_set.empty)
|
2011-07-26 22:11:46 +00:00
|
|
|
let add_keyword kwd = keywords := String_set.add kwd !keywords
|
|
|
|
|
2011-08-04 09:43:20 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
2012-02-11 09:21:07 +00:00
|
|
|
| Error reporting |
|
2011-08-04 09:43:20 +00:00
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
let get_message func x =
|
|
|
|
let buffer = Buffer.create 1024 in
|
|
|
|
let pp = Format.formatter_of_buffer buffer in
|
2015-08-04 10:44:36 +00:00
|
|
|
UTop_private.set_margin pp;
|
2012-02-11 09:21:07 +00:00
|
|
|
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
|
2015-08-04 10:44:36 +00:00
|
|
|
UTop_private.set_margin pp;
|
2012-02-11 09:21:07 +00:00
|
|
|
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)
|
2011-08-04 09:43:20 +00:00
|
|
|
|
2012-02-23 14:07:00 +00:00
|
|
|
let collect_formatters buf pps f =
|
|
|
|
(* First flush all formatters. *)
|
|
|
|
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
|
|
|
|
(* Save all formatter functions. *)
|
2014-10-20 12:51:50 +00:00
|
|
|
let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in
|
2012-02-23 14:07:00 +00:00
|
|
|
let restore () =
|
|
|
|
List.iter2
|
2014-10-20 12:51:50 +00:00
|
|
|
(fun pp out_functions ->
|
2012-02-23 14:07:00 +00:00
|
|
|
Format.pp_print_flush pp ();
|
2014-10-20 12:51:50 +00:00
|
|
|
Format.pp_set_formatter_out_functions pp out_functions)
|
2012-02-23 14:07:00 +00:00
|
|
|
pps save
|
|
|
|
in
|
|
|
|
(* Output functions. *)
|
2017-04-05 08:37:54 +00:00
|
|
|
let out_functions =
|
|
|
|
let ppb = Format.formatter_of_buffer buf in
|
|
|
|
Format.pp_get_formatter_out_functions ppb ()
|
|
|
|
in
|
2012-02-23 14:07:00 +00:00
|
|
|
(* Replace formatter functions. *)
|
|
|
|
List.iter
|
|
|
|
(fun pp ->
|
2015-08-04 10:44:36 +00:00
|
|
|
UTop_private.set_margin pp;
|
2014-10-20 12:51:50 +00:00
|
|
|
Format.pp_set_formatter_out_functions pp out_functions)
|
2012-02-23 14:07:00 +00:00
|
|
|
pps;
|
|
|
|
try
|
|
|
|
let x = f () in
|
|
|
|
restore ();
|
|
|
|
x
|
|
|
|
with exn ->
|
|
|
|
restore ();
|
|
|
|
raise exn
|
|
|
|
|
|
|
|
let discard_formatters pps f =
|
|
|
|
(* First flush all formatters. *)
|
|
|
|
List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
|
|
|
|
(* Save all formatter functions. *)
|
2014-10-20 12:51:50 +00:00
|
|
|
let save = List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in
|
2012-02-23 14:07:00 +00:00
|
|
|
let restore () =
|
|
|
|
List.iter2
|
2014-10-20 12:51:50 +00:00
|
|
|
(fun pp out_functions ->
|
2012-02-23 14:07:00 +00:00
|
|
|
Format.pp_print_flush pp ();
|
2014-10-20 12:51:50 +00:00
|
|
|
Format.pp_set_formatter_out_functions pp out_functions)
|
2012-02-23 14:07:00 +00:00
|
|
|
pps save
|
|
|
|
in
|
|
|
|
(* Output functions. *)
|
2014-10-20 12:51:50 +00:00
|
|
|
let out_functions = {
|
|
|
|
Format.out_string = (fun _ _ _ -> ()); out_flush = ignore;
|
|
|
|
out_newline = ignore; out_spaces = ignore;
|
|
|
|
} in
|
2012-02-23 14:07:00 +00:00
|
|
|
(* Replace formatter functions. *)
|
2014-10-20 12:51:50 +00:00
|
|
|
List.iter (fun pp -> Format.pp_set_formatter_out_functions pp out_functions) pps;
|
2012-02-23 14:07:00 +00:00
|
|
|
try
|
|
|
|
let x = f () in
|
|
|
|
restore ();
|
|
|
|
x
|
|
|
|
with exn ->
|
|
|
|
restore ();
|
|
|
|
raise exn
|
|
|
|
|
2011-08-01 15:42:13 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
2012-02-11 09:21:07 +00:00
|
|
|
| Parsing |
|
2011-08-01 15:42:13 +00:00
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
type location = int * int
|
|
|
|
|
|
|
|
type 'a result =
|
|
|
|
| Value of 'a
|
|
|
|
| Error of location list * string
|
|
|
|
|
|
|
|
exception Need_more
|
|
|
|
|
|
|
|
let input_name = "//toplevel//"
|
|
|
|
|
|
|
|
let lexbuf_of_string eof str =
|
|
|
|
let pos = ref 0 in
|
2013-07-12 11:02:18 +00:00
|
|
|
let lexbuf =
|
|
|
|
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)
|
|
|
|
in
|
|
|
|
Location.init lexbuf input_name;
|
|
|
|
lexbuf
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
let mkloc loc =
|
|
|
|
(loc.Location.loc_start.Lexing.pos_cnum,
|
|
|
|
loc.Location.loc_end.Lexing.pos_cnum)
|
|
|
|
|
2013-04-03 15:53:02 +00:00
|
|
|
let parse_default parse str eos_is_error =
|
2012-02-11 09:21:07 +00:00
|
|
|
let eof = ref false in
|
|
|
|
let lexbuf = lexbuf_of_string eof str in
|
|
|
|
try
|
|
|
|
(* Try to parse the phrase. *)
|
2013-04-03 15:53:02 +00:00
|
|
|
let phrase = parse lexbuf in
|
2012-02-11 09:21:07 +00:00
|
|
|
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)
|
2013-10-25 09:52:05 +00:00
|
|
|
| Syntaxerr.Error error -> begin
|
|
|
|
match error with
|
|
|
|
| Syntaxerr.Unclosed (opening_loc, opening, closing_loc, closing) ->
|
2012-02-11 09:21:07 +00:00
|
|
|
Error ([mkloc opening_loc; mkloc closing_loc],
|
|
|
|
Printf.sprintf "Syntax error: '%s' expected, the highlighted '%s' might be unmatched" closing opening)
|
2013-10-25 09:52:05 +00:00
|
|
|
| Syntaxerr.Applicative_path loc ->
|
2012-02-11 09:21:07 +00:00
|
|
|
Error ([mkloc loc],
|
|
|
|
"Syntax error: applicative paths of the form F(X).t are not supported when the option -no-app-funct is set.")
|
2013-10-25 09:52:05 +00:00
|
|
|
| Syntaxerr.Other loc ->
|
2012-02-11 09:21:07 +00:00
|
|
|
Error ([mkloc loc],
|
|
|
|
"Syntax error")
|
2013-10-25 09:52:05 +00:00
|
|
|
| Syntaxerr.Expecting (loc, nonterm) ->
|
|
|
|
Error ([mkloc loc],
|
|
|
|
Printf.sprintf "Syntax error: %s expected." nonterm)
|
|
|
|
| Syntaxerr.Variable_in_scope (loc, var) ->
|
|
|
|
Error ([mkloc loc],
|
|
|
|
Printf.sprintf "In this scoped type, variable '%s is reserved for the local type %s." var var)
|
2014-11-17 14:58:12 +00:00
|
|
|
#if OCAML_VERSION >= (4, 02, 0)
|
2014-02-14 09:49:00 +00:00
|
|
|
| Syntaxerr.Not_expecting (loc, nonterm) ->
|
|
|
|
Error ([mkloc loc],
|
|
|
|
Printf.sprintf "Syntax error: %s not expected" nonterm)
|
2014-08-18 10:29:34 +00:00
|
|
|
| Syntaxerr.Ill_formed_ast (loc, s) ->
|
|
|
|
Error ([mkloc loc],
|
|
|
|
Printf.sprintf "Error: broken invariant in parsetree: %s" s)
|
2016-08-15 08:32:20 +00:00
|
|
|
#endif
|
2016-08-15 09:06:33 +00:00
|
|
|
#if OCAML_VERSION >= (4, 03, 0)
|
2016-08-15 08:32:20 +00:00
|
|
|
| Syntaxerr.Invalid_package_type (loc, s) ->
|
|
|
|
Error ([mkloc loc],
|
|
|
|
Printf.sprintf "Invalid package type: %s" s)
|
2013-10-25 09:52:05 +00:00
|
|
|
#endif
|
|
|
|
end
|
2012-02-11 09:21:07 +00:00
|
|
|
| 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)
|
|
|
|
|
2013-04-14 11:32:04 +00:00
|
|
|
let parse_toplevel_phrase_default = parse_default Parse.toplevel_phrase
|
2012-02-11 09:21:07 +00:00
|
|
|
let parse_toplevel_phrase = ref parse_toplevel_phrase_default
|
2011-08-04 07:35:22 +00:00
|
|
|
|
2013-04-14 11:32:04 +00:00
|
|
|
let parse_use_file_default = parse_default Parse.use_file
|
|
|
|
let parse_use_file = ref parse_use_file_default
|
2011-08-04 07:35:22 +00:00
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Safety checking |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
2011-07-26 18:43:10 +00:00
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
let null = Format.make_formatter (fun str ofs len -> ()) ignore
|
|
|
|
|
|
|
|
let rec last head tail =
|
|
|
|
match tail with
|
|
|
|
| [] ->
|
|
|
|
head
|
|
|
|
| head :: tail ->
|
|
|
|
last head tail
|
|
|
|
|
2012-06-15 14:23:21 +00:00
|
|
|
let with_loc loc str = {
|
|
|
|
Location.txt = str;
|
|
|
|
Location.loc = loc;
|
|
|
|
}
|
|
|
|
|
2015-03-18 16:47:29 +00:00
|
|
|
#if OCAML_VERSION >= (4, 03, 0)
|
|
|
|
let nolabel = Asttypes.Nolabel
|
|
|
|
#else
|
|
|
|
let nolabel = ""
|
|
|
|
#endif
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
(* Check that the given phrase can be evaluated without typing/compile
|
|
|
|
errors. *)
|
|
|
|
let check_phrase phrase =
|
2013-07-15 08:24:18 +00:00
|
|
|
let open Parsetree in
|
2012-02-11 09:21:07 +00:00
|
|
|
match phrase with
|
2013-07-15 08:24:18 +00:00
|
|
|
| Ptop_dir _ ->
|
2012-02-11 09:21:07 +00:00
|
|
|
None
|
2013-07-15 08:24:18 +00:00
|
|
|
| Ptop_def [] ->
|
2012-02-11 09:21:07 +00:00
|
|
|
None
|
2013-07-15 08:24:18 +00:00
|
|
|
| Ptop_def (item :: items) ->
|
2012-02-11 09:21:07 +00:00
|
|
|
let loc = {
|
2013-07-15 08:24:18 +00:00
|
|
|
Location.loc_start = item.pstr_loc.Location.loc_start;
|
|
|
|
Location.loc_end = (last item items).pstr_loc.Location.loc_end;
|
2012-02-11 09:21:07 +00:00
|
|
|
Location.loc_ghost = false;
|
|
|
|
} in
|
|
|
|
(* Backup. *)
|
|
|
|
let snap = Btype.snapshot () in
|
|
|
|
let env = !Toploop.toplevel_env in
|
2013-07-15 08:24:18 +00:00
|
|
|
(* Construct "let _ () = let module _ = struct <items> end in ()" in order to test
|
|
|
|
the typing and compilation of [items] without evaluating them. *)
|
2014-05-02 09:58:05 +00:00
|
|
|
let unit = with_loc loc (Longident.Lident "()") in
|
2014-11-17 14:58:12 +00:00
|
|
|
#if OCAML_VERSION < (4, 02, 0)
|
2013-07-15 08:24:18 +00:00
|
|
|
let structure = {
|
|
|
|
pmod_loc = loc;
|
|
|
|
pmod_desc = Pmod_structure (item :: items);
|
2012-02-11 09:21:07 +00:00
|
|
|
} in
|
2013-07-15 08:24:18 +00:00
|
|
|
let unit_expr = {
|
|
|
|
pexp_desc = Pexp_construct (unit, None, false);
|
|
|
|
pexp_loc = loc;
|
2012-02-11 09:21:07 +00:00
|
|
|
} in
|
2013-07-15 08:24:18 +00:00
|
|
|
let unit_patt = {
|
|
|
|
ppat_desc = Ppat_construct (unit, None, false);
|
|
|
|
ppat_loc = loc;
|
|
|
|
} in
|
|
|
|
let letmodule = {
|
|
|
|
pexp_desc = Pexp_letmodule (with_loc loc "_", structure, unit_expr);
|
|
|
|
pexp_loc = loc;
|
|
|
|
} in
|
|
|
|
let func = {
|
|
|
|
pexp_desc = Pexp_function ("", None, [(unit_patt, letmodule)]);
|
|
|
|
pexp_loc = loc;
|
2012-02-11 09:21:07 +00:00
|
|
|
} in
|
|
|
|
let top_def = {
|
2013-07-15 08:24:18 +00:00
|
|
|
pstr_desc = Pstr_value (Asttypes.Nonrecursive,
|
|
|
|
[({ ppat_desc = Ppat_var (with_loc loc "_");
|
|
|
|
ppat_loc = loc }, func)]);
|
|
|
|
pstr_loc = loc;
|
2012-02-11 09:21:07 +00:00
|
|
|
} in
|
2014-02-14 09:49:00 +00:00
|
|
|
#else
|
|
|
|
let top_def =
|
|
|
|
let open Ast_helper in
|
|
|
|
with_default_loc loc
|
|
|
|
(fun () ->
|
|
|
|
Str.eval
|
2015-03-18 16:47:29 +00:00
|
|
|
(Exp.fun_ nolabel None (Pat.construct unit None)
|
2014-05-12 10:25:41 +00:00
|
|
|
(Exp.letmodule (with_loc loc "_")
|
|
|
|
(Mod.structure (item :: items))
|
|
|
|
(Exp.construct unit None))))
|
2014-02-14 09:49:00 +00:00
|
|
|
in
|
|
|
|
#endif
|
2013-07-15 08:24:18 +00:00
|
|
|
let check_phrase = Ptop_def [top_def] in
|
2012-02-11 09:21:07 +00:00
|
|
|
try
|
2013-05-21 09:26:59 +00:00
|
|
|
let _ =
|
|
|
|
discard_formatters [Format.err_formatter] (fun () ->
|
|
|
|
Env.reset_cache_toplevel ();
|
|
|
|
Toploop.execute_phrase false null check_phrase)
|
|
|
|
in
|
2012-02-11 09:21:07 +00:00
|
|
|
(* The phrase is safe. *)
|
|
|
|
Toploop.toplevel_env := env;
|
|
|
|
Btype.backtrack snap;
|
|
|
|
None
|
|
|
|
with exn ->
|
|
|
|
(* The phrase contains errors. *)
|
2013-05-21 09:26:59 +00:00
|
|
|
let loc, msg = get_ocaml_error_message exn in
|
2012-02-11 09:21:07 +00:00
|
|
|
Toploop.toplevel_env := env;
|
|
|
|
Btype.backtrack snap;
|
|
|
|
Some ([loc], msg)
|
2011-08-04 09:43:20 +00:00
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Prompt |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
2011-08-04 09:43:20 +00:00
|
|
|
|
2011-09-21 04:26:50 +00:00
|
|
|
let make_prompt ui profile count size key_sequence (recording, macro_count, macro_counter) =
|
2011-08-04 09:43:20 +00:00
|
|
|
let tm = Unix.localtime !time in
|
2011-08-01 22:18:35 +00:00
|
|
|
let color dark light =
|
|
|
|
match profile with
|
|
|
|
| Dark -> dark
|
|
|
|
| Light -> light
|
|
|
|
in
|
2011-09-21 04:26:50 +00:00
|
|
|
match ui with
|
|
|
|
| Emacs ->
|
|
|
|
[||]
|
|
|
|
| Console ->
|
|
|
|
let bold = profile = Dark in
|
|
|
|
let txta =
|
|
|
|
if key_sequence = [] then
|
|
|
|
eval [
|
|
|
|
B_bold bold;
|
|
|
|
B_fg (color lcyan blue);
|
|
|
|
S "─( ";
|
|
|
|
B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg;
|
|
|
|
S " )─< ";
|
|
|
|
B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg;
|
|
|
|
S " >─";
|
|
|
|
]
|
|
|
|
else
|
|
|
|
eval [
|
|
|
|
B_bold bold;
|
|
|
|
B_fg (color lcyan blue);
|
|
|
|
S "─( ";
|
|
|
|
B_fg (color lmagenta magenta); S (Printf.sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec); E_fg;
|
|
|
|
S " )─< ";
|
|
|
|
B_fg (color lyellow yellow); S (Printf.sprintf "command %d" count); E_fg;
|
|
|
|
S " >─[ ";
|
|
|
|
B_fg (color lgreen green); S (String.concat " " (List.map LTerm_key.to_string_compact key_sequence)); E_fg;
|
|
|
|
S " ]─";
|
|
|
|
]
|
|
|
|
in
|
|
|
|
let txtb =
|
|
|
|
if recording then
|
|
|
|
eval [
|
|
|
|
B_bold bold;
|
|
|
|
B_fg (color lcyan blue);
|
|
|
|
S "{ ";
|
|
|
|
B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg;
|
|
|
|
S " }─[ ";
|
|
|
|
B_fg (color lwhite black); S (Printf.sprintf "macro: %d" macro_count); E_fg;
|
|
|
|
S " ]─";
|
|
|
|
]
|
|
|
|
else
|
|
|
|
eval [
|
|
|
|
B_bold bold;
|
|
|
|
B_fg (color lcyan blue);
|
|
|
|
S "{ ";
|
|
|
|
B_fg (color lwhite black); S (Printf.sprintf "counter: %d" macro_counter); E_fg;
|
|
|
|
S " }─";
|
|
|
|
]
|
|
|
|
in
|
2012-02-11 09:21:07 +00:00
|
|
|
let second_line =
|
|
|
|
eval [
|
|
|
|
S "\n";
|
|
|
|
B_bold bold;
|
|
|
|
B_fg (rgb 0xe3 0xaa 0x73);
|
|
|
|
S "utop";
|
|
|
|
B_fg (color lgreen green);
|
2013-04-05 16:21:50 +00:00
|
|
|
S " # ";
|
2012-02-11 09:21:07 +00:00
|
|
|
]
|
|
|
|
in
|
2011-09-21 04:26:50 +00:00
|
|
|
Array.append (
|
|
|
|
if Array.length txta + Array.length txtb > size.cols then
|
|
|
|
Array.sub (Array.append txta txtb) 0 size.cols
|
|
|
|
else
|
|
|
|
Array.concat [
|
|
|
|
txta;
|
|
|
|
Array.make
|
|
|
|
(size.cols - Array.length txta - Array.length txtb)
|
|
|
|
(UChar.of_int 0x2500, { none with foreground = Some (color lcyan blue); bold = Some bold });
|
|
|
|
txtb;
|
|
|
|
]
|
2012-02-11 09:21:07 +00:00
|
|
|
) second_line
|
2011-07-26 18:43:10 +00:00
|
|
|
|
2013-08-07 16:35:02 +00:00
|
|
|
let default_prompt =
|
2011-09-21 04:26:50 +00:00
|
|
|
S.l6 make_prompt
|
|
|
|
UTop_private.ui
|
2011-08-02 08:13:49 +00:00
|
|
|
profile
|
|
|
|
count
|
|
|
|
size
|
2011-08-04 07:35:22 +00:00
|
|
|
key_sequence
|
|
|
|
(S.l3 (fun x y z -> (x, y, z))
|
|
|
|
(Zed_macro.recording LTerm_read_line.macro)
|
|
|
|
(Zed_macro.count LTerm_read_line.macro)
|
|
|
|
(Zed_macro.counter LTerm_read_line.macro))
|
2013-08-07 16:35:02 +00:00
|
|
|
|
|
|
|
let prompt = ref default_prompt
|
|
|
|
|
|
|
|
let () =
|
|
|
|
Hashtbl.add Toploop.directive_table "utop_prompt_simple"
|
|
|
|
(Toploop.Directive_none
|
|
|
|
(fun () ->
|
|
|
|
prompt := S.map (Printf.ksprintf LTerm_text.of_string "utop [%d]: ") count));
|
|
|
|
|
|
|
|
Hashtbl.add Toploop.directive_table "utop_prompt_dummy"
|
|
|
|
(Toploop.Directive_none
|
|
|
|
(fun () ->
|
|
|
|
prompt := S.const (LTerm_text.of_string "# ")));
|
|
|
|
|
|
|
|
Hashtbl.add Toploop.directive_table "utop_prompt_fancy_light"
|
|
|
|
(Toploop.Directive_none
|
|
|
|
(fun () ->
|
|
|
|
set_profile Light;
|
|
|
|
prompt := default_prompt));
|
|
|
|
|
|
|
|
Hashtbl.add Toploop.directive_table "utop_prompt_fancy_dark"
|
|
|
|
(Toploop.Directive_none
|
|
|
|
(fun () ->
|
|
|
|
set_profile Dark;
|
|
|
|
prompt := default_prompt))
|
2011-07-26 18:43:10 +00:00
|
|
|
|
2011-08-01 15:42:13 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Help |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2011-08-01 20:44:29 +00:00
|
|
|
module Bindings = Zed_input.Make (LTerm_key)
|
|
|
|
module Keys_map = Map.Make (struct type t = LTerm_key.t list let compare = compare end)
|
2011-08-01 15:42:13 +00:00
|
|
|
|
2015-05-12 15:46:24 +00:00
|
|
|
let name_of_action action =
|
|
|
|
if action == end_and_accept_current_phrase then
|
|
|
|
"end-and-accept-current-phrase"
|
|
|
|
else
|
|
|
|
LTerm_read_line.name_of_action action
|
|
|
|
|
|
|
|
let doc_of_action action =
|
|
|
|
if action == end_and_accept_current_phrase then
|
|
|
|
"end the current phrase with the phrase terminator (;;) and evaluate it"
|
|
|
|
else
|
|
|
|
LTerm_read_line.doc_of_action action
|
|
|
|
|
2011-08-01 15:42:13 +00:00
|
|
|
let () =
|
|
|
|
Hashtbl.add Toploop.directive_table "utop_help"
|
|
|
|
(Toploop.Directive_none
|
|
|
|
(fun () ->
|
2013-08-07 16:35:02 +00:00
|
|
|
print_endline "If you can't see the prompt properly try: #utop_prompt_simple
|
2011-08-01 22:18:35 +00:00
|
|
|
|
2013-08-07 15:57:28 +00:00
|
|
|
utop defines the following directives:
|
2011-08-01 15:42:13 +00:00
|
|
|
|
2016-11-16 07:47:24 +00:00
|
|
|
#help : list all directives
|
2013-08-07 15:57:28 +00:00
|
|
|
#utop_bindings : list all the current key bindings
|
|
|
|
#utop_macro : display the currently recorded macro
|
|
|
|
#topfind_log : display messages recorded from findlib since the beginning of the session
|
|
|
|
#topfind_verbose : enable/disable topfind verbosity
|
2011-08-02 17:34:27 +00:00
|
|
|
|
|
|
|
For a complete description of utop, look at the utop(1) manual page."));
|
2011-08-01 15:42:13 +00:00
|
|
|
|
|
|
|
Hashtbl.add Toploop.directive_table "utop_bindings"
|
|
|
|
(Toploop.Directive_none
|
|
|
|
(fun () ->
|
2011-08-01 20:44:29 +00:00
|
|
|
let make_lines keys actions acc =
|
|
|
|
match actions with
|
|
|
|
| [] ->
|
|
|
|
(String.concat " " (List.map LTerm_key.to_string_compact keys),
|
|
|
|
"",
|
|
|
|
"does nothing")
|
|
|
|
:: acc
|
|
|
|
| action :: actions ->
|
|
|
|
let rec loop actions acc =
|
|
|
|
match actions with
|
|
|
|
| [] ->
|
|
|
|
acc
|
|
|
|
| action :: actions ->
|
|
|
|
loop
|
|
|
|
actions
|
|
|
|
(("",
|
2015-05-12 15:46:24 +00:00
|
|
|
name_of_action action,
|
|
|
|
doc_of_action action)
|
2011-08-01 20:44:29 +00:00
|
|
|
:: acc)
|
|
|
|
in
|
|
|
|
loop
|
|
|
|
actions
|
|
|
|
((String.concat " " (List.map LTerm_key.to_string_compact keys),
|
2015-05-12 15:46:24 +00:00
|
|
|
name_of_action action,
|
|
|
|
doc_of_action action)
|
2011-08-01 20:44:29 +00:00
|
|
|
:: acc)
|
2011-08-01 15:42:13 +00:00
|
|
|
in
|
2015-05-12 15:46:24 +00:00
|
|
|
let bindings =
|
|
|
|
Bindings.fold
|
|
|
|
(fun key actions map ->
|
|
|
|
Keys_map.add key
|
|
|
|
(List.map (fun action -> (LTerm_read_line.Edit action)) actions) map)
|
|
|
|
!LTerm_edit.bindings Keys_map.empty
|
|
|
|
in
|
2011-08-01 20:44:29 +00:00
|
|
|
let bindings = Bindings.fold Keys_map.add !LTerm_read_line.bindings bindings in
|
2015-05-12 15:46:24 +00:00
|
|
|
let table =
|
|
|
|
List.rev (Keys_map.fold (fun keys action acc -> make_lines keys action acc)
|
|
|
|
bindings [])
|
|
|
|
in
|
2011-08-01 15:42:13 +00:00
|
|
|
let size_key, size_name, size_doc =
|
|
|
|
List.fold_left
|
|
|
|
(fun (size_key, size_name, size_doc) (key, name, doc) ->
|
|
|
|
(max (String.length key) size_key,
|
|
|
|
max (String.length name) size_name,
|
|
|
|
max (String.length doc) size_doc))
|
|
|
|
(0, 0, 0)
|
|
|
|
table
|
|
|
|
in
|
|
|
|
let buf = Buffer.create 128 in
|
|
|
|
let format_line (key, name, doc) =
|
|
|
|
Buffer.clear buf;
|
|
|
|
Buffer.add_string buf key;
|
|
|
|
while Buffer.length buf < size_key do
|
|
|
|
Buffer.add_char buf ' '
|
|
|
|
done;
|
|
|
|
Buffer.add_string buf " : ";
|
|
|
|
Buffer.add_string buf name;
|
|
|
|
while Buffer.length buf < size_key + size_name + 3 do
|
|
|
|
Buffer.add_char buf ' '
|
|
|
|
done;
|
|
|
|
Buffer.add_string buf " -> ";
|
|
|
|
Buffer.add_string buf doc;
|
|
|
|
Buffer.add_char buf '\n';
|
|
|
|
output_string stdout (Buffer.contents buf)
|
|
|
|
in
|
|
|
|
List.iter format_line table;
|
2011-08-01 21:51:14 +00:00
|
|
|
flush stdout));
|
|
|
|
|
|
|
|
Hashtbl.add Toploop.directive_table "utop_macro"
|
|
|
|
(Toploop.Directive_none
|
|
|
|
(fun () ->
|
2011-08-02 08:01:12 +00:00
|
|
|
let macro = Zed_macro.contents LTerm_read_line.macro in
|
2011-08-01 21:51:14 +00:00
|
|
|
List.iter
|
|
|
|
(fun action ->
|
2015-05-12 15:46:24 +00:00
|
|
|
output_string stdout (name_of_action action);
|
2011-08-01 21:51:14 +00:00
|
|
|
output_char stdout '\n')
|
|
|
|
macro;
|
2011-08-01 15:42:13 +00:00
|
|
|
flush stdout))
|
|
|
|
|
2015-11-23 12:48:27 +00:00
|
|
|
let () =
|
|
|
|
Hashtbl.add Toploop.directive_table "pwd"
|
|
|
|
(Toploop.Directive_none
|
|
|
|
(fun () -> print_endline (Sys.getcwd ())))
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Camlp4 |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
|
|
|
let print_error msg =
|
2014-10-18 16:35:39 +00:00
|
|
|
Lazy.force LTerm.stdout >>= fun term ->
|
|
|
|
LTerm.set_style term !UTop_private.error_style >>= fun () ->
|
|
|
|
Lwt_io.print msg >>= fun () ->
|
|
|
|
LTerm.set_style term LTerm_style.none >>= fun () ->
|
2012-02-11 09:21:07 +00:00
|
|
|
LTerm.flush term
|
|
|
|
|
|
|
|
let handle_findlib_error = function
|
|
|
|
| Failure msg ->
|
|
|
|
Lwt_main.run (print_error msg)
|
|
|
|
| Fl_package_base.No_such_package(pkg, reason) ->
|
2014-10-17 15:57:32 +00:00
|
|
|
Lwt_main.run (print_error (Printf.sprintf "No such package: %s%s\n" pkg (if reason <> "" then " - " ^ reason else "")))
|
2012-02-11 09:21:07 +00:00
|
|
|
| Fl_package_base.Package_loop pkg ->
|
|
|
|
Lwt_main.run (print_error (Printf.sprintf "Package requires itself: %s\n" pkg))
|
|
|
|
| exn ->
|
|
|
|
raise exn
|
|
|
|
|
2014-10-20 16:04:18 +00:00
|
|
|
let check_for_camlp4_support () =
|
|
|
|
try
|
|
|
|
ignore (Fl_package_base.query "utop.camlp4");
|
|
|
|
true
|
|
|
|
with Fl_package_base.No_such_package("utop.camlp4", "") ->
|
|
|
|
Lwt_main.run (print_error "utop was built without camlp4 support.\n");
|
|
|
|
false
|
|
|
|
|
2012-02-23 10:54:39 +00:00
|
|
|
let set_syntax syntax =
|
|
|
|
match get_syntax (), syntax with
|
|
|
|
| Normal, Normal
|
|
|
|
| Camlp4o, Camlp4o
|
|
|
|
| Camlp4r, Camlp4r ->
|
|
|
|
()
|
|
|
|
| (Camlp4o | Camlp4r), _ ->
|
|
|
|
Lwt_main.run (print_error "Camlp4 already loaded, you cannot change the syntax now.\n")
|
2014-10-20 16:04:18 +00:00
|
|
|
| Normal, Camlp4o ->
|
|
|
|
if check_for_camlp4_support () then begin
|
2012-02-23 10:54:39 +00:00
|
|
|
Topfind.syntax "camlp4o";
|
2014-10-20 16:04:18 +00:00
|
|
|
Topfind.load_deeply ["utop.camlp4"];
|
|
|
|
set_syntax Camlp4o;
|
|
|
|
set_phrase_terminator ";;"
|
|
|
|
end
|
|
|
|
| Normal, Camlp4r ->
|
|
|
|
if check_for_camlp4_support () then begin
|
2012-02-23 10:54:39 +00:00
|
|
|
Topfind.syntax "camlp4r";
|
2014-10-20 16:04:18 +00:00
|
|
|
Topfind.load_deeply ["utop.camlp4"];
|
|
|
|
set_syntax Camlp4r;
|
|
|
|
set_phrase_terminator ";";
|
|
|
|
add_keyword "value"
|
|
|
|
end
|
2012-02-23 10:54:39 +00:00
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
let () =
|
|
|
|
Hashtbl.add
|
|
|
|
Toploop.directive_table
|
|
|
|
"camlp4o"
|
|
|
|
(Toploop.Directive_none
|
2012-02-23 10:54:39 +00:00
|
|
|
(fun () -> set_syntax Camlp4o));
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
Hashtbl.add
|
|
|
|
Toploop.directive_table
|
|
|
|
"camlp4r"
|
|
|
|
(Toploop.Directive_none
|
2012-02-23 10:54:39 +00:00
|
|
|
(fun () -> set_syntax Camlp4r))
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2013-03-09 18:44:57 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
2013-08-07 15:57:28 +00:00
|
|
|
| Findlib stuff |
|
2013-03-09 18:44:57 +00:00
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2013-08-07 15:57:28 +00:00
|
|
|
let topfind_log, set_topfind_log = S.create ~eq:(fun _ _ -> false) []
|
|
|
|
|
|
|
|
let () =
|
|
|
|
let real_log = !Topfind.log in
|
|
|
|
Topfind.log := fun str ->
|
|
|
|
set_topfind_log (str :: S.value topfind_log);
|
|
|
|
if S.value topfind_verbose then real_log str
|
|
|
|
|
|
|
|
let () =
|
|
|
|
Hashtbl.add
|
|
|
|
Toploop.directive_table
|
|
|
|
"topfind_log"
|
|
|
|
(Toploop.Directive_none
|
|
|
|
(fun () ->
|
|
|
|
List.iter (fun str -> print_string str; print_char '\n')
|
|
|
|
(S.value topfind_log);
|
|
|
|
flush stdout));
|
|
|
|
|
|
|
|
Hashtbl.add
|
|
|
|
Toploop.directive_table
|
|
|
|
"topfind_verbose"
|
|
|
|
(Toploop.Directive_bool set_topfind_verbose)
|
|
|
|
|
2013-03-09 18:44:57 +00:00
|
|
|
let split_words str =
|
|
|
|
let len = String.length str in
|
|
|
|
let is_sep = function
|
|
|
|
| ' ' | '\t' | '\r' | '\n' | ',' -> true
|
|
|
|
| _ -> false
|
|
|
|
in
|
|
|
|
let rec skip i =
|
|
|
|
if i = len then
|
|
|
|
[]
|
|
|
|
else
|
|
|
|
if is_sep str.[i] then
|
|
|
|
skip (i + 1)
|
|
|
|
else
|
|
|
|
extract i (i + 1)
|
|
|
|
and extract i j =
|
|
|
|
if j = len then
|
|
|
|
[String.sub str i (j - i)]
|
|
|
|
else
|
|
|
|
if is_sep str.[j] then
|
2013-05-17 18:39:14 +00:00
|
|
|
String.sub str i (j - i) :: skip (j + 1)
|
2013-03-09 18:44:57 +00:00
|
|
|
else
|
|
|
|
extract i (j + 1)
|
|
|
|
in
|
|
|
|
skip 0
|
|
|
|
|
|
|
|
let require packages =
|
|
|
|
try
|
|
|
|
let eff_packages = Findlib.package_deep_ancestors !Topfind.predicates packages in
|
|
|
|
if get_syntax () = Normal && List.mem "camlp4" eff_packages then begin
|
|
|
|
set_syntax Camlp4o;
|
|
|
|
Topfind.load_deeply packages
|
|
|
|
end else
|
|
|
|
Topfind.load eff_packages
|
|
|
|
with exn ->
|
|
|
|
handle_findlib_error exn
|
|
|
|
|
|
|
|
let () =
|
|
|
|
Hashtbl.add
|
|
|
|
Toploop.directive_table
|
|
|
|
"require"
|
|
|
|
(Toploop.Directive_string
|
|
|
|
(fun str -> require (split_words str)))
|
|
|
|
|
2011-08-01 15:42:13 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Initialization |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2011-07-26 18:43:10 +00:00
|
|
|
let () =
|
2012-02-11 09:21:07 +00:00
|
|
|
(* "utop" is an internal library so it is not passed as "-package"
|
|
|
|
to "ocamlfind ocamlmktop". *)
|
|
|
|
Topfind.don't_load ["utop"];
|
2015-11-02 15:10:51 +00:00
|
|
|
Topfind.add_predicates ["byte"; "toploop"];
|
2012-01-22 14:37:06 +00:00
|
|
|
(* Add findlib path so Topfind is available and it won't be
|
|
|
|
initialized twice if the user does [#use "topfind"]. *)
|
|
|
|
Topdirs.dir_directory (Findlib.package_directory "findlib");
|
|
|
|
(* Make UTop accessible. *)
|
|
|
|
Topdirs.dir_directory (Findlib.package_directory "utop")
|
2011-08-01 15:42:13 +00:00
|
|
|
|
2014-12-11 20:25:12 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Compiler-libs re-exports |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
|
|
|
let load_path = Config.load_path
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| 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 [| |])
|