2012-02-11 09:21:07 +00:00
|
|
|
(*
|
|
|
|
* uTop_main.ml
|
|
|
|
* ------------
|
|
|
|
* Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org>
|
|
|
|
* Licence : BSD3
|
|
|
|
*
|
|
|
|
* This file is a part of utop.
|
|
|
|
*)
|
|
|
|
|
2019-01-14 18:57:08 +00:00
|
|
|
[@@@warning "-7-9-27-32-33"]
|
|
|
|
|
2018-07-14 07:56:00 +00:00
|
|
|
open CamomileLibraryDefault.Camomile
|
2012-02-11 09:21:07 +00:00
|
|
|
open Lwt_react
|
2018-07-14 07:45:19 +00:00
|
|
|
open LTerm_dlist
|
2012-02-11 09:21:07 +00:00
|
|
|
open LTerm_text
|
|
|
|
open LTerm_geom
|
2020-01-05 21:21:53 +00:00
|
|
|
open UTop
|
2012-02-11 09:21:07 +00:00
|
|
|
open UTop_token
|
|
|
|
open UTop_styles
|
|
|
|
open UTop_private
|
|
|
|
|
2014-10-18 16:35:39 +00:00
|
|
|
let return, (>>=) = Lwt.return, Lwt.(>>=)
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
module String_set = Set.Make(String)
|
|
|
|
|
2012-02-15 15:49:29 +00:00
|
|
|
exception Term of int
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| History |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2012-02-13 14:57:25 +00:00
|
|
|
let save_history () =
|
|
|
|
match !UTop.history_file_name with
|
|
|
|
| None ->
|
|
|
|
return ()
|
|
|
|
| Some fn ->
|
2014-10-18 16:35:39 +00:00
|
|
|
Lwt.catch
|
|
|
|
(fun () -> LTerm_history.save UTop.history
|
|
|
|
?max_size:!UTop.history_file_max_size
|
|
|
|
?max_entries:!UTop.history_file_max_entries fn)
|
|
|
|
(function
|
|
|
|
| Unix.Unix_error (error, func, arg) ->
|
|
|
|
Lwt_log.error_f "cannot save history to %S: %s: %s" fn func (Unix.error_message error)
|
|
|
|
| exn -> Lwt.fail exn)
|
2012-02-13 14:57:25 +00:00
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
let init_history () =
|
|
|
|
(* Save history on exit. *)
|
2012-02-13 14:57:25 +00:00
|
|
|
Lwt_main.at_exit save_history;
|
2012-02-11 09:21:07 +00:00
|
|
|
(* Load history. *)
|
2012-02-12 19:37:12 +00:00
|
|
|
match !UTop.history_file_name with
|
|
|
|
| None ->
|
|
|
|
return ()
|
|
|
|
| Some fn ->
|
2014-10-18 16:35:39 +00:00
|
|
|
Lwt.catch
|
|
|
|
(fun () -> LTerm_history.load UTop.history fn)
|
|
|
|
(function
|
|
|
|
| Unix.Unix_error (error, func, arg) ->
|
|
|
|
Lwt_log.error_f "cannot load history from %S: %s: %s"
|
|
|
|
fn func (Unix.error_message error)
|
|
|
|
| exn -> Lwt.fail exn)
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| 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
|
|
|
|
|
2020-01-05 21:21:53 +00:00
|
|
|
let convert_loc str (a, b) = (index_of_offset str a, index_of_offset str b)
|
|
|
|
|
|
|
|
let convert_locs str locs = List.map (fun (a, b) -> convert_loc str (a,b)) locs
|
|
|
|
|
|
|
|
let get_line src line =
|
|
|
|
let rec aux line' ofs skipped =
|
|
|
|
if ofs >= String.length src then
|
|
|
|
("", 0)
|
|
|
|
else if line' = line then
|
|
|
|
(String.sub src ofs (String.length src - ofs), skipped)
|
|
|
|
else
|
|
|
|
let ch, next_ofs = Zed_utf8.unsafe_extract_next src ofs in
|
|
|
|
if Zed_utf8.escaped_char ch = "\\n" then
|
|
|
|
aux (line' + 1) next_ofs (skipped + 1)
|
|
|
|
else
|
|
|
|
aux line' next_ofs (skipped + 1)
|
|
|
|
in
|
|
|
|
aux 1 0 0
|
|
|
|
|
|
|
|
let convert_one_line str line ofs=
|
|
|
|
let selected, skipped = get_line str line in
|
|
|
|
index_of_offset selected ofs + skipped
|
|
|
|
|
|
|
|
let convert_line str (start_ofs, end_ofs) lines =
|
|
|
|
(convert_one_line str lines.start start_ofs,
|
|
|
|
convert_one_line str lines.stop end_ofs)
|
|
|
|
|
|
|
|
let convert_loc_line input locs lines =
|
|
|
|
List.map2 (fun loc line ->
|
|
|
|
match line with
|
|
|
|
| None ->
|
|
|
|
convert_loc input loc
|
|
|
|
| Some line ->
|
|
|
|
convert_line input loc line) locs lines
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| The read-line class |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2017-04-19 21:34:49 +00:00
|
|
|
#if OCAML_VERSION >= (4, 04, 0)
|
|
|
|
let ast_impl_kind = Pparse.Structure
|
2017-04-20 12:34:48 +00:00
|
|
|
#else
|
2017-04-19 21:34:49 +00:00
|
|
|
let ast_impl_kind = Config.ast_impl_magic_number
|
|
|
|
#endif
|
|
|
|
|
|
|
|
let preprocess input =
|
|
|
|
match input with
|
|
|
|
| Parsetree.Ptop_def pstr ->
|
|
|
|
Parsetree.Ptop_def
|
|
|
|
(Pparse.apply_rewriters ~tool_name:"ocaml" ast_impl_kind pstr)
|
|
|
|
| _ -> input
|
|
|
|
|
2013-04-03 19:18:36 +00:00
|
|
|
let parse_input_multi input =
|
2012-02-23 14:07:00 +00:00
|
|
|
let buf = Buffer.create 32 in
|
|
|
|
let result =
|
|
|
|
UTop.collect_formatters buf [Format.err_formatter]
|
|
|
|
(fun () ->
|
2013-04-03 19:18:36 +00:00
|
|
|
match !UTop.parse_use_file input false with
|
|
|
|
| UTop.Error (locs, msg) ->
|
|
|
|
UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n")
|
|
|
|
| UTop.Value phrases ->
|
2017-04-19 21:34:49 +00:00
|
|
|
try
|
|
|
|
UTop.Value (List.map preprocess phrases)
|
|
|
|
with Pparse.Error error ->
|
|
|
|
Pparse.report_error Format.str_formatter error;
|
|
|
|
UTop.Error ([], "Error: " ^ Format.flush_str_formatter () ^ "\n"))
|
2013-04-03 19:18:36 +00:00
|
|
|
in
|
|
|
|
(result, Buffer.contents buf)
|
|
|
|
|
|
|
|
let parse_and_check input eos_is_error =
|
|
|
|
let buf = Buffer.create 32 in
|
|
|
|
let result =
|
|
|
|
UTop.collect_formatters buf [Format.err_formatter]
|
|
|
|
(fun () ->
|
2017-04-19 21:34:49 +00:00
|
|
|
match !UTop.parse_toplevel_phrase input eos_is_error with
|
2012-02-23 14:07:00 +00:00
|
|
|
| UTop.Error (locs, msg) ->
|
2017-04-19 21:34:49 +00:00
|
|
|
UTop.Error (convert_locs input locs, "Error: " ^ msg ^ "\n")
|
2012-02-23 14:07:00 +00:00
|
|
|
| UTop.Value phrase ->
|
2017-04-19 21:34:49 +00:00
|
|
|
try
|
|
|
|
let phrase = preprocess phrase in
|
|
|
|
match UTop.check_phrase phrase with
|
|
|
|
| None ->
|
|
|
|
UTop.Value phrase
|
2020-01-05 21:21:53 +00:00
|
|
|
| Some (locs, msg, lines) ->
|
|
|
|
UTop.Error (convert_loc_line input locs lines, msg)
|
2017-04-19 21:34:49 +00:00
|
|
|
with Pparse.Error error ->
|
|
|
|
Pparse.report_error Format.str_formatter error;
|
|
|
|
UTop.Error ([], "Error: " ^ Format.flush_str_formatter () ^ "\n"))
|
2012-02-23 14:07:00 +00:00
|
|
|
in
|
|
|
|
(result, Buffer.contents buf)
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2015-05-12 15:46:24 +00:00
|
|
|
let add_terminator s =
|
2019-04-01 16:51:01 +00:00
|
|
|
let terminator = UTop.get_phrase_terminator () |> Zed_string.unsafe_of_utf8 in
|
2019-05-17 04:01:04 +00:00
|
|
|
if Zed_string.ends_with s ~suffix:terminator then
|
2015-05-12 15:46:24 +00:00
|
|
|
s
|
|
|
|
else
|
2019-04-01 16:51:01 +00:00
|
|
|
Zed_string.append s terminator
|
2015-05-12 15:46:24 +00:00
|
|
|
|
|
|
|
let is_accept : LTerm_read_line.action -> bool = function
|
|
|
|
| Accept -> true
|
|
|
|
| action -> action == UTop.end_and_accept_current_phrase
|
|
|
|
|
2016-07-01 13:26:50 +00:00
|
|
|
(* Read a phrase. If the result is a value, it is guaranteed to be a
|
2012-02-23 14:07:00 +00:00
|
|
|
valid phrase (i.e. typable and compilable). It also returns
|
|
|
|
warnings printed parsing. *)
|
2012-02-11 09:21:07 +00:00
|
|
|
class read_phrase ~term = object(self)
|
2019-04-01 16:51:01 +00:00
|
|
|
inherit [Parsetree.toplevel_phrase UTop.result * string] LTerm_read_line.engine ~history:(LTerm_history.contents UTop.history) () as super
|
2012-02-23 14:07:00 +00:00
|
|
|
inherit [Parsetree.toplevel_phrase UTop.result * string] LTerm_read_line.term term as super_term
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2015-10-29 09:55:31 +00:00
|
|
|
method create_temporary_file_for_external_editor =
|
|
|
|
Filename.temp_file "utop" ".ml"
|
|
|
|
|
2015-10-29 10:07:28 +00:00
|
|
|
method external_editor = UTop.get_external_editor ()
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
val mutable return_value = None
|
|
|
|
|
|
|
|
method eval =
|
|
|
|
match return_value with
|
2015-05-12 15:46:24 +00:00
|
|
|
| Some x ->
|
|
|
|
x
|
|
|
|
| None -> assert false
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2015-08-07 10:03:25 +00:00
|
|
|
method! send_action action =
|
|
|
|
let action : LTerm_read_line.action =
|
|
|
|
if is_accept action && S.value self#mode <> LTerm_read_line.Edition then
|
|
|
|
Accept
|
|
|
|
else
|
|
|
|
action
|
|
|
|
in
|
|
|
|
super#send_action action
|
|
|
|
|
2020-04-08 02:39:38 +00:00
|
|
|
method! exec ?(keys=[]) = function
|
2015-05-12 15:46:24 +00:00
|
|
|
| action :: actions when S.value self#mode = LTerm_read_line.Edition &&
|
|
|
|
is_accept action -> begin
|
|
|
|
Zed_macro.add self#macro action;
|
2012-02-11 09:21:07 +00:00
|
|
|
let input = Zed_rope.to_string (Zed_edit.text self#edit) in
|
2015-05-12 15:46:24 +00:00
|
|
|
let input =
|
|
|
|
if action == UTop.end_and_accept_current_phrase then
|
|
|
|
add_terminator input
|
|
|
|
else
|
|
|
|
input
|
|
|
|
in
|
2019-04-01 16:51:01 +00:00
|
|
|
let input_utf8= Zed_string.to_utf8 input in
|
2012-02-11 09:21:07 +00:00
|
|
|
(* Toploop does that: *)
|
|
|
|
Location.reset ();
|
2015-05-12 15:46:24 +00:00
|
|
|
let eos_is_error = not !UTop.smart_accept in
|
2012-02-11 09:21:07 +00:00
|
|
|
try
|
2019-04-01 16:51:01 +00:00
|
|
|
let result = parse_and_check input_utf8 eos_is_error in
|
2012-02-11 09:21:07 +00:00
|
|
|
return_value <- Some result;
|
2012-02-12 19:04:32 +00:00
|
|
|
LTerm_history.add UTop.history input;
|
2017-04-10 21:49:05 +00:00
|
|
|
let out, warnings = result in
|
|
|
|
begin
|
|
|
|
match out with
|
|
|
|
| UTop.Value _ ->
|
2019-04-01 16:51:01 +00:00
|
|
|
UTop_history.add_input UTop.stashable_session_history input_utf8;
|
2017-04-10 21:49:05 +00:00
|
|
|
UTop_history.add_warnings UTop.stashable_session_history warnings;
|
|
|
|
| (UTop.Error (_, msg)) ->
|
2019-04-01 16:51:01 +00:00
|
|
|
UTop_history.add_bad_input UTop.stashable_session_history input_utf8;
|
2017-04-10 21:49:05 +00:00
|
|
|
UTop_history.add_warnings UTop.stashable_session_history warnings;
|
|
|
|
UTop_history.add_error UTop.stashable_session_history msg;
|
|
|
|
end;
|
2020-04-08 02:39:38 +00:00
|
|
|
return (LTerm_read_line.Result result)
|
2012-02-11 09:21:07 +00:00
|
|
|
with UTop.Need_more ->
|
|
|
|
(* Input not finished, continue. *)
|
|
|
|
self#insert (UChar.of_char '\n');
|
2020-04-08 02:39:38 +00:00
|
|
|
self#exec ~keys actions
|
2012-02-11 09:21:07 +00:00
|
|
|
end
|
|
|
|
| actions ->
|
2015-05-12 15:46:24 +00:00
|
|
|
super_term#exec actions
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2015-08-07 10:03:25 +00:00
|
|
|
method! stylise last =
|
2012-02-11 09:21:07 +00:00
|
|
|
let styled, position = super#stylise last in
|
|
|
|
|
|
|
|
(* Syntax highlighting *)
|
2012-02-22 15:59:31 +00:00
|
|
|
let stylise loc token_style =
|
|
|
|
for i = loc.idx1 to loc.idx2 - 1 do
|
2012-02-11 09:21:07 +00:00
|
|
|
let ch, style = styled.(i) in
|
|
|
|
styled.(i) <- (ch, LTerm_style.merge token_style style)
|
|
|
|
done
|
|
|
|
in
|
2019-07-08 07:30:37 +00:00
|
|
|
UTop_styles.stylise stylise (UTop_lexer.lex_string (Zed_string.to_utf8 (LTerm_text.to_string styled)));
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
if not last then
|
|
|
|
(* Parenthesis matching. *)
|
|
|
|
LTerm_text.stylise_parenthesis styled position styles.style_paren
|
|
|
|
else begin
|
|
|
|
match return_value with
|
2015-05-12 15:46:24 +00:00
|
|
|
| Some (UTop.Error (locs, _), _) ->
|
|
|
|
(* Highlight error locations. *)
|
|
|
|
List.iter
|
|
|
|
(fun (start, stop) ->
|
2015-08-04 10:26:28 +00:00
|
|
|
for i = max 0 start to min (Array.length styled) stop - 1 do
|
2015-05-12 15:46:24 +00:00
|
|
|
let ch, style = styled.(i) in
|
|
|
|
styled.(i) <- (ch, { style with LTerm_style.underline = Some true })
|
|
|
|
done)
|
|
|
|
locs
|
|
|
|
| _ ->
|
|
|
|
()
|
2012-02-11 09:21:07 +00:00
|
|
|
end;
|
|
|
|
|
|
|
|
(styled, position)
|
|
|
|
|
2015-08-07 10:03:25 +00:00
|
|
|
method! completion =
|
2012-02-22 15:59:31 +00:00
|
|
|
let pos, words =
|
|
|
|
UTop_complete.complete
|
|
|
|
~phrase_terminator:(UTop.get_phrase_terminator ())
|
2019-04-01 16:51:01 +00:00
|
|
|
~input:(Zed_string.to_utf8 (Zed_rope.to_string self#input_prev))
|
2012-02-22 15:59:31 +00:00
|
|
|
in
|
2019-03-30 13:27:48 +00:00
|
|
|
let words= words |> List.map (fun (k, v)->
|
2019-04-01 16:51:01 +00:00
|
|
|
(Zed_string.unsafe_of_utf8 k, Zed_string.unsafe_of_utf8 v)) in
|
2012-02-11 09:21:07 +00:00
|
|
|
self#set_completion pos words
|
|
|
|
|
2015-08-07 10:03:25 +00:00
|
|
|
method! show_box = S.value self#mode <> LTerm_read_line.Edition || UTop.get_show_box ()
|
2013-04-26 08:53:59 +00:00
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
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 |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2012-02-15 17:36:08 +00:00
|
|
|
let fix_string str =
|
|
|
|
let len = String.length str in
|
2012-02-15 20:47:40 +00:00
|
|
|
let ofs, _, _ = Zed_utf8.next_error str 0 in
|
|
|
|
if ofs = len then
|
2012-02-15 17:36:08 +00:00
|
|
|
str
|
2012-02-15 20:47:40 +00:00
|
|
|
else begin
|
2012-02-15 17:36:08 +00:00
|
|
|
let buf = Buffer.create (len + 128) in
|
2012-02-15 20:47:40 +00:00
|
|
|
if ofs > 0 then Buffer.add_substring buf str 0 ofs;
|
|
|
|
let rec loop ofs =
|
2016-02-01 08:55:17 +00:00
|
|
|
Zed_utf8.add buf (UChar.of_char str.[ofs]);
|
2012-02-15 20:47:40 +00:00
|
|
|
let ofs1 = ofs + 1 in
|
|
|
|
let ofs2, _, _ = Zed_utf8.next_error str ofs1 in
|
|
|
|
if ofs1 < ofs2 then
|
|
|
|
Buffer.add_substring buf str ofs1 (ofs2 - ofs1);
|
|
|
|
if ofs2 < len then
|
|
|
|
loop ofs2
|
|
|
|
else
|
|
|
|
Buffer.contents buf
|
|
|
|
in
|
|
|
|
loop ofs
|
|
|
|
end
|
2012-02-15 17:36:08 +00:00
|
|
|
|
2013-02-06 22:22:03 +00:00
|
|
|
let render_out_phrase term string =
|
2014-06-24 13:25:49 +00:00
|
|
|
if String.length string >= 100 * 1024 then
|
|
|
|
LTerm.fprint term string
|
|
|
|
else begin
|
|
|
|
let string = fix_string string in
|
2019-03-30 13:27:48 +00:00
|
|
|
let styled = LTerm_text.of_utf8 string in
|
2014-06-24 13:25:49 +00:00
|
|
|
let stylise loc token_style =
|
|
|
|
for i = loc.idx1 to loc.idx2 - 1 do
|
|
|
|
let ch, style = styled.(i) in
|
|
|
|
styled.(i) <- (ch, LTerm_style.merge token_style style)
|
|
|
|
done
|
|
|
|
in
|
2019-07-08 07:30:37 +00:00
|
|
|
UTop_styles.stylise stylise (UTop_lexer.lex_string string);
|
2014-06-24 13:25:49 +00:00
|
|
|
LTerm.fprints term styled
|
|
|
|
end
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2013-02-06 22:22:03 +00:00
|
|
|
let orig_print_out_signature = !Toploop.print_out_signature
|
|
|
|
let orig_print_out_phrase = !Toploop.print_out_phrase
|
|
|
|
|
2017-04-18 19:42:13 +00:00
|
|
|
let is_implicit_name name =
|
|
|
|
name <> "" &&
|
|
|
|
name.[0] = '_' &&
|
|
|
|
try
|
|
|
|
let _ = int_of_string @@ String.sub name 1 (String.length name - 1) in
|
|
|
|
true
|
|
|
|
with
|
|
|
|
Failure _ -> false
|
|
|
|
|
2018-08-23 16:53:07 +00:00
|
|
|
let map_items unwrap wrap items =
|
|
|
|
let rec aux acc = function
|
|
|
|
| [] ->
|
|
|
|
acc
|
|
|
|
| item :: items ->
|
|
|
|
let sig_item, _ = unwrap item in
|
|
|
|
let name, rec_status =
|
|
|
|
match sig_item with
|
|
|
|
| Outcometree.Osig_class (_, name, _, _, rs)
|
|
|
|
| Outcometree.Osig_class_type (_, name, _, _, rs)
|
|
|
|
| Outcometree.Osig_module (name, _, rs)
|
|
|
|
| Outcometree.Osig_type ({ Outcometree.otype_name = name }, rs) ->
|
|
|
|
(name, rs)
|
|
|
|
| Outcometree.Osig_typext ({ Outcometree.oext_name = name}, _)
|
|
|
|
| Outcometree.Osig_modtype (name, _)
|
2016-03-02 17:38:10 +00:00
|
|
|
#if OCAML_VERSION < (4, 03, 0)
|
2018-08-23 16:53:07 +00:00
|
|
|
| Outcometree.Osig_value (name, _, _) ->
|
|
|
|
(name, Outcometree.Orec_not)
|
2016-03-02 17:38:10 +00:00
|
|
|
#else
|
2018-08-23 16:53:07 +00:00
|
|
|
| Outcometree.Osig_value { oval_name = name; _ } ->
|
|
|
|
(name, Outcometree.Orec_not)
|
|
|
|
| Outcometree.Osig_ellipsis -> ("", Outcometree.Orec_not)
|
2015-03-18 16:47:29 +00:00
|
|
|
#endif
|
2018-08-23 16:53:07 +00:00
|
|
|
in
|
|
|
|
let keep =
|
|
|
|
name = "" || name.[0] <> '_' ||
|
|
|
|
(UTop.get_create_implicits () && is_implicit_name name)
|
|
|
|
in
|
|
|
|
if keep then
|
|
|
|
aux (item :: acc) items
|
|
|
|
else
|
|
|
|
(* Replace the [Orec_next] at the head of items by [Orec_first] *)
|
|
|
|
let items =
|
|
|
|
match items with
|
|
|
|
| [] ->
|
|
|
|
[]
|
|
|
|
| item :: items' ->
|
|
|
|
let sig_item, extra = unwrap item in
|
|
|
|
match sig_item with
|
|
|
|
| Outcometree.Osig_class (a, name, b, c, rs) ->
|
|
|
|
if rs = Outcometree.Orec_next then
|
|
|
|
wrap (Outcometree.Osig_class (a, name, b, c, Outcometree.Orec_first)) extra :: items'
|
|
|
|
else
|
|
|
|
items
|
|
|
|
| Outcometree.Osig_class_type (a, name, b, c, rs) ->
|
|
|
|
if rs = Outcometree.Orec_next then
|
|
|
|
wrap (Outcometree.Osig_class_type (a, name, b, c, Outcometree.Orec_first)) extra :: items'
|
|
|
|
else
|
|
|
|
items
|
|
|
|
| Outcometree.Osig_module (name, a, rs) ->
|
|
|
|
if rs = Outcometree.Orec_next then
|
|
|
|
wrap (Outcometree.Osig_module (name, a, Outcometree.Orec_first)) extra :: items'
|
|
|
|
else
|
|
|
|
items
|
|
|
|
| Outcometree.Osig_type (oty, rs) ->
|
|
|
|
if rs = Outcometree.Orec_next then
|
|
|
|
wrap (Outcometree.Osig_type (oty, Outcometree.Orec_first)) extra :: items'
|
|
|
|
else
|
|
|
|
items
|
|
|
|
| Outcometree.Osig_typext _
|
2015-03-18 16:47:29 +00:00
|
|
|
#if OCAML_VERSION >= (4, 03, 0)
|
2018-08-23 16:53:07 +00:00
|
|
|
| Outcometree.Osig_ellipsis
|
2014-05-06 16:18:39 +00:00
|
|
|
#endif
|
2018-08-23 16:53:07 +00:00
|
|
|
| Outcometree.Osig_modtype _
|
|
|
|
| Outcometree.Osig_value _ ->
|
|
|
|
items
|
|
|
|
in
|
|
|
|
aux acc items
|
|
|
|
in
|
|
|
|
List.rev (aux [] items)
|
2013-02-06 22:22:03 +00:00
|
|
|
|
|
|
|
let print_out_signature pp items =
|
|
|
|
if UTop.get_hide_reserved () then
|
|
|
|
orig_print_out_signature pp (map_items (fun x -> (x, ())) (fun x () -> x) items)
|
|
|
|
else
|
|
|
|
orig_print_out_signature pp items
|
|
|
|
|
|
|
|
let print_out_phrase pp phrase =
|
|
|
|
if UTop.get_hide_reserved () then
|
|
|
|
let phrase =
|
|
|
|
match phrase with
|
|
|
|
| Outcometree.Ophr_eval _
|
|
|
|
| Outcometree.Ophr_exception _ ->
|
|
|
|
phrase
|
|
|
|
| Outcometree.Ophr_signature items ->
|
|
|
|
Outcometree.Ophr_signature (map_items (fun x -> x) (fun x y -> (x, y)) items)
|
|
|
|
in
|
|
|
|
orig_print_out_phrase pp phrase
|
|
|
|
else
|
|
|
|
orig_print_out_phrase pp phrase
|
|
|
|
|
|
|
|
let () =
|
|
|
|
Toploop.print_out_signature := print_out_signature;
|
|
|
|
Toploop.print_out_phrase := print_out_phrase
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
2012-10-15 09:45:44 +00:00
|
|
|
| Toplevel expression rewriting |
|
2012-02-11 09:21:07 +00:00
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2012-06-15 14:23:21 +00:00
|
|
|
let with_loc loc str = {
|
|
|
|
Location.txt = str;
|
|
|
|
Location.loc = loc;
|
|
|
|
}
|
|
|
|
|
2012-10-15 09:45:44 +00:00
|
|
|
(* A rule for rewriting a toplevel expression. *)
|
|
|
|
type rewrite_rule = {
|
2016-01-07 10:30:06 +00:00
|
|
|
type_to_rewrite : Longident.t;
|
|
|
|
mutable path_to_rewrite : Path.t option;
|
2012-10-15 09:45:44 +00:00
|
|
|
required_values : Longident.t list;
|
|
|
|
(* Values that must exist and be persistent for the rule to apply. *)
|
|
|
|
rewrite : Location.t -> Parsetree.expression -> Parsetree.expression;
|
|
|
|
(* The rewrite function. *)
|
|
|
|
enabled : bool React.signal;
|
|
|
|
(* Whether the rule is enabled or not. *)
|
|
|
|
}
|
|
|
|
|
2020-05-08 06:54:32 +00:00
|
|
|
#if OCAML_VERSION < (4, 11, 0)
|
|
|
|
let longident_parse= Longident.parse
|
|
|
|
#else
|
|
|
|
let longident_parse str=
|
|
|
|
let lexbuf= Lexing.from_string str in
|
|
|
|
Parse.longident lexbuf
|
|
|
|
#endif
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
let longident_lwt_main_run = Longident.Ldot (Longident.Lident "Lwt_main", "run")
|
2014-02-10 09:42:34 +00:00
|
|
|
let longident_async_thread_safe_block_on_async_exn =
|
2020-05-08 12:45:39 +00:00
|
|
|
Longident.(Ldot (Ldot (Lident "Async", "Thread_safe"), "block_on_async_exn"))
|
2012-10-15 06:02:59 +00:00
|
|
|
let longident_unit = Longident.Lident "()"
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2015-03-18 16:47:29 +00:00
|
|
|
#if OCAML_VERSION >= (4, 03, 0)
|
|
|
|
let nolabel = Asttypes.Nolabel
|
|
|
|
#else
|
|
|
|
let nolabel = ""
|
|
|
|
#endif
|
|
|
|
|
2016-01-07 10:30:06 +00:00
|
|
|
let rewrite_rules = [
|
2012-10-15 09:45:44 +00:00
|
|
|
(* Rewrite Lwt.t expressions to Lwt_main.run <expr> *)
|
2016-01-07 10:30:06 +00:00
|
|
|
{
|
2020-05-08 12:45:39 +00:00
|
|
|
type_to_rewrite = Longident.(Ldot (Lident "Lwt", "t"));
|
2016-01-07 10:30:06 +00:00
|
|
|
path_to_rewrite = None;
|
2012-10-15 09:45:44 +00:00
|
|
|
required_values = [longident_lwt_main_run];
|
2014-02-14 09:49:00 +00:00
|
|
|
rewrite = (fun loc e ->
|
|
|
|
let open Ast_helper in
|
|
|
|
with_default_loc loc (fun () ->
|
2015-03-18 16:47:29 +00:00
|
|
|
Exp.apply (Exp.ident (with_loc loc longident_lwt_main_run)) [(nolabel, e)]
|
2014-02-14 09:49:00 +00:00
|
|
|
)
|
|
|
|
);
|
2012-10-15 09:45:44 +00:00
|
|
|
enabled = UTop.auto_run_lwt;
|
|
|
|
};
|
|
|
|
|
2017-04-26 07:41:43 +00:00
|
|
|
(* Rewrite Async.Defered.t expressions to
|
|
|
|
Async.Thread_safe.block_on_async_exn (fun () -> <expr>). *)
|
2016-01-07 10:30:06 +00:00
|
|
|
{
|
2020-05-08 12:45:39 +00:00
|
|
|
type_to_rewrite = Longident.(Ldot (Ldot (Lident "Async", "Deferred"), "t"));
|
2016-01-07 10:30:06 +00:00
|
|
|
path_to_rewrite = None;
|
2014-02-10 09:42:34 +00:00
|
|
|
required_values = [longident_async_thread_safe_block_on_async_exn];
|
2014-02-14 09:49:00 +00:00
|
|
|
rewrite = (fun loc e ->
|
|
|
|
let open Ast_helper in
|
2014-05-02 09:58:05 +00:00
|
|
|
let punit = Pat.construct (with_loc loc (Longident.Lident "()")) None in
|
2014-02-14 09:49:00 +00:00
|
|
|
with_default_loc loc (fun () ->
|
|
|
|
Exp.apply
|
|
|
|
(Exp.ident (with_loc loc longident_async_thread_safe_block_on_async_exn))
|
2015-03-18 16:47:29 +00:00
|
|
|
[(nolabel, Exp.fun_ nolabel None punit e)]
|
2014-02-14 09:49:00 +00:00
|
|
|
)
|
|
|
|
);
|
2012-10-15 09:45:44 +00:00
|
|
|
enabled = UTop.auto_run_async;
|
2016-01-07 10:30:06 +00:00
|
|
|
}
|
|
|
|
]
|
|
|
|
|
2019-12-12 02:15:29 +00:00
|
|
|
#if OCAML_VERSION >= (4, 10, 0)
|
|
|
|
let lookup_type longident env =
|
|
|
|
Env.find_type_by_name longident env
|
2019-12-12 09:01:21 +00:00
|
|
|
#elif OCAML_VERSION >= (4, 04, 0)
|
2016-08-15 08:32:20 +00:00
|
|
|
let lookup_type longident env =
|
|
|
|
let path = Env.lookup_type longident env in
|
|
|
|
(path, Env.find_type path env)
|
|
|
|
#else
|
|
|
|
let lookup_type = Env.lookup_type
|
|
|
|
#endif
|
|
|
|
|
2016-01-07 10:30:06 +00:00
|
|
|
let rule_path rule =
|
|
|
|
match rule.path_to_rewrite with
|
|
|
|
| Some _ as x -> x
|
|
|
|
| None ->
|
|
|
|
try
|
|
|
|
let env = !Toploop.toplevel_env in
|
|
|
|
let path =
|
2016-08-15 08:32:20 +00:00
|
|
|
match lookup_type rule.type_to_rewrite env with
|
2016-01-07 10:30:06 +00:00
|
|
|
| path, { Types.type_kind = Types.Type_abstract
|
|
|
|
; Types.type_private = Asttypes.Public
|
|
|
|
; Types.type_manifest = Some ty
|
|
|
|
} -> begin
|
|
|
|
match Ctype.expand_head env ty with
|
|
|
|
| { Types.desc = Types.Tconstr (path, _, _) } -> path
|
|
|
|
| _ -> path
|
|
|
|
end
|
|
|
|
| path, _ -> path
|
|
|
|
in
|
|
|
|
let opt = Some path in
|
|
|
|
rule.path_to_rewrite <- opt;
|
|
|
|
opt
|
|
|
|
with _ ->
|
|
|
|
None
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2012-10-15 09:45:44 +00:00
|
|
|
(* Returns whether the given path is persistent. *)
|
|
|
|
let rec is_persistent_path = function
|
|
|
|
| Path.Pident id -> Ident.persistent id
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
| Path.Pdot (p, _) -> is_persistent_path p
|
|
|
|
#else
|
2012-10-15 09:45:44 +00:00
|
|
|
| Path.Pdot (p, _, _) -> is_persistent_path p
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2012-10-15 09:45:44 +00:00
|
|
|
| Path.Papply (_, p) -> is_persistent_path p
|
|
|
|
|
|
|
|
(* Check that the given long identifier is present in the environment
|
|
|
|
and is persistent. *)
|
|
|
|
let is_persistent_in_env longident =
|
2019-12-12 02:15:29 +00:00
|
|
|
let lookup_value=
|
|
|
|
#if OCAML_VERSION >= (4, 10, 0)
|
|
|
|
Env.find_value_by_name
|
|
|
|
#else
|
|
|
|
Env.lookup_value
|
|
|
|
#endif
|
|
|
|
in
|
2012-10-15 09:45:44 +00:00
|
|
|
try
|
2019-12-12 02:15:29 +00:00
|
|
|
is_persistent_path (fst (lookup_value longident !Toploop.toplevel_env))
|
2012-10-15 09:45:44 +00:00
|
|
|
with Not_found ->
|
|
|
|
false
|
2012-10-15 06:02:59 +00:00
|
|
|
|
2016-01-07 10:30:06 +00:00
|
|
|
let rule_matches rule path =
|
|
|
|
React.S.value rule.enabled &&
|
|
|
|
(match rule_path rule with
|
|
|
|
| None -> false
|
|
|
|
| Some path' -> Path.same path path') &&
|
|
|
|
List.for_all is_persistent_in_env rule.required_values
|
|
|
|
|
|
|
|
(* Returns whether the argument is a toplevel expression. *)
|
|
|
|
let is_eval = function
|
|
|
|
| { Parsetree.pstr_desc = Parsetree.Pstr_eval _ } -> true
|
|
|
|
| _ -> false
|
|
|
|
|
|
|
|
(* Returns the rewrite rule associated to a type, if any. *)
|
2018-08-23 16:53:07 +00:00
|
|
|
let rule_of_type typ =
|
2016-01-07 10:30:06 +00:00
|
|
|
match (Ctype.expand_head !Toploop.toplevel_env typ).Types.desc with
|
|
|
|
| Types.Tconstr (path, _, _) -> begin
|
|
|
|
try
|
|
|
|
Some (List.find (fun rule -> rule_matches rule path) rewrite_rules)
|
|
|
|
with _ ->
|
|
|
|
None
|
|
|
|
end
|
|
|
|
| _ ->
|
|
|
|
None
|
|
|
|
|
2014-02-14 09:49:00 +00:00
|
|
|
let rewrite_str_item pstr_item tstr_item =
|
2014-10-20 12:45:26 +00:00
|
|
|
match pstr_item, tstr_item.Typedtree.str_desc with
|
2014-02-14 09:49:00 +00:00
|
|
|
| ({ Parsetree.pstr_desc = Parsetree.Pstr_eval (e, _);
|
|
|
|
Parsetree.pstr_loc = loc },
|
|
|
|
Typedtree.Tstr_eval ({ Typedtree.exp_type = typ }, _)) -> begin
|
|
|
|
match rule_of_type typ with
|
|
|
|
| Some rule ->
|
2016-01-07 10:30:06 +00:00
|
|
|
{ Parsetree.pstr_desc = Parsetree.Pstr_eval (rule.rewrite loc e, []);
|
|
|
|
Parsetree.pstr_loc = loc }
|
2014-02-14 09:49:00 +00:00
|
|
|
| None ->
|
|
|
|
pstr_item
|
|
|
|
end
|
|
|
|
| _ ->
|
|
|
|
pstr_item
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2020-10-30 15:22:14 +00:00
|
|
|
let type_structure env pstr =
|
|
|
|
#if OCAML_VERSION >= (4, 12, 0)
|
|
|
|
let tstr, _, _, _ = Typemod.type_structure env pstr in
|
|
|
|
#elif OCAML_VERSION >= (4, 08, 0)
|
|
|
|
let tstr, _, _, _ = Typemod.type_structure env pstr Location.none in
|
|
|
|
#else
|
|
|
|
let tstr, _, _ = Typemod.type_structure env pstr Location.none in
|
|
|
|
#endif
|
|
|
|
tstr
|
|
|
|
|
2012-10-15 09:45:44 +00:00
|
|
|
let rewrite phrase =
|
2012-10-15 06:02:59 +00:00
|
|
|
match phrase with
|
|
|
|
| Parsetree.Ptop_def pstr ->
|
2012-10-15 09:45:44 +00:00
|
|
|
if (UTop.get_auto_run_lwt () || UTop.get_auto_run_async ()) && List.exists is_eval pstr then
|
2020-10-30 15:22:14 +00:00
|
|
|
let tstr = type_structure !Toploop.toplevel_env pstr in
|
2014-10-20 12:45:26 +00:00
|
|
|
Parsetree.Ptop_def (List.map2 rewrite_str_item pstr tstr.Typedtree.str_items)
|
2012-10-15 09:45:44 +00:00
|
|
|
else
|
2017-04-12 23:56:26 +00:00
|
|
|
phrase
|
|
|
|
| Parsetree.Ptop_dir _ ->
|
|
|
|
phrase
|
|
|
|
|
|
|
|
let add_let binding_name def =
|
|
|
|
let open Parsetree in
|
|
|
|
match def with
|
|
|
|
| { pstr_desc = Pstr_eval (expr, attr); pstr_loc } ->
|
|
|
|
{
|
|
|
|
pstr_loc;
|
|
|
|
pstr_desc = Pstr_value (Asttypes.Nonrecursive, [
|
|
|
|
{
|
2017-04-18 19:42:13 +00:00
|
|
|
pvb_pat = {
|
|
|
|
ppat_desc = Ppat_var { txt = binding_name; loc = pstr_loc; };
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
ppat_loc_stack= [];
|
|
|
|
#endif
|
2017-04-18 19:42:13 +00:00
|
|
|
ppat_loc = pstr_loc;
|
|
|
|
ppat_attributes = [];
|
|
|
|
};
|
|
|
|
pvb_expr = expr;
|
|
|
|
pvb_attributes = attr;
|
|
|
|
pvb_loc = pstr_loc;
|
|
|
|
}]);
|
2017-04-12 23:56:26 +00:00
|
|
|
}
|
|
|
|
| _ ->
|
|
|
|
def
|
|
|
|
|
|
|
|
let bind_expressions name phrase =
|
|
|
|
match phrase with
|
|
|
|
| Parsetree.Ptop_def pstr ->
|
|
|
|
Parsetree.Ptop_def (List.map (add_let name) pstr)
|
2012-10-15 09:45:44 +00:00
|
|
|
| Parsetree.Ptop_dir _ ->
|
|
|
|
phrase
|
2012-10-15 06:02:59 +00:00
|
|
|
|
2019-01-15 18:49:54 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Handling of [@@toplevel_printer] attributes |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2019-01-16 08:59:48 +00:00
|
|
|
#if OCAML_VERSION >= (4, 04, 0)
|
2019-01-15 18:49:54 +00:00
|
|
|
|
2019-09-16 12:28:08 +00:00
|
|
|
#if OCAML_VERSION >= (4, 09, 0)
|
2019-12-12 02:15:29 +00:00
|
|
|
module Persistent_signature = Persistent_env.Persistent_signature
|
2019-09-16 12:28:08 +00:00
|
|
|
#else
|
2019-12-12 02:15:29 +00:00
|
|
|
module Persistent_signature = Env.Persistent_signature
|
2019-09-16 12:28:08 +00:00
|
|
|
#endif
|
2019-12-12 02:15:29 +00:00
|
|
|
|
|
|
|
let execute_phrase =
|
|
|
|
let new_cmis = ref []in
|
|
|
|
let default_load = !Persistent_signature.load in
|
2019-01-15 18:49:54 +00:00
|
|
|
let load ~unit_name =
|
|
|
|
let res = default_load ~unit_name in
|
|
|
|
(match res with None -> () | Some x -> new_cmis := x.cmi :: !new_cmis);
|
|
|
|
res
|
|
|
|
in
|
2019-12-12 02:15:29 +00:00
|
|
|
Persistent_signature.load := load;
|
2019-01-15 18:49:54 +00:00
|
|
|
|
|
|
|
let rec collect_printers path signature acc =
|
|
|
|
List.fold_left (fun acc item ->
|
|
|
|
match (item : Types.signature_item) with
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
| Sig_module (id, _, {md_type = Mty_signature s; _}, _, _) ->
|
|
|
|
#else
|
2019-01-15 18:49:54 +00:00
|
|
|
| Sig_module (id, {md_type = Mty_signature s; _}, _) ->
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2019-01-15 18:49:54 +00:00
|
|
|
collect_printers (Longident.Ldot (path, Ident.name id)) s acc
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
| Sig_value (id, vd, _) ->
|
|
|
|
#else
|
2019-01-15 18:49:54 +00:00
|
|
|
| Sig_value (id, vd) ->
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
if List.exists (fun attr->
|
|
|
|
let open Parsetree in
|
|
|
|
match attr.attr_name with
|
|
|
|
| {Asttypes.txt = "toplevel_printer" | "ocaml.toplevel_printer"; _} ->
|
|
|
|
#else
|
2019-01-15 18:49:54 +00:00
|
|
|
if List.exists (function
|
|
|
|
| {Asttypes.txt = "toplevel_printer" | "ocaml.toplevel_printer"; _},
|
|
|
|
_ ->
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2019-01-15 18:49:54 +00:00
|
|
|
true
|
|
|
|
| _ -> false)
|
|
|
|
vd.val_attributes
|
|
|
|
then
|
|
|
|
Longident.Ldot (path, Ident.name id) :: acc
|
|
|
|
else acc
|
|
|
|
| _ -> acc)
|
|
|
|
acc signature
|
|
|
|
in
|
|
|
|
|
|
|
|
let acknowledge_new_cmis () =
|
|
|
|
let l = !new_cmis in
|
|
|
|
new_cmis := [];
|
|
|
|
let printers =
|
|
|
|
List.fold_left (fun acc (cmi : Cmi_format.cmi_infos) ->
|
|
|
|
collect_printers (Longident.Lident cmi.cmi_name) cmi.cmi_sign acc )
|
|
|
|
[] l
|
|
|
|
in
|
|
|
|
List.iter (Topdirs.dir_install_printer Format.err_formatter) printers
|
|
|
|
in
|
|
|
|
|
|
|
|
fun b pp phrase ->
|
|
|
|
acknowledge_new_cmis ();
|
|
|
|
let res = Toploop.execute_phrase b pp phrase in
|
|
|
|
acknowledge_new_cmis ();
|
|
|
|
res
|
|
|
|
|
2019-01-16 08:59:48 +00:00
|
|
|
#else
|
|
|
|
|
|
|
|
let execute_phrase = Toploop.execute_phrase
|
|
|
|
|
|
|
|
#endif
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Main loop |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2020-05-30 01:19:39 +00:00
|
|
|
let registers= ref LTerm_vi.Vi.Interpret.RegisterMap.empty
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
let rec read_phrase term =
|
2014-10-18 16:35:39 +00:00
|
|
|
Lwt.catch
|
2020-04-14 08:05:09 +00:00
|
|
|
(fun () ->
|
2020-05-30 01:19:39 +00:00
|
|
|
let read_line= new read_phrase ~term in
|
|
|
|
(match !UTop.edit_mode with
|
|
|
|
| LTerm_editor.Default-> ()
|
|
|
|
| LTerm_editor.Vi as mode-> read_line#set_editor_mode mode);
|
|
|
|
let vi_state= read_line#vi_state in
|
|
|
|
vi_state#set_registers !registers;
|
|
|
|
read_line#run >>= fun result->
|
|
|
|
registers:= vi_state#get_registers;
|
|
|
|
return result)
|
2014-10-18 16:35:39 +00:00
|
|
|
(function
|
|
|
|
| Sys.Break ->
|
|
|
|
LTerm.fprintl term "Interrupted." >>= fun () ->
|
|
|
|
read_phrase term
|
|
|
|
| exn -> Lwt.fail exn)
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2012-02-22 16:21:47 +00:00
|
|
|
let print_error term msg =
|
2014-10-18 16:35:39 +00:00
|
|
|
LTerm.set_style term styles.style_error >>= 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 rec loop term =
|
|
|
|
(* Reset completion. *)
|
|
|
|
UTop_complete.reset ();
|
|
|
|
|
|
|
|
(* increment the command counter. *)
|
|
|
|
UTop_private.set_count (S.value UTop_private.count + 1);
|
|
|
|
|
|
|
|
(* Call hooks. *)
|
2018-07-14 07:45:19 +00:00
|
|
|
LTerm_dlist.iter_l (fun f -> f ()) UTop.new_command_hooks;
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
(* Read interactively user input. *)
|
|
|
|
let phrase_opt =
|
|
|
|
Lwt_main.run (
|
2014-10-18 16:35:39 +00:00
|
|
|
Lwt.finalize
|
|
|
|
(fun () ->
|
|
|
|
read_phrase term >>= fun (result, warnings) ->
|
|
|
|
(* Print warnings before errors. *)
|
|
|
|
Lwt_io.print warnings >>= fun () ->
|
|
|
|
match result with
|
|
|
|
| UTop.Value phrase ->
|
|
|
|
return (Some phrase)
|
2016-06-25 19:48:55 +00:00
|
|
|
| UTop.Error (locs, msg) ->
|
2014-10-18 16:35:39 +00:00
|
|
|
print_error term msg >>= fun () ->
|
|
|
|
return None)
|
|
|
|
(fun () -> LTerm.flush term)
|
2012-02-11 09:21:07 +00:00
|
|
|
)
|
|
|
|
in
|
|
|
|
match phrase_opt with
|
|
|
|
| Some phrase ->
|
2012-10-15 09:45:44 +00:00
|
|
|
(* Rewrite toplevel expressions. *)
|
2017-04-12 23:56:26 +00:00
|
|
|
let count = S.value UTop_private.count in
|
2017-04-18 19:42:13 +00:00
|
|
|
let phrase = rewrite phrase in
|
|
|
|
let phrase =
|
|
|
|
if UTop.get_create_implicits () then
|
|
|
|
let binding_name = Printf.sprintf "_%d" count in
|
|
|
|
bind_expressions binding_name phrase
|
|
|
|
else
|
|
|
|
phrase
|
|
|
|
in
|
2012-02-11 09:21:07 +00:00
|
|
|
(* Set the margin of standard formatters. *)
|
2015-08-04 10:44:36 +00:00
|
|
|
UTop_private.set_margin Format.std_formatter;
|
|
|
|
UTop_private.set_margin Format.err_formatter;
|
2012-02-22 16:21:47 +00:00
|
|
|
(* Formatter to get the output phrase. *)
|
|
|
|
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-17 10:51:27 +00:00
|
|
|
(try
|
2013-05-21 09:26:59 +00:00
|
|
|
Env.reset_cache_toplevel ();
|
2014-05-02 15:43:30 +00:00
|
|
|
if !Clflags.dump_parsetree then Printast.top_phrase pp phrase;
|
|
|
|
if !Clflags.dump_source then Pprintast.top_phrase pp phrase;
|
2019-01-15 18:49:54 +00:00
|
|
|
ignore (execute_phrase true pp phrase);
|
2012-02-22 16:21:47 +00:00
|
|
|
(* Flush everything. *)
|
|
|
|
Format.pp_print_flush Format.std_formatter ();
|
|
|
|
Format.pp_print_flush Format.err_formatter ();
|
|
|
|
flush stdout;
|
|
|
|
flush stderr;
|
|
|
|
(* Get the string printed. *)
|
|
|
|
Format.pp_print_flush pp ();
|
|
|
|
let string = Buffer.contents buffer in
|
2017-04-10 21:49:05 +00:00
|
|
|
UTop_history.add_output UTop.stashable_session_history string;
|
2012-02-22 16:21:47 +00:00
|
|
|
match phrase with
|
|
|
|
| Parsetree.Ptop_def _ ->
|
|
|
|
(* The string is an output phrase, colorize it. *)
|
2013-07-08 12:15:52 +00:00
|
|
|
Lwt_main.run (render_out_phrase term string)
|
2012-02-22 16:21:47 +00:00
|
|
|
| Parsetree.Ptop_dir _ ->
|
|
|
|
(* The string is an error message. *)
|
|
|
|
Lwt_main.run (print_error term string)
|
2012-02-17 10:51:27 +00:00
|
|
|
with exn ->
|
|
|
|
(* The only possible errors are directive errors. *)
|
|
|
|
let msg = UTop.get_message Errors.report_error exn in
|
|
|
|
(* Skip the dumb location. *)
|
|
|
|
let msg =
|
|
|
|
try
|
|
|
|
let idx = String.index msg '\n' + 1 in
|
|
|
|
String.sub msg idx (String.length msg - idx)
|
|
|
|
with Not_found ->
|
|
|
|
msg
|
|
|
|
in
|
2012-02-22 16:21:47 +00:00
|
|
|
Lwt_main.run (print_error term msg));
|
2012-02-11 09:21:07 +00:00
|
|
|
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. *)
|
2014-10-18 16:35:39 +00:00
|
|
|
LTerm.print_box term matrix >>= fun () ->
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
(* Move to after the box. *)
|
2014-10-18 16:35:39 +00:00
|
|
|
LTerm.fprint term "\n" >>= fun () ->
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
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 ->
|
2014-05-02 09:58:05 +00:00
|
|
|
Bytes.set buffer i c;
|
2012-02-11 09:21:07 +00:00
|
|
|
if c = '\n' then
|
|
|
|
return (i + 1, false)
|
|
|
|
else
|
|
|
|
loop (i + 1)
|
|
|
|
| None ->
|
|
|
|
return (i, true)
|
|
|
|
in
|
2014-10-18 16:35:39 +00:00
|
|
|
Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >>= fun () -> loop 0)
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| 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)
|
|
|
|
|
2012-02-12 20:40:29 +00:00
|
|
|
let split_at ?(trim=false) ch str =
|
2018-08-23 16:53:07 +00:00
|
|
|
let rec aux acc i j =
|
2012-02-11 09:21:07 +00:00
|
|
|
if j = String.length str then
|
2012-02-12 20:40:29 +00:00
|
|
|
if trim && i = j then
|
2018-08-23 16:53:07 +00:00
|
|
|
acc
|
2012-02-12 20:40:29 +00:00
|
|
|
else
|
2018-08-23 16:53:07 +00:00
|
|
|
(String.sub str i (j - i)) :: acc
|
2012-02-12 20:40:29 +00:00
|
|
|
else if str.[j] = ch then
|
2018-08-23 16:53:07 +00:00
|
|
|
aux (String.sub str i (j - i) :: acc) (j + 1) (j + 1)
|
2012-02-11 09:21:07 +00:00
|
|
|
else
|
2018-08-23 16:53:07 +00:00
|
|
|
aux acc i (j + 1)
|
2012-02-11 09:21:07 +00:00
|
|
|
in
|
2018-08-23 16:53:07 +00:00
|
|
|
List.rev (aux [] 0 0)
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
(* +---------------------------------------------------------------+
|
|
|
|
| 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)))
|
|
|
|
|
2012-02-12 20:40:29 +00:00
|
|
|
let read_data () =
|
2012-02-11 09:21:07 +00:00
|
|
|
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", _) ->
|
|
|
|
Buffer.contents buf
|
|
|
|
| Some (command, argument) ->
|
|
|
|
Printf.ksprintf (send "stderr") "'data' or 'end' command expected, got %S!" command;
|
|
|
|
exit 1
|
|
|
|
in
|
|
|
|
loop true
|
|
|
|
|
2013-04-14 11:32:04 +00:00
|
|
|
let process_checked_phrase phrase =
|
2013-04-03 19:18:36 +00:00
|
|
|
(* Rewrite toplevel expressions. *)
|
|
|
|
let phrase = rewrite phrase in
|
|
|
|
try
|
2013-05-21 09:26:59 +00:00
|
|
|
Env.reset_cache_toplevel ();
|
2019-01-15 18:49:54 +00:00
|
|
|
ignore (execute_phrase true Format.std_formatter phrase);
|
2013-04-03 19:18:36 +00:00
|
|
|
true
|
|
|
|
with exn ->
|
|
|
|
(* The only possible errors are directive errors. *)
|
|
|
|
let msg = UTop.get_message Errors.report_error exn in
|
|
|
|
(* Skip the dumb location. *)
|
|
|
|
let msg =
|
|
|
|
try
|
|
|
|
let idx = String.index msg '\n' + 1 in
|
|
|
|
String.sub msg idx (String.length msg - idx)
|
|
|
|
with Not_found ->
|
|
|
|
msg
|
|
|
|
in
|
|
|
|
List.iter (send "stderr") (split_at ~trim:true '\n' msg);
|
|
|
|
false
|
|
|
|
|
2012-02-12 20:40:29 +00:00
|
|
|
let process_input add_to_history eos_is_error =
|
|
|
|
let input = read_data () in
|
2019-04-01 16:51:01 +00:00
|
|
|
let input_zed= Zed_string.unsafe_of_utf8 input in
|
2013-04-03 19:18:36 +00:00
|
|
|
let result, warnings = parse_and_check input eos_is_error in
|
2012-02-23 14:07:00 +00:00
|
|
|
match result with
|
2013-04-03 19:18:36 +00:00
|
|
|
| UTop.Value phrase ->
|
2012-02-11 09:21:07 +00:00
|
|
|
send "accept" "";
|
2012-02-23 14:07:00 +00:00
|
|
|
List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
|
2019-04-01 16:51:01 +00:00
|
|
|
if add_to_history then LTerm_history.add UTop.history input_zed;
|
2013-04-03 19:18:36 +00:00
|
|
|
ignore (process_checked_phrase phrase)
|
2012-02-11 09:21:07 +00:00
|
|
|
| UTop.Error (locs, msg) ->
|
|
|
|
send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs));
|
2012-02-23 14:07:00 +00:00
|
|
|
List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
|
2019-04-01 16:51:01 +00:00
|
|
|
if add_to_history then LTerm_history.add UTop.history input_zed;
|
2012-02-12 20:40:29 +00:00
|
|
|
List.iter (send "stderr") (split_at ~trim:true '\n' msg)
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2013-04-03 19:18:36 +00:00
|
|
|
let send_error locs msg warnings =
|
|
|
|
send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs));
|
|
|
|
match warnings with
|
|
|
|
| Some warnings -> List.iter (send "stderr") (split_at ~trim:true '\n' warnings)
|
|
|
|
| None -> ();
|
|
|
|
List.iter (send "stderr") (split_at ~trim:true '\n' msg)
|
|
|
|
|
|
|
|
let process_input_multi () =
|
|
|
|
let input = read_data () in
|
|
|
|
let result, warnings = parse_input_multi input in
|
2013-04-14 11:32:04 +00:00
|
|
|
let typecheck phrase =
|
2013-04-26 08:53:59 +00:00
|
|
|
match UTop.check_phrase phrase with
|
2013-04-03 19:18:36 +00:00
|
|
|
| None -> None
|
2020-01-05 21:21:53 +00:00
|
|
|
| Some (locs, msg, lines) -> Some (convert_loc_line input locs lines, msg)
|
2013-04-03 19:18:36 +00:00
|
|
|
in
|
|
|
|
match result with
|
|
|
|
| UTop.Value phrases ->
|
|
|
|
send "accept" "";
|
|
|
|
List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
|
|
|
|
let rec loop = function
|
|
|
|
| (phrase::more_phrases) -> begin
|
|
|
|
match typecheck phrase with
|
|
|
|
| Some (locs, msg) ->
|
|
|
|
send_error locs msg None
|
|
|
|
| None ->
|
|
|
|
let success = process_checked_phrase phrase in
|
|
|
|
if success then
|
2013-04-03 20:02:56 +00:00
|
|
|
loop more_phrases
|
2013-04-03 19:18:36 +00:00
|
|
|
else
|
|
|
|
()
|
|
|
|
end
|
|
|
|
| [] ->
|
|
|
|
()
|
|
|
|
in
|
|
|
|
loop phrases
|
|
|
|
| UTop.Error (locs, msg) ->
|
|
|
|
send_error locs msg (Some warnings)
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
let rec loop () =
|
|
|
|
(* Reset completion. *)
|
|
|
|
UTop_complete.reset ();
|
|
|
|
|
|
|
|
(* Increment the command counter. *)
|
|
|
|
UTop_private.set_count (S.value UTop_private.count + 1);
|
|
|
|
|
|
|
|
(* Call hooks. *)
|
2018-07-14 07:45:19 +00:00
|
|
|
LTerm_dlist.iter_l (fun f -> f ()) UTop.new_command_hooks;
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
(* Tell emacs we are ready. *)
|
|
|
|
send "prompt" "";
|
|
|
|
|
2012-02-12 20:40:29 +00:00
|
|
|
loop_commands (LTerm_history.contents UTop.history) []
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2012-02-12 20:40:29 +00:00
|
|
|
and loop_commands history_prev history_next =
|
2012-02-11 09:21:07 +00:00
|
|
|
match read_command () with
|
|
|
|
| None ->
|
|
|
|
()
|
2012-02-12 20:40:29 +00:00
|
|
|
| Some ("input", arg) ->
|
|
|
|
let args = split_at ',' arg in
|
|
|
|
let allow_incomplete = List.mem "allow-incomplete" args
|
|
|
|
and add_to_history = List.mem "add-to-history" args in
|
2012-02-11 09:21:07 +00:00
|
|
|
let continue =
|
|
|
|
try
|
2012-02-12 20:40:29 +00:00
|
|
|
process_input add_to_history (not allow_incomplete);
|
2012-02-11 09:21:07 +00:00
|
|
|
false
|
|
|
|
with UTop.Need_more ->
|
|
|
|
send "continue" "";
|
|
|
|
true
|
|
|
|
in
|
|
|
|
if continue then
|
2012-02-12 20:40:29 +00:00
|
|
|
loop_commands history_prev history_next
|
2012-02-11 09:21:07 +00:00
|
|
|
else
|
|
|
|
loop ()
|
2013-04-03 20:02:56 +00:00
|
|
|
| Some ("input-multi", _) ->
|
2013-04-03 19:18:36 +00:00
|
|
|
let continue =
|
|
|
|
try
|
|
|
|
process_input_multi ();
|
|
|
|
false
|
|
|
|
with UTop.Need_more ->
|
|
|
|
send "continue" "";
|
|
|
|
true
|
|
|
|
in
|
|
|
|
if continue then
|
|
|
|
loop_commands history_prev history_next
|
|
|
|
else
|
|
|
|
loop ()
|
2017-08-18 20:39:33 +00:00
|
|
|
| Some ("complete-company", _) ->
|
|
|
|
let input = read_data () in
|
|
|
|
let _, words =
|
|
|
|
UTop_complete.complete
|
|
|
|
~phrase_terminator:(UTop.get_phrase_terminator ())
|
|
|
|
~input
|
|
|
|
in
|
|
|
|
send "completion-start" "";
|
|
|
|
List.iter (fun (w, _) -> send "completion" w) words;
|
|
|
|
send "completion-stop" "";
|
|
|
|
loop_commands history_prev history_next
|
2012-02-11 09:21:07 +00:00
|
|
|
| Some ("complete", _) ->
|
2012-02-12 20:40:29 +00:00
|
|
|
let input = read_data () in
|
2012-02-22 15:59:31 +00:00
|
|
|
let start, words =
|
|
|
|
UTop_complete.complete
|
|
|
|
~phrase_terminator:(UTop.get_phrase_terminator ())
|
|
|
|
~input
|
|
|
|
in
|
2012-02-11 09:21:07 +00:00
|
|
|
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" "";
|
2012-02-12 20:40:29 +00:00
|
|
|
List.iter (send "completion") words;
|
2012-02-11 09:21:07 +00:00
|
|
|
send "completion-stop" "";
|
|
|
|
end else
|
|
|
|
send "completion-word" suffix;
|
2012-02-12 20:40:29 +00:00
|
|
|
loop_commands history_prev history_next
|
|
|
|
| Some ("history-prev", _) -> begin
|
|
|
|
let input = read_data () in
|
|
|
|
match history_prev with
|
|
|
|
| [] ->
|
|
|
|
send "history-bound" "";
|
|
|
|
loop_commands history_prev history_next
|
|
|
|
| entry :: history_prev ->
|
2019-04-01 16:51:01 +00:00
|
|
|
List.iter (send "history-data") (split_at '\n' (Zed_string.to_utf8 entry));
|
2012-02-12 20:40:29 +00:00
|
|
|
send "history-end" "";
|
|
|
|
loop_commands history_prev (input :: history_next)
|
|
|
|
end
|
|
|
|
| Some ("history-next", _) -> begin
|
|
|
|
let input = read_data () in
|
|
|
|
match history_next with
|
|
|
|
| [] ->
|
|
|
|
send "history-bound" "";
|
|
|
|
loop_commands history_prev history_next
|
|
|
|
| entry :: history_next ->
|
|
|
|
List.iter (send "history-data") (split_at '\n' entry);
|
|
|
|
send "history-end" "";
|
2019-04-01 16:51:01 +00:00
|
|
|
loop_commands ((Zed_string.unsafe_of_utf8 input) :: history_prev) history_next
|
2012-02-12 20:40:29 +00:00
|
|
|
end
|
2012-02-13 09:21:10 +00:00
|
|
|
| Some ("exit", code) ->
|
|
|
|
exit (int_of_string code)
|
2012-02-13 14:57:25 +00:00
|
|
|
| Some ("save-history", code) ->
|
|
|
|
Lwt_main.run (save_history ());
|
|
|
|
loop_commands history_prev history_next
|
2012-03-03 17:54:48 +00:00
|
|
|
| Some ("require", package) -> begin
|
|
|
|
try
|
|
|
|
Topfind.load_deeply [package]
|
|
|
|
with Fl_package_base.No_such_package(pkg, reason) ->
|
|
|
|
send "no-such-package" pkg
|
|
|
|
end;
|
2012-03-01 03:56:06 +00:00
|
|
|
loop_commands history_prev history_next
|
2012-02-11 09:21:07 +00:00
|
|
|
| Some (command, _) ->
|
|
|
|
Printf.ksprintf (send "stderr") "unrecognized command %S!" command;
|
|
|
|
exit 1
|
|
|
|
end
|
|
|
|
|
2013-07-08 12:15:52 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Extra macros |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2013-10-16 08:18:44 +00:00
|
|
|
let typeof sid =
|
2020-05-08 06:54:32 +00:00
|
|
|
let id = longident_parse sid in
|
2013-07-08 12:15:52 +00:00
|
|
|
let env = !Toploop.toplevel_env in
|
2019-12-12 02:15:29 +00:00
|
|
|
#if OCAML_VERSION >= (4, 10, 0)
|
|
|
|
let lookup_value= Env.find_value_by_name
|
|
|
|
and lookup_label= Env.find_label_by_name
|
|
|
|
and lookup_modtype= Env.find_modtype_by_name
|
|
|
|
and lookup_module id env =
|
|
|
|
let path, decl = Env.find_module_by_name id env in
|
|
|
|
(path, decl.md_type)
|
|
|
|
#else
|
|
|
|
let lookup_value= Env.lookup_value
|
|
|
|
and lookup_label= Env.lookup_label
|
|
|
|
and lookup_modtype= Env.lookup_modtype
|
|
|
|
and lookup_module id env =
|
|
|
|
let path = Env.lookup_module id env ~load:true in
|
|
|
|
(path, (Env.find_module path env).md_type)
|
|
|
|
#endif
|
|
|
|
in
|
2013-10-16 08:18:44 +00:00
|
|
|
let from_type_desc = function
|
|
|
|
| Types.Tconstr (path, _, _) ->
|
|
|
|
let typ_decl = Env.find_type path env in
|
|
|
|
path, typ_decl
|
|
|
|
| _ -> assert false
|
|
|
|
in
|
|
|
|
let out_sig_item =
|
|
|
|
try
|
2016-08-15 08:32:20 +00:00
|
|
|
let (path, ty_decl) = lookup_type id env in
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
let id = Ident.create_local (Path.name path) in
|
|
|
|
#else
|
2013-10-16 08:18:44 +00:00
|
|
|
let id = Ident.create (Path.name path) in
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2013-10-16 08:18:44 +00:00
|
|
|
Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not)
|
|
|
|
with Not_found ->
|
|
|
|
try
|
2019-12-12 02:15:29 +00:00
|
|
|
let (path, val_descr) = lookup_value id env in
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
let id = Ident.create_local (Path.name path) in
|
|
|
|
#else
|
2013-10-16 08:18:44 +00:00
|
|
|
let id = Ident.create (Path.name path) in
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2013-10-16 08:18:44 +00:00
|
|
|
Some (Printtyp.tree_of_value_description id val_descr)
|
|
|
|
with Not_found ->
|
|
|
|
try
|
2019-12-12 02:15:29 +00:00
|
|
|
let lbl_desc = lookup_label id env in
|
2013-10-25 09:52:32 +00:00
|
|
|
let (path, ty_decl) = from_type_desc lbl_desc.Types.lbl_res.Types.desc in
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
let id = Ident.create_local (Path.name path) in
|
|
|
|
#else
|
2013-10-16 08:18:44 +00:00
|
|
|
let id = Ident.create (Path.name path) in
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2013-10-16 08:18:44 +00:00
|
|
|
Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not)
|
|
|
|
with Not_found ->
|
|
|
|
try
|
2019-12-12 02:15:29 +00:00
|
|
|
let path, mod_typ = lookup_module id env in
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
let id = Ident.create_local (Path.name path) in
|
|
|
|
#else
|
2013-10-16 08:18:44 +00:00
|
|
|
let id = Ident.create (Path.name path) in
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2013-10-16 08:18:44 +00:00
|
|
|
Some (Printtyp.tree_of_module id mod_typ Types.Trec_not)
|
|
|
|
with Not_found ->
|
|
|
|
try
|
2019-12-12 02:15:29 +00:00
|
|
|
let (path, mty_decl) = lookup_modtype id env in
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
let id = Ident.create_local (Path.name path) in
|
|
|
|
#else
|
2013-10-16 08:18:44 +00:00
|
|
|
let id = Ident.create (Path.name path) in
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2013-10-16 08:18:44 +00:00
|
|
|
Some (Printtyp.tree_of_modtype_declaration id mty_decl)
|
|
|
|
with Not_found ->
|
|
|
|
try
|
2019-12-12 02:15:29 +00:00
|
|
|
#if OCAML_VERSION >= (4, 10, 0)
|
|
|
|
let cstr_desc = Env.find_constructor_by_name id env in
|
|
|
|
#else
|
2013-10-16 08:18:44 +00:00
|
|
|
let cstr_desc = Env.lookup_constructor id env in
|
2019-12-12 02:15:29 +00:00
|
|
|
#endif
|
2013-10-16 08:18:44 +00:00
|
|
|
match cstr_desc.Types.cstr_tag with
|
|
|
|
| _ ->
|
2013-10-25 09:52:32 +00:00
|
|
|
let (path, ty_decl) = from_type_desc cstr_desc.Types.cstr_res.Types.desc in
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
let id = Ident.create_local (Path.name path) in
|
|
|
|
#else
|
2013-10-16 08:18:44 +00:00
|
|
|
let id = Ident.create (Path.name path) in
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2013-10-16 08:18:44 +00:00
|
|
|
Some (Printtyp.tree_of_type_declaration id ty_decl Types.Trec_not)
|
|
|
|
with Not_found ->
|
|
|
|
None
|
|
|
|
in
|
|
|
|
match out_sig_item with
|
|
|
|
| None ->
|
|
|
|
Lwt_main.run (Lazy.force LTerm.stdout >>= fun term ->
|
|
|
|
print_error term "Unknown type\n")
|
|
|
|
| Some osig ->
|
2013-07-08 12:15:52 +00:00
|
|
|
let buf = Buffer.create 128 in
|
|
|
|
let pp = Format.formatter_of_buffer buf in
|
|
|
|
!Toploop.print_out_signature pp [osig];
|
|
|
|
Format.pp_print_newline pp ();
|
|
|
|
let str = Buffer.contents buf in
|
|
|
|
Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> render_out_phrase term str)
|
2013-10-16 08:18:44 +00:00
|
|
|
|
2021-05-25 19:54:51 +00:00
|
|
|
let default_info = {
|
|
|
|
Toploop.section = "UTop";
|
|
|
|
doc = ""; (* TODO: have some kind of documentation *)
|
|
|
|
}
|
|
|
|
|
2013-07-08 12:15:52 +00:00
|
|
|
let () =
|
2021-05-25 19:54:51 +00:00
|
|
|
Toploop.add_directive "typeof"
|
2013-10-16 08:18:44 +00:00
|
|
|
(Toploop.Directive_string typeof)
|
2021-05-25 19:54:51 +00:00
|
|
|
default_info
|
2013-07-08 12:15:52 +00:00
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Entry point |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
|
|
|
let emacs_mode = ref false
|
2014-04-11 15:06:09 +00:00
|
|
|
let preload = ref []
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
let prepare () =
|
|
|
|
Toploop.set_paths ();
|
|
|
|
try
|
2014-04-11 15:06:09 +00:00
|
|
|
let ok =
|
|
|
|
List.for_all
|
|
|
|
(function
|
|
|
|
| `Packages l -> UTop.require l; true
|
2021-05-25 19:54:51 +00:00
|
|
|
| `Object fn ->
|
|
|
|
#if OCAML_VERSION >= (4, 13, 0)
|
|
|
|
Toploop.load_file Format.err_formatter fn)
|
|
|
|
#else
|
|
|
|
Topdirs.load_file Format.err_formatter fn)
|
|
|
|
#endif
|
2014-04-11 15:06:09 +00:00
|
|
|
(List.rev !preload)
|
|
|
|
in
|
|
|
|
if ok then !Toploop.toplevel_startup_hook ();
|
|
|
|
ok
|
2012-02-11 09:21:07 +00:00
|
|
|
with exn ->
|
|
|
|
try
|
|
|
|
Errors.report_error Format.err_formatter exn;
|
|
|
|
false
|
|
|
|
with exn ->
|
|
|
|
Format.eprintf "Uncaught exception: %s\n" (Printexc.to_string exn);
|
|
|
|
false
|
|
|
|
|
2019-09-16 12:28:38 +00:00
|
|
|
#if OCAML_VERSION >= (4, 09, 0)
|
|
|
|
external caml_sys_modify_argv : string array -> unit =
|
|
|
|
"caml_sys_modify_argv"
|
|
|
|
let override_argv () =
|
|
|
|
let len = Array.length Sys.argv - !Arg.current in
|
|
|
|
let copy = Array.init len (fun i -> Sys.argv.(i+ !Arg.current)) in
|
|
|
|
caml_sys_modify_argv copy;
|
|
|
|
Arg.current := 0
|
|
|
|
#else
|
|
|
|
let override_argv () =
|
|
|
|
let len = Array.length Sys.argv - !Arg.current in
|
|
|
|
Array.blit Sys.argv !Arg.current Sys.argv 0 len;
|
|
|
|
Obj.truncate (Obj.repr Sys.argv) len;
|
|
|
|
Arg.current := 0
|
|
|
|
#endif
|
|
|
|
|
|
|
|
|
2014-04-11 15:06:09 +00:00
|
|
|
let run_script name =
|
|
|
|
(* To prevent message from camlp4 *)
|
|
|
|
Sys.interactive := false;
|
|
|
|
if not (prepare ()) then exit 2;
|
2019-09-16 12:28:38 +00:00
|
|
|
override_argv ();
|
2014-04-11 15:06:09 +00:00
|
|
|
Toploop.initialize_toplevel_env ();
|
|
|
|
Location.input_name := UTop.input_name;
|
|
|
|
if Toploop.use_silently Format.err_formatter name then
|
2012-02-11 09:21:07 +00:00
|
|
|
exit 0
|
|
|
|
else
|
|
|
|
exit 2
|
|
|
|
|
|
|
|
let file_argument name =
|
|
|
|
if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma" then
|
2014-04-11 15:06:09 +00:00
|
|
|
preload := `Object name :: !preload
|
|
|
|
else
|
|
|
|
run_script name
|
2012-02-11 09:21:07 +00:00
|
|
|
|
|
|
|
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 () =
|
2018-02-26 12:34:37 +00:00
|
|
|
Printf.printf "%s\n" UTop.version;
|
|
|
|
exit 0
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2013-11-26 13:48:34 +00:00
|
|
|
(* Config from command line *)
|
|
|
|
let autoload = ref true
|
|
|
|
|
2012-02-11 09:21:07 +00:00
|
|
|
let args = Arg.align [
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
"-absname", Arg.Set Clflags.absname, " Show absolute filenames in error message";
|
|
|
|
#else
|
2012-02-11 09:21:07 +00:00
|
|
|
"-absname", Arg.Set Location.absname, " Show absolute filenames in error message";
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2018-07-09 09:28:08 +00:00
|
|
|
"-I", Arg.String (fun dir -> Clflags.include_dirs := dir :: !Clflags.include_dirs), "<dir> Add <dir> to the list of include directories";
|
2012-02-11 09:21:07 +00:00
|
|
|
"-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";
|
2014-05-02 15:38:57 +00:00
|
|
|
"-ppx", Arg.String (fun ppx -> Clflags.all_ppx := ppx :: !Clflags.all_ppx), "<command> Pipe abstract syntax trees through preprocessor <command>";
|
2012-02-11 09:21:07 +00:00
|
|
|
"-principal", Arg.Set Clflags.principal, " Check principality of type inference";
|
2014-09-08 19:25:21 +00:00
|
|
|
"-safe-string", Arg.Clear Clflags.unsafe_string, " Make strings immutable";
|
2013-01-29 20:02:52 +00:00
|
|
|
"-short-paths", Arg.Clear Clflags.real_paths, " Shorten paths in types (the default)";
|
|
|
|
"-no-short-paths", Arg.Set Clflags.real_paths, " Do not shorten paths in types";
|
2012-02-11 09:21:07 +00:00
|
|
|
"-rectypes", Arg.Set Clflags.recursive_types, " Allow arbitrary recursive types";
|
2014-04-11 15:06:09 +00:00
|
|
|
"-stdin", Arg.Unit (fun () -> run_script ""), " Read script from standard input";
|
2012-02-11 09:21:07 +00:00
|
|
|
"-strict-sequence", Arg.Set Clflags.strict_sequence, " Left-hand part of a sequence must have type unit";
|
2019-05-23 05:42:47 +00:00
|
|
|
#if OCAML_VERSION >= (4, 08, 0)
|
|
|
|
"-unsafe", Arg.Set Clflags.unsafe, " Do not compile bounds checking on array and string access";
|
|
|
|
#else
|
2012-02-11 09:21:07 +00:00
|
|
|
"-unsafe", Arg.Set Clflags.fast, " Do not compile bounds checking on array and string access";
|
2019-05-23 05:42:47 +00:00
|
|
|
#endif
|
2012-02-11 09:21:07 +00:00
|
|
|
"-version", Arg.Unit print_version, " Print version and exit";
|
|
|
|
"-vnum", Arg.Unit print_version_num, " Print version number and exit";
|
2021-03-09 10:52:53 +00:00
|
|
|
"-w", Arg.String (fun opt -> ignore (Warnings.parse_options false opt)),
|
2012-02-11 09:21:07 +00:00
|
|
|
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;
|
2021-03-09 10:52:53 +00:00
|
|
|
"-warn-error", Arg.String (fun opt -> ignore (Warnings.parse_options true opt)),
|
2012-02-11 09:21:07 +00:00
|
|
|
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";
|
2013-02-06 22:27:09 +00:00
|
|
|
"-hide-reserved", Arg.Unit (fun () -> UTop.set_hide_reserved true),
|
|
|
|
" Hide identifiers starting with a '_' (the default)";
|
|
|
|
"-show-reserved", Arg.Unit (fun () -> UTop.set_hide_reserved false),
|
|
|
|
" Show identifiers starting with a '_'";
|
2017-04-18 19:42:13 +00:00
|
|
|
"-no-implicit-bindings", Arg.Unit (fun () -> UTop.set_create_implicits false),
|
|
|
|
" Don't add implicit bindings for expressions (the default)";
|
|
|
|
"-implicit-bindings", Arg.Unit (fun () -> UTop.set_create_implicits true),
|
|
|
|
" Add implicit bindings: <expr>;; -> let _0 = <expr>;;";
|
2013-11-26 13:48:34 +00:00
|
|
|
"-no-autoload", Arg.Clear autoload,
|
|
|
|
" Disable autoloading of files in $OCAML_TOPLEVEL_PATH/autoload";
|
2014-04-11 15:06:09 +00:00
|
|
|
"-require", Arg.String (fun s -> preload := `Packages (UTop.split_words s) :: !preload),
|
2013-12-10 15:19:10 +00:00
|
|
|
"<package> Load this package";
|
2014-05-02 15:43:30 +00:00
|
|
|
"-dparsetree", Arg.Set Clflags.dump_parsetree, " Dump OCaml AST after rewriting";
|
|
|
|
"-dsource", Arg.Set Clflags.dump_source, " Dump OCaml source after rewriting";
|
2012-02-11 09:21:07 +00:00
|
|
|
]
|
|
|
|
|
2013-01-29 20:02:52 +00:00
|
|
|
let () = Clflags.real_paths := false
|
|
|
|
|
2012-02-12 19:04:32 +00:00
|
|
|
let app_name = Filename.basename Sys.executable_name
|
|
|
|
let usage = Printf.sprintf "Usage: %s <options> <object-files> [script-file [arguments]]\noptions are:" app_name
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2013-11-04 12:58:15 +00:00
|
|
|
let load_init_files dir =
|
|
|
|
let files = Sys.readdir dir in
|
|
|
|
Array.sort String.compare files;
|
|
|
|
Array.iter
|
|
|
|
(fun fn ->
|
|
|
|
if Filename.check_suffix fn ".ml" then
|
2013-11-26 13:22:36 +00:00
|
|
|
ignore (Toploop.use_silently Format.err_formatter (Filename.concat dir fn) : bool))
|
2013-11-04 12:58:15 +00:00
|
|
|
files
|
|
|
|
;;
|
|
|
|
|
2016-02-23 11:06:52 +00:00
|
|
|
let common_init ~initial_env =
|
2012-02-11 09:21:07 +00:00
|
|
|
(* Initializes toplevel environment. *)
|
2016-02-23 11:06:52 +00:00
|
|
|
(match initial_env with
|
|
|
|
| None -> Toploop.initialize_toplevel_env ()
|
|
|
|
| Some env -> Toploop.toplevel_env := env);
|
2012-02-11 09:21:07 +00:00
|
|
|
(* Set the global input name. *)
|
|
|
|
Location.input_name := UTop.input_name;
|
|
|
|
(* Make sure SIGINT is catched while executing OCaml code. *)
|
|
|
|
Sys.catch_break true;
|
2013-11-04 12:58:15 +00:00
|
|
|
(* Load system init files. *)
|
|
|
|
(match try Some (Sys.getenv "OCAML_TOPLEVEL_PATH") with Not_found -> None with
|
|
|
|
| Some dir ->
|
|
|
|
Topdirs.dir_directory dir;
|
2013-11-26 13:48:34 +00:00
|
|
|
let autoload_dir = Filename.concat dir "autoload" in
|
|
|
|
if !autoload && !UTop_private.autoload && Sys.file_exists autoload_dir then
|
|
|
|
load_init_files autoload_dir
|
2013-11-04 12:58:15 +00:00
|
|
|
| None -> ());
|
2020-02-22 20:38:28 +00:00
|
|
|
(* Load user's init file. *)
|
|
|
|
let init_fn =
|
|
|
|
match !Clflags.init_file with
|
2012-02-12 20:40:29 +00:00
|
|
|
| Some fn ->
|
|
|
|
if Sys.file_exists fn then
|
2020-02-22 20:38:28 +00:00
|
|
|
Some fn
|
|
|
|
else (
|
|
|
|
Printf.eprintf "Init file not found: \"%s\".\n" fn;
|
|
|
|
None
|
|
|
|
)
|
2012-02-12 20:40:29 +00:00
|
|
|
| None ->
|
2021-03-31 07:47:39 +00:00
|
|
|
if Sys.file_exists ".ocamlinit" && Sys.getcwd () <> LTerm_resources.home then
|
2020-02-22 20:38:28 +00:00
|
|
|
Some ".ocamlinit"
|
2012-02-12 20:40:29 +00:00
|
|
|
else
|
2020-02-22 20:38:28 +00:00
|
|
|
let xdg_fn = LTerm_resources.xdgbd_file ~loc:LTerm_resources.Config "utop/init.ml" in
|
|
|
|
if Sys.file_exists xdg_fn then
|
|
|
|
Some xdg_fn
|
|
|
|
else
|
|
|
|
let fn = Filename.concat LTerm_resources.home ".ocamlinit" in
|
|
|
|
if Sys.file_exists fn then
|
|
|
|
Some fn
|
|
|
|
else
|
|
|
|
None
|
|
|
|
in
|
|
|
|
(match init_fn with
|
|
|
|
| None -> ()
|
|
|
|
| Some fn ->
|
|
|
|
ignore (Toploop.use_silently Format.err_formatter fn : bool));
|
2012-02-12 20:40:29 +00:00
|
|
|
(* Load history after the initialization file so the user can change
|
|
|
|
the history file name. *)
|
2012-02-15 15:49:29 +00:00
|
|
|
Lwt_main.run (init_history ());
|
|
|
|
(* Install signal handlers. *)
|
|
|
|
let behavior = Sys.Signal_handle (fun signo -> raise (Term signo)) in
|
|
|
|
let catch signo =
|
|
|
|
try
|
|
|
|
Sys.set_signal signo behavior
|
|
|
|
with _ ->
|
|
|
|
(* All signals may not be supported on some OS. *)
|
|
|
|
()
|
|
|
|
in
|
|
|
|
(* We lost the terminal. *)
|
|
|
|
catch Sys.sighup;
|
|
|
|
(* Termination request. *)
|
|
|
|
catch Sys.sigterm
|
2012-02-11 09:21:07 +00:00
|
|
|
|
2012-02-12 19:04:32 +00:00
|
|
|
let load_inputrc () =
|
2014-10-18 16:35:39 +00:00
|
|
|
Lwt.catch
|
|
|
|
LTerm_inputrc.load
|
|
|
|
(function
|
|
|
|
| Unix.Unix_error (error, func, arg) ->
|
|
|
|
Lwt_log.error_f "cannot load key bindings from %S: %s: %s" LTerm_inputrc.default func (Unix.error_message error)
|
|
|
|
| LTerm_inputrc.Parse_error (fname, line, msg) ->
|
|
|
|
Lwt_log.error_f "error in key bindings file %S, line %d: %s" fname line msg
|
|
|
|
| exn -> Lwt.fail exn)
|
2012-02-12 19:04:32 +00:00
|
|
|
|
2018-02-28 09:26:19 +00:00
|
|
|
let protocol_version = 1
|
|
|
|
|
2016-02-23 11:06:52 +00:00
|
|
|
let main_aux ~initial_env =
|
2012-02-11 09:21:07 +00:00
|
|
|
Arg.parse args file_argument usage;
|
|
|
|
if not (prepare ()) then exit 2;
|
|
|
|
if !emacs_mode then begin
|
2018-02-28 09:26:19 +00:00
|
|
|
Printf.printf "protocol-version:%d\n%!" protocol_version;
|
2012-02-11 09:21:07 +00:00
|
|
|
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;
|
2016-02-23 11:06:52 +00:00
|
|
|
common_init ~initial_env;
|
2012-02-11 09:21:07 +00:00
|
|
|
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));
|
|
|
|
(* Load user data. *)
|
2014-10-18 16:35:39 +00:00
|
|
|
Lwt_main.run (Lwt.join [UTop_styles.load (); load_inputrc ()]);
|
2012-02-11 09:21:07 +00:00
|
|
|
(* Display a welcome message. *)
|
|
|
|
Lwt_main.run (welcome term);
|
|
|
|
(* Common initialization. *)
|
2016-02-23 11:06:52 +00:00
|
|
|
common_init ~initial_env;
|
2012-02-11 09:21:07 +00:00
|
|
|
(* 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
|
2012-02-12 19:04:32 +00:00
|
|
|
|
2016-02-23 11:06:52 +00:00
|
|
|
let main_internal ~initial_env =
|
2021-03-30 12:18:31 +00:00
|
|
|
let exit_status = ref 2 in
|
2012-02-12 19:04:32 +00:00
|
|
|
try
|
2016-02-23 11:06:52 +00:00
|
|
|
main_aux ~initial_env
|
2012-02-12 19:04:32 +00:00
|
|
|
with exn ->
|
|
|
|
(match exn with
|
|
|
|
| Unix.Unix_error (error, func, "") ->
|
|
|
|
Printf.eprintf "%s: %s: %s\n" app_name func (Unix.error_message error)
|
|
|
|
| Unix.Unix_error (error, func, arg) ->
|
2021-03-30 12:18:31 +00:00
|
|
|
Printf.eprintf "%s: %s(%S): %s\n" app_name func arg (Unix.error_message error)
|
|
|
|
#if OCAML_VERSION >= (4,12,0)
|
|
|
|
| Compenv.Exit_with_status e -> exit_status := e
|
|
|
|
#endif
|
2012-02-12 19:04:32 +00:00
|
|
|
| exn ->
|
|
|
|
Printf.eprintf "Fatal error: exception %s\n" (Printexc.to_string exn));
|
|
|
|
Printexc.print_backtrace stderr;
|
|
|
|
flush stderr;
|
2021-03-30 12:18:31 +00:00
|
|
|
exit !exit_status
|
2016-02-23 11:06:52 +00:00
|
|
|
|
|
|
|
let main () = main_internal ~initial_env:None
|
|
|
|
|
|
|
|
type value = V : string * _ -> value
|
|
|
|
|
2017-05-26 14:26:27 +00:00
|
|
|
exception Found of Env.t
|
2016-04-25 09:50:26 +00:00
|
|
|
|
2017-05-26 14:26:27 +00:00
|
|
|
#if OCAML_VERSION >= (4, 03, 0)
|
|
|
|
let get_required_label name args =
|
|
|
|
match List.find (fun (lab, _) -> lab = Asttypes.Labelled name) args with
|
|
|
|
| _, x -> x
|
|
|
|
| exception Not_found -> None
|
2016-04-08 08:31:37 +00:00
|
|
|
#else
|
2017-05-26 14:26:27 +00:00
|
|
|
let get_required_label name args =
|
|
|
|
match List.find (fun (lab, _, k) -> lab = "loc" && k = Typedtree.Required) args with
|
|
|
|
| _, x, _ -> x
|
|
|
|
| _ -> None
|
|
|
|
| exception Not_found -> None
|
|
|
|
#endif
|
2016-04-08 08:31:37 +00:00
|
|
|
|
2017-05-26 14:26:27 +00:00
|
|
|
let walk dir ~init ~f =
|
|
|
|
let rec loop dir acc =
|
|
|
|
let acc = f dir acc in
|
|
|
|
ArrayLabels.fold_left (Sys.readdir dir) ~init:acc ~f:(fun acc fn ->
|
|
|
|
let fn = Filename.concat dir fn in
|
|
|
|
match Unix.lstat fn with
|
|
|
|
| { st_kind = S_DIR; _ } -> loop fn acc
|
|
|
|
| _ -> acc)
|
|
|
|
in
|
|
|
|
match Unix.lstat dir with
|
|
|
|
| exception Unix.Unix_error(ENOENT, _, _) -> init
|
|
|
|
| _ -> loop dir init
|
2016-02-23 11:06:52 +00:00
|
|
|
|
2017-05-26 14:26:27 +00:00
|
|
|
let interact ?(search_path=[]) ?(build_dir="_build") ~unit ~loc:(fname, lnum, cnum, _)
|
|
|
|
~values =
|
|
|
|
let search_path = walk build_dir ~init:search_path ~f:(fun dir acc -> dir :: acc) in
|
2016-02-23 11:27:22 +00:00
|
|
|
let cmt_fname =
|
|
|
|
try
|
|
|
|
Misc.find_in_path_uncap search_path (unit ^ ".cmt")
|
|
|
|
with Not_found ->
|
2017-05-26 14:26:27 +00:00
|
|
|
Printf.ksprintf failwith "%s.cmt not found in search path!" unit
|
2016-02-23 11:27:22 +00:00
|
|
|
in
|
|
|
|
let cmt_infos = Cmt_format.read_cmt cmt_fname in
|
2019-09-16 12:30:29 +00:00
|
|
|
let expr next (e : Typedtree.expression) =
|
|
|
|
match e.exp_desc with
|
2017-05-26 14:26:27 +00:00
|
|
|
| Texp_apply (_, args) -> begin
|
|
|
|
try
|
|
|
|
match get_required_label "loc" args,
|
|
|
|
get_required_label "values" args
|
|
|
|
with
|
|
|
|
| Some l, Some v ->
|
|
|
|
let pos = l.exp_loc.loc_start in
|
|
|
|
if pos.pos_fname = fname &&
|
|
|
|
pos.pos_lnum = lnum &&
|
|
|
|
pos.pos_cnum - pos.pos_bol = cnum then
|
|
|
|
raise (Found v.exp_env)
|
2019-09-16 12:30:29 +00:00
|
|
|
| _ -> next e
|
|
|
|
with Not_found -> next e
|
2017-05-26 14:26:27 +00:00
|
|
|
end
|
2019-09-16 12:30:29 +00:00
|
|
|
| _ -> next e
|
|
|
|
in
|
|
|
|
#if OCAML_VERSION >= (4,09,0)
|
|
|
|
let next iterator e = Tast_iterator.default_iterator.expr iterator e in
|
|
|
|
let expr iterator = expr (next iterator) in
|
|
|
|
let iter = { Tast_iterator.default_iterator with expr } in
|
|
|
|
let search = iter.structure iter in
|
|
|
|
#else
|
|
|
|
let module Search =
|
|
|
|
TypedtreeIter.MakeIterator(struct
|
|
|
|
include TypedtreeIter.DefaultIteratorArgument
|
|
|
|
|
|
|
|
let enter_expression = expr ignore
|
2017-05-26 14:26:27 +00:00
|
|
|
end) in
|
2019-09-16 12:30:29 +00:00
|
|
|
let search = Search.iter_structure in
|
|
|
|
#endif
|
2016-04-08 08:31:37 +00:00
|
|
|
try
|
2017-05-26 14:26:27 +00:00
|
|
|
begin match cmt_infos.cmt_annots with
|
2019-09-16 12:30:29 +00:00
|
|
|
| Implementation st -> search st
|
2017-05-26 14:26:27 +00:00
|
|
|
| _ -> ()
|
|
|
|
end;
|
2016-04-08 08:31:37 +00:00
|
|
|
failwith "Couldn't find location in cmt file"
|
|
|
|
with Found env ->
|
|
|
|
try
|
|
|
|
List.iter Topdirs.dir_directory (search_path @ cmt_infos.cmt_loadpath);
|
|
|
|
let env = Envaux.env_of_only_summary env in
|
|
|
|
List.iter (fun (V (name, v)) -> Toploop.setvalue name (Obj.repr v)) values;
|
|
|
|
main_internal ~initial_env:(Some env)
|
|
|
|
with exn ->
|
|
|
|
Location.report_exception Format.err_formatter exn;
|
|
|
|
exit 2
|
2016-02-24 11:03:51 +00:00
|
|
|
|
|
|
|
let () =
|
|
|
|
Location.register_error_of_exn
|
|
|
|
(function
|
|
|
|
| Envaux.Error err ->
|
|
|
|
Some (Location.error_of_printer_file Envaux.report_error err)
|
|
|
|
| _ -> None
|
|
|
|
)
|