WIP add eio support
This commit is contained in:
parent
384b3098c8
commit
d0d49d5de1
|
|
@ -3,8 +3,8 @@
|
|||
(public_name utop)
|
||||
(wrapped false)
|
||||
(modes byte)
|
||||
(libraries compiler-libs.toplevel findlib.top lambda-term logs.lwt threads
|
||||
xdg zed)
|
||||
(libraries compiler-libs.toplevel eio_main findlib.top lambda-term logs.lwt
|
||||
lwt_eio threads xdg zed)
|
||||
(preprocess
|
||||
(action
|
||||
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))))
|
||||
|
|
|
|||
|
|
@ -712,11 +712,11 @@ let print_error msg =
|
|||
|
||||
let handle_findlib_error = function
|
||||
| Failure msg ->
|
||||
Lwt_main.run (print_error msg)
|
||||
UTop_compat.lwt_eio_shim (print_error msg)
|
||||
| Fl_package_base.No_such_package(pkg, reason) ->
|
||||
Lwt_main.run (print_error (Printf.sprintf "No such package: %s%s\n" pkg (if reason <> "" then " - " ^ reason else "")))
|
||||
UTop_compat.lwt_eio_shim (print_error (Printf.sprintf "No such package: %s%s\n" pkg (if reason <> "" then " - " ^ reason else "")))
|
||||
| Fl_package_base.Package_loop pkg ->
|
||||
Lwt_main.run (print_error (Printf.sprintf "Package requires itself: %s\n" pkg))
|
||||
UTop_compat.lwt_eio_shim (print_error (Printf.sprintf "Package requires itself: %s\n" pkg))
|
||||
| exn ->
|
||||
raise exn
|
||||
|
||||
|
|
|
|||
|
|
@ -142,3 +142,15 @@ let add_cmi_hook f =
|
|||
in
|
||||
Persistent_env.Persistent_signature.load := load
|
||||
|
||||
#if OCAML_VERSION >= (5, 1, 0)
|
||||
let lwt_eio_shim lwt_promise =
|
||||
Lwt_eio.run_lwt (fun () -> lwt_promise)
|
||||
|
||||
let eio_env : Eio_unix.Stdenv.base option ref = ref None
|
||||
#else
|
||||
let lwt_eio_shim lwt_promise =
|
||||
failwith "eio not supported in this version of OCaml!"
|
||||
|
||||
let eio_env : int option ref = ref None
|
||||
#endif
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,8 @@
|
|||
|
||||
[@@@warning "-7-9-27-32-33"]
|
||||
|
||||
open Eio.Std
|
||||
open Lwt.Syntax
|
||||
open Lwt_react
|
||||
open LTerm_dlist
|
||||
open LTerm_text
|
||||
|
|
@ -529,7 +531,8 @@ type rewrite_rule = {
|
|||
(* Whether the rule is enabled or not. *)
|
||||
}
|
||||
|
||||
let longident_lwt_main_run = Longident.Ldot (Longident.Lident "Lwt_main", "run")
|
||||
(* let longident_lwt_main_run = Longident.Ldot (Longident.Lident "Lwt_main", "run") *)
|
||||
let longident_eio_lwt_run_in_main = Longident.Ldot (Longident.Lident "UTop_compat", "lwt_eio_shim")
|
||||
let longident_async_thread_safe_block_on_async_exn =
|
||||
Longident.(Ldot (Ldot (Lident "Async", "Thread_safe"), "block_on_async_exn"))
|
||||
|
||||
|
|
@ -538,11 +541,11 @@ let rewrite_rules = [
|
|||
{
|
||||
type_to_rewrite = Longident.(Ldot (Lident "Lwt", "t"));
|
||||
path_to_rewrite = None;
|
||||
required_values = [longident_lwt_main_run];
|
||||
required_values = [longident_eio_lwt_run_in_main];
|
||||
rewrite = (fun loc e ->
|
||||
let open Ast_helper in
|
||||
with_default_loc loc (fun () ->
|
||||
Exp.apply (Exp.ident (with_loc loc longident_lwt_main_run)) [(Nolabel, e)]
|
||||
Exp.apply (Exp.ident (with_loc loc longident_eio_lwt_run_in_main)) [(Nolabel, e)]
|
||||
)
|
||||
);
|
||||
enabled = UTop.auto_run_lwt;
|
||||
|
|
@ -714,7 +717,9 @@ let print_error term msg =
|
|||
LTerm.set_style term LTerm_style.none >>= fun () ->
|
||||
LTerm.flush term
|
||||
|
||||
let rec loop term =
|
||||
let cancel_user_code : unit Lazy.t option ref = ref None
|
||||
|
||||
let rec loop term : unit Lwt.t =
|
||||
(* Reset completion. *)
|
||||
UTop_complete.reset ();
|
||||
|
||||
|
|
@ -725,8 +730,8 @@ let rec loop term =
|
|||
LTerm_dlist.iter_l (fun f -> f ()) UTop.new_command_hooks;
|
||||
|
||||
(* Read interactively user input. *)
|
||||
let phrase_opt =
|
||||
Lwt_main.run (
|
||||
let* phrase_opt =
|
||||
(
|
||||
Lwt.finalize
|
||||
(fun () ->
|
||||
read_phrase term >>= fun (result, warnings) ->
|
||||
|
|
@ -760,11 +765,23 @@ let rec loop term =
|
|||
let buffer = Buffer.create 1024 in
|
||||
let pp = Format.formatter_of_buffer buffer in
|
||||
UTop_private.set_margin pp;
|
||||
(try
|
||||
let* () = begin try
|
||||
Env.reset_cache_toplevel ();
|
||||
if !Clflags.dump_parsetree then Printast.top_phrase pp phrase;
|
||||
if !Clflags.dump_source then Pprintast.top_phrase pp phrase;
|
||||
ignore (execute_phrase true pp phrase);
|
||||
let* () = Lwt_eio.run_eio
|
||||
(fun () ->
|
||||
Switch.run @@ fun sw ->
|
||||
Switch.on_release sw (fun () -> cancel_user_code := None);
|
||||
try
|
||||
Eio.Cancel.sub @@ fun cc ->
|
||||
cancel_user_code := Some (lazy begin
|
||||
try Eio.Cancel.cancel cc Sys.Break with Invalid_argument _ -> ()
|
||||
end);
|
||||
ignore (execute_phrase true pp phrase)
|
||||
with Eio.Cancel.Cancelled Sys.Break ->
|
||||
UTop_compat.lwt_eio_shim (LTerm.fprintl term "Interrupted.")
|
||||
) in
|
||||
(* Flush everything. *)
|
||||
Format.pp_print_flush Format.std_formatter ();
|
||||
Format.pp_print_flush Format.err_formatter ();
|
||||
|
|
@ -777,10 +794,10 @@ let rec loop term =
|
|||
match phrase with
|
||||
| Parsetree.Ptop_def _ ->
|
||||
(* The string is an output phrase, colorize it. *)
|
||||
Lwt_main.run (render_out_phrase term string)
|
||||
render_out_phrase term string
|
||||
| Parsetree.Ptop_dir _ ->
|
||||
(* The string is an error message. *)
|
||||
Lwt_main.run (print_error term string)
|
||||
print_error term string
|
||||
with exn ->
|
||||
(* The only possible errors are directive errors. *)
|
||||
let msg = UTop.get_message Errors.report_error exn in
|
||||
|
|
@ -792,7 +809,8 @@ let rec loop term =
|
|||
with Not_found ->
|
||||
msg
|
||||
in
|
||||
Lwt_main.run (print_error term msg));
|
||||
print_error term msg
|
||||
end in
|
||||
loop term
|
||||
| None ->
|
||||
loop term
|
||||
|
|
@ -836,330 +854,330 @@ let welcome 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 ->
|
||||
Bytes.set buffer i c;
|
||||
if c = '\n' then
|
||||
return (i + 1, false)
|
||||
else
|
||||
loop (i + 1)
|
||||
| None ->
|
||||
return (i, true)
|
||||
in
|
||||
Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >>= fun () -> loop 0)
|
||||
(* 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 -> *)
|
||||
(* Bytes.set buffer i c; *)
|
||||
(* if c = '\n' then *)
|
||||
(* return (i + 1, false) *)
|
||||
(* else *)
|
||||
(* loop (i + 1) *)
|
||||
(* | None -> *)
|
||||
(* return (i, true) *)
|
||||
(* in *)
|
||||
(* Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >>= fun () -> loop 0) *)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Emacs mode |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
||||
module Emacs(M : sig end) = struct
|
||||
|
||||
(* Copy standard output, which will be used to send commands. *)
|
||||
let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout)
|
||||
|
||||
let split_at ?(trim=false) ch str =
|
||||
let rec aux acc i j =
|
||||
if j = String.length str then
|
||||
if trim && i = j then
|
||||
acc
|
||||
else
|
||||
(String.sub str i (j - i)) :: acc
|
||||
else if str.[j] = ch then
|
||||
aux (String.sub str i (j - i) :: acc) (j + 1) (j + 1)
|
||||
else
|
||||
aux acc i (j + 1)
|
||||
in
|
||||
List.rev (aux [] 0 0)
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Sending commands to Emacs |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
(* Mutex used to send commands to Emacs. *)
|
||||
let command_mutex = Mutex.create ()
|
||||
|
||||
let send command argument =
|
||||
Mutex.lock command_mutex;
|
||||
output_string command_oc command;
|
||||
output_char command_oc ':';
|
||||
output_string command_oc argument;
|
||||
output_char command_oc '\n';
|
||||
flush command_oc;
|
||||
Mutex.unlock command_mutex
|
||||
|
||||
(* Keep the [utop-phrase-terminator] variable of the emacs part in sync. *)
|
||||
let () =
|
||||
S.keep (S.map (send "phrase-terminator") UTop.phrase_terminator)
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Standard outputs redirection |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
(* The output of ocaml (stdout and stderr) is redirected so the
|
||||
emacs parts of utop can recognize it. *)
|
||||
|
||||
(* Continuously copy the output of ocaml to Emacs. *)
|
||||
let rec copy_output which ic =
|
||||
let line = input_line ic in
|
||||
send which line;
|
||||
copy_output which ic
|
||||
|
||||
(* Create a thread which redirect the given output: *)
|
||||
let redirect which fd =
|
||||
let fdr, fdw = Unix.pipe () in
|
||||
Unix.dup2 fdw fd;
|
||||
Unix.close fdw;
|
||||
Thread.create (copy_output which) (Unix.in_channel_of_descr fdr)
|
||||
|
||||
(* Redirects stdout and stderr: *)
|
||||
let _ = redirect "stdout" Unix.stdout
|
||||
let _ = redirect "stderr" Unix.stderr
|
||||
|
||||
(* +---------------------------------------------------------------+
|
||||
| Loop |
|
||||
+---------------------------------------------------------------+ *)
|
||||
|
||||
let read_line () =
|
||||
let behavior = Sys.signal Sys.sigint Sys.Signal_ignore in
|
||||
try
|
||||
let line = Lwt_main.run (Lwt_io.read_line_opt Lwt_io.stdin) in
|
||||
Sys.set_signal Sys.sigint behavior;
|
||||
line
|
||||
with exn ->
|
||||
Sys.set_signal Sys.sigint behavior;
|
||||
raise exn
|
||||
|
||||
let read_command () =
|
||||
match read_line () with
|
||||
| None ->
|
||||
None
|
||||
| Some line ->
|
||||
match try Some (String.index line ':') with Not_found -> None with
|
||||
| None ->
|
||||
send "stderr" "':' missing!";
|
||||
exit 1
|
||||
| Some idx ->
|
||||
Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1)))
|
||||
|
||||
let read_data () =
|
||||
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
|
||||
|
||||
let process_checked_phrase phrase =
|
||||
(* Rewrite toplevel expressions. *)
|
||||
let phrase = rewrite phrase in
|
||||
try
|
||||
Env.reset_cache_toplevel ();
|
||||
ignore (execute_phrase true Format.std_formatter phrase);
|
||||
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
|
||||
|
||||
let process_input add_to_history eos_is_error =
|
||||
let input = read_data () in
|
||||
let input_zed= Zed_string.unsafe_of_utf8 input in
|
||||
let result, warnings = parse_and_check input ~eos_is_error in
|
||||
match result with
|
||||
| UTop.Value phrase ->
|
||||
send "accept" "";
|
||||
List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
|
||||
if add_to_history then LTerm_history.add UTop.history input_zed;
|
||||
ignore (process_checked_phrase phrase)
|
||||
| UTop.Error (locs, msg) ->
|
||||
send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs));
|
||||
List.iter (send "stderr") (split_at ~trim:true '\n' warnings);
|
||||
if add_to_history then LTerm_history.add UTop.history input_zed;
|
||||
List.iter (send "stderr") (split_at ~trim:true '\n' msg)
|
||||
|
||||
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
|
||||
let typecheck phrase =
|
||||
match UTop.check_phrase phrase with
|
||||
| None -> None
|
||||
| Some (locs, msg, lines) -> Some (convert_loc_line input locs lines, msg)
|
||||
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
|
||||
loop more_phrases
|
||||
else
|
||||
()
|
||||
end
|
||||
| [] ->
|
||||
()
|
||||
in
|
||||
loop phrases
|
||||
| UTop.Error (locs, msg) ->
|
||||
send_error locs msg (Some warnings)
|
||||
|
||||
let rec loop () =
|
||||
(* Reset completion. *)
|
||||
UTop_complete.reset ();
|
||||
|
||||
(* Increment the command counter. *)
|
||||
UTop_private.set_count (S.value UTop_private.count + 1);
|
||||
|
||||
(* Call hooks. *)
|
||||
LTerm_dlist.iter_l (fun f -> f ()) UTop.new_command_hooks;
|
||||
|
||||
(* Tell emacs we are ready. *)
|
||||
send "prompt" "";
|
||||
|
||||
loop_commands (LTerm_history.contents UTop.history) []
|
||||
|
||||
and loop_commands history_prev history_next =
|
||||
match read_command () with
|
||||
| None ->
|
||||
()
|
||||
| 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
|
||||
let continue =
|
||||
try
|
||||
process_input add_to_history (not allow_incomplete);
|
||||
false
|
||||
with UTop.Need_more ->
|
||||
send "continue" "";
|
||||
true
|
||||
in
|
||||
if continue then
|
||||
loop_commands history_prev history_next
|
||||
else
|
||||
loop ()
|
||||
| Some ("input-multi", _) ->
|
||||
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 ()
|
||||
| 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
|
||||
| Some ("complete", _) ->
|
||||
let input = read_data () in
|
||||
let start, words =
|
||||
UTop_complete.complete
|
||||
~phrase_terminator:(UTop.get_phrase_terminator ())
|
||||
~input
|
||||
in
|
||||
let words = List.map fst words in
|
||||
let prefix = LTerm_read_line.common_prefix words in
|
||||
let index = String.length input - start in
|
||||
let suffix =
|
||||
if index > 0 && index <= String.length prefix then
|
||||
String.sub prefix index (String.length prefix - index)
|
||||
else
|
||||
""
|
||||
in
|
||||
if suffix = "" then begin
|
||||
send "completion-start" "";
|
||||
List.iter (send "completion") words;
|
||||
send "completion-stop" "";
|
||||
end else
|
||||
send "completion-word" suffix;
|
||||
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 ->
|
||||
List.iter (send "history-data") (split_at '\n' (Zed_string.to_utf8 entry));
|
||||
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" "";
|
||||
loop_commands ((Zed_string.unsafe_of_utf8 input) :: history_prev) history_next
|
||||
end
|
||||
| Some ("exit", code) ->
|
||||
exit (int_of_string code)
|
||||
| Some ("save-history", code) ->
|
||||
Lwt_main.run (save_history ());
|
||||
loop_commands history_prev history_next
|
||||
| Some ("require", package) -> begin
|
||||
try
|
||||
Topfind.load_deeply [package]
|
||||
with Fl_package_base.No_such_package(pkg, reason) ->
|
||||
send "no-such-package" pkg
|
||||
end;
|
||||
loop_commands history_prev history_next
|
||||
| Some (command, _) ->
|
||||
Printf.ksprintf (send "stderr") "unrecognized command %S!" command;
|
||||
exit 1
|
||||
end
|
||||
(* module Emacs(M : sig end) = struct *)
|
||||
(* *)
|
||||
(* (* Copy standard output, which will be used to send commands. *) *)
|
||||
(* let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout) *)
|
||||
(* *)
|
||||
(* let split_at ?(trim=false) ch str = *)
|
||||
(* let rec aux acc i j = *)
|
||||
(* if j = String.length str then *)
|
||||
(* if trim && i = j then *)
|
||||
(* acc *)
|
||||
(* else *)
|
||||
(* (String.sub str i (j - i)) :: acc *)
|
||||
(* else if str.[j] = ch then *)
|
||||
(* aux (String.sub str i (j - i) :: acc) (j + 1) (j + 1) *)
|
||||
(* else *)
|
||||
(* aux acc i (j + 1) *)
|
||||
(* in *)
|
||||
(* List.rev (aux [] 0 0) *)
|
||||
(* *)
|
||||
(* (* +---------------------------------------------------------------+ *)
|
||||
(* | Sending commands to Emacs | *)
|
||||
(* +---------------------------------------------------------------+ *) *)
|
||||
(* *)
|
||||
(* (* Mutex used to send commands to Emacs. *) *)
|
||||
(* let command_mutex = Mutex.create () *)
|
||||
(* *)
|
||||
(* let send command argument = *)
|
||||
(* Mutex.lock command_mutex; *)
|
||||
(* output_string command_oc command; *)
|
||||
(* output_char command_oc ':'; *)
|
||||
(* output_string command_oc argument; *)
|
||||
(* output_char command_oc '\n'; *)
|
||||
(* flush command_oc; *)
|
||||
(* Mutex.unlock command_mutex *)
|
||||
(* *)
|
||||
(* (* Keep the [utop-phrase-terminator] variable of the emacs part in sync. *) *)
|
||||
(* let () = *)
|
||||
(* S.keep (S.map (send "phrase-terminator") UTop.phrase_terminator) *)
|
||||
(* *)
|
||||
(* (* +---------------------------------------------------------------+ *)
|
||||
(* | Standard outputs redirection | *)
|
||||
(* +---------------------------------------------------------------+ *) *)
|
||||
(* *)
|
||||
(* (* The output of ocaml (stdout and stderr) is redirected so the *)
|
||||
(* emacs parts of utop can recognize it. *) *)
|
||||
(* *)
|
||||
(* (* Continuously copy the output of ocaml to Emacs. *) *)
|
||||
(* let rec copy_output which ic = *)
|
||||
(* let line = input_line ic in *)
|
||||
(* send which line; *)
|
||||
(* copy_output which ic *)
|
||||
(* *)
|
||||
(* (* Create a thread which redirect the given output: *) *)
|
||||
(* let redirect which fd = *)
|
||||
(* let fdr, fdw = Unix.pipe () in *)
|
||||
(* Unix.dup2 fdw fd; *)
|
||||
(* Unix.close fdw; *)
|
||||
(* Thread.create (copy_output which) (Unix.in_channel_of_descr fdr) *)
|
||||
(* *)
|
||||
(* (* Redirects stdout and stderr: *) *)
|
||||
(* let _ = redirect "stdout" Unix.stdout *)
|
||||
(* let _ = redirect "stderr" Unix.stderr *)
|
||||
(* *)
|
||||
(* (* +---------------------------------------------------------------+ *)
|
||||
(* | Loop | *)
|
||||
(* +---------------------------------------------------------------+ *) *)
|
||||
(* *)
|
||||
(* let read_line () = *)
|
||||
(* let behavior = Sys.signal Sys.sigint Sys.Signal_ignore in *)
|
||||
(* try *)
|
||||
(* let line = Lwt_main.run (Lwt_io.read_line_opt Lwt_io.stdin) in *)
|
||||
(* Sys.set_signal Sys.sigint behavior; *)
|
||||
(* line *)
|
||||
(* with exn -> *)
|
||||
(* Sys.set_signal Sys.sigint behavior; *)
|
||||
(* raise exn *)
|
||||
(* *)
|
||||
(* let read_command () = *)
|
||||
(* match read_line () with *)
|
||||
(* | None -> *)
|
||||
(* None *)
|
||||
(* | Some line -> *)
|
||||
(* match try Some (String.index line ':') with Not_found -> None with *)
|
||||
(* | None -> *)
|
||||
(* send "stderr" "':' missing!"; *)
|
||||
(* exit 1 *)
|
||||
(* | Some idx -> *)
|
||||
(* Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1))) *)
|
||||
(* *)
|
||||
(* let read_data () = *)
|
||||
(* 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 *)
|
||||
(* *)
|
||||
(* let process_checked_phrase phrase = *)
|
||||
(* (* Rewrite toplevel expressions. *) *)
|
||||
(* let phrase = rewrite phrase in *)
|
||||
(* try *)
|
||||
(* Env.reset_cache_toplevel (); *)
|
||||
(* ignore (execute_phrase true Format.std_formatter phrase); *)
|
||||
(* 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 *)
|
||||
(* *)
|
||||
(* let process_input add_to_history eos_is_error = *)
|
||||
(* let input = read_data () in *)
|
||||
(* let input_zed= Zed_string.unsafe_of_utf8 input in *)
|
||||
(* let result, warnings = parse_and_check input ~eos_is_error in *)
|
||||
(* match result with *)
|
||||
(* | UTop.Value phrase -> *)
|
||||
(* send "accept" ""; *)
|
||||
(* List.iter (send "stderr") (split_at ~trim:true '\n' warnings); *)
|
||||
(* if add_to_history then LTerm_history.add UTop.history input_zed; *)
|
||||
(* ignore (process_checked_phrase phrase) *)
|
||||
(* | UTop.Error (locs, msg) -> *)
|
||||
(* send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs)); *)
|
||||
(* List.iter (send "stderr") (split_at ~trim:true '\n' warnings); *)
|
||||
(* if add_to_history then LTerm_history.add UTop.history input_zed; *)
|
||||
(* List.iter (send "stderr") (split_at ~trim:true '\n' msg) *)
|
||||
(* *)
|
||||
(* 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 *)
|
||||
(* let typecheck phrase = *)
|
||||
(* match UTop.check_phrase phrase with *)
|
||||
(* | None -> None *)
|
||||
(* | Some (locs, msg, lines) -> Some (convert_loc_line input locs lines, msg) *)
|
||||
(* 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 *)
|
||||
(* loop more_phrases *)
|
||||
(* else *)
|
||||
(* () *)
|
||||
(* end *)
|
||||
(* | [] -> *)
|
||||
(* () *)
|
||||
(* in *)
|
||||
(* loop phrases *)
|
||||
(* | UTop.Error (locs, msg) -> *)
|
||||
(* send_error locs msg (Some warnings) *)
|
||||
(* *)
|
||||
(* let rec loop () = *)
|
||||
(* (* Reset completion. *) *)
|
||||
(* UTop_complete.reset (); *)
|
||||
(* *)
|
||||
(* (* Increment the command counter. *) *)
|
||||
(* UTop_private.set_count (S.value UTop_private.count + 1); *)
|
||||
(* *)
|
||||
(* (* Call hooks. *) *)
|
||||
(* LTerm_dlist.iter_l (fun f -> f ()) UTop.new_command_hooks; *)
|
||||
(* *)
|
||||
(* (* Tell emacs we are ready. *) *)
|
||||
(* send "prompt" ""; *)
|
||||
(* *)
|
||||
(* loop_commands (LTerm_history.contents UTop.history) [] *)
|
||||
(* *)
|
||||
(* and loop_commands history_prev history_next = *)
|
||||
(* match read_command () with *)
|
||||
(* | None -> *)
|
||||
(* () *)
|
||||
(* | 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 *)
|
||||
(* let continue = *)
|
||||
(* try *)
|
||||
(* process_input add_to_history (not allow_incomplete); *)
|
||||
(* false *)
|
||||
(* with UTop.Need_more -> *)
|
||||
(* send "continue" ""; *)
|
||||
(* true *)
|
||||
(* in *)
|
||||
(* if continue then *)
|
||||
(* loop_commands history_prev history_next *)
|
||||
(* else *)
|
||||
(* loop () *)
|
||||
(* | Some ("input-multi", _) -> *)
|
||||
(* 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 () *)
|
||||
(* | 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 *)
|
||||
(* | Some ("complete", _) -> *)
|
||||
(* let input = read_data () in *)
|
||||
(* let start, words = *)
|
||||
(* UTop_complete.complete *)
|
||||
(* ~phrase_terminator:(UTop.get_phrase_terminator ()) *)
|
||||
(* ~input *)
|
||||
(* in *)
|
||||
(* let words = List.map fst words in *)
|
||||
(* let prefix = LTerm_read_line.common_prefix words in *)
|
||||
(* let index = String.length input - start in *)
|
||||
(* let suffix = *)
|
||||
(* if index > 0 && index <= String.length prefix then *)
|
||||
(* String.sub prefix index (String.length prefix - index) *)
|
||||
(* else *)
|
||||
(* "" *)
|
||||
(* in *)
|
||||
(* if suffix = "" then begin *)
|
||||
(* send "completion-start" ""; *)
|
||||
(* List.iter (send "completion") words; *)
|
||||
(* send "completion-stop" ""; *)
|
||||
(* end else *)
|
||||
(* send "completion-word" suffix; *)
|
||||
(* 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 -> *)
|
||||
(* List.iter (send "history-data") (split_at '\n' (Zed_string.to_utf8 entry)); *)
|
||||
(* 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" ""; *)
|
||||
(* loop_commands ((Zed_string.unsafe_of_utf8 input) :: history_prev) history_next *)
|
||||
(* end *)
|
||||
(* | Some ("exit", code) -> *)
|
||||
(* exit (int_of_string code) *)
|
||||
(* | Some ("save-history", code) -> *)
|
||||
(* Lwt_main.run (save_history ()); *)
|
||||
(* loop_commands history_prev history_next *)
|
||||
(* | Some ("require", package) -> begin *)
|
||||
(* try *)
|
||||
(* Topfind.load_deeply [package] *)
|
||||
(* with Fl_package_base.No_such_package(pkg, reason) -> *)
|
||||
(* send "no-such-package" pkg *)
|
||||
(* end; *)
|
||||
(* loop_commands history_prev history_next *)
|
||||
(* | Some (command, _) -> *)
|
||||
(* Printf.ksprintf (send "stderr") "unrecognized command %S!" command; *)
|
||||
(* exit 1 *)
|
||||
(* end *)
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Extra macros |
|
||||
|
|
@ -1213,15 +1231,16 @@ let typeof sid =
|
|||
in
|
||||
match out_sig_item with
|
||||
| None ->
|
||||
Lwt_main.run (Lazy.force LTerm.stdout >>= fun term ->
|
||||
print_error term "Unknown type\n")
|
||||
UTop_compat.lwt_eio_shim
|
||||
(Lazy.force LTerm.stdout >>= fun term -> print_error term "Unknown type\n")
|
||||
| Some osig ->
|
||||
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)
|
||||
UTop_compat.lwt_eio_shim
|
||||
(Lazy.force LTerm.stdout >>= fun term -> render_out_phrase term str)
|
||||
|
||||
let default_info = {
|
||||
Toploop.section = "UTop";
|
||||
|
|
@ -1368,7 +1387,7 @@ let load_init_files dir =
|
|||
files
|
||||
;;
|
||||
|
||||
let common_init ~initial_env =
|
||||
let common_init ~initial_env : unit Lwt.t =
|
||||
(* Initializes toplevel environment. *)
|
||||
(match initial_env with
|
||||
| None -> Toploop.initialize_toplevel_env ()
|
||||
|
|
@ -1376,7 +1395,13 @@ let common_init ~initial_env =
|
|||
(* Set the global input name. *)
|
||||
Location.input_name := UTop.input_name;
|
||||
(* Make sure SIGINT is catched while executing OCaml code. *)
|
||||
Sys.catch_break true;
|
||||
Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ ->
|
||||
(* if we're currently in user code, execute the cancel thunk for that *)
|
||||
(* otherwise, raise directly (for compat) *)
|
||||
match !cancel_user_code with
|
||||
| Some canceler -> Lazy.force canceler
|
||||
| None -> raise Sys.Break
|
||||
));
|
||||
(* Load system init files. *)
|
||||
(match try Some (Sys.getenv "OCAML_TOPLEVEL_PATH") with Not_found -> None with
|
||||
| Some dir ->
|
||||
|
|
@ -1415,7 +1440,7 @@ let common_init ~initial_env =
|
|||
ignore (toploop_use_silently Format.err_formatter fn : bool));
|
||||
(* Load history after the initialization file so the user can change
|
||||
the history file name. *)
|
||||
Lwt_main.run (init_history ());
|
||||
let* () = init_history () in
|
||||
(* Install signal handlers. *)
|
||||
let behavior = Sys.Signal_handle (fun signo -> raise (Term signo)) in
|
||||
let catch signo =
|
||||
|
|
@ -1428,7 +1453,8 @@ let common_init ~initial_env =
|
|||
(* We lost the terminal. *)
|
||||
catch Sys.sighup;
|
||||
(* Termination request. *)
|
||||
catch Sys.sigterm
|
||||
catch Sys.sigterm;
|
||||
return ()
|
||||
|
||||
let load_inputrc () =
|
||||
Lwt.catch
|
||||
|
|
@ -1442,52 +1468,66 @@ let load_inputrc () =
|
|||
|
||||
let protocol_version = 1
|
||||
|
||||
let main_aux ~initial_env =
|
||||
let main_aux ~initial_env : unit Lwt.t =
|
||||
Arg.parse args file_argument usage;
|
||||
#if OCAML_VERSION >= (5, 0, 0) && OCAML_VERSION < (5, 1, 0)
|
||||
Topcommon.load_topdirs_signature ();
|
||||
#endif
|
||||
if not (prepare ()) then exit 2;
|
||||
if !emacs_mode then begin
|
||||
Printf.printf "protocol-version:%d\n%!" protocol_version;
|
||||
UTop_private.set_ui UTop_private.Emacs;
|
||||
let module Emacs = Emacs (struct end) in
|
||||
Printf.printf "Welcome to utop version %s (using OCaml version %s)!\n\n%!" UTop.version Sys.ocaml_version;
|
||||
common_init ~initial_env;
|
||||
Emacs.loop ()
|
||||
let* () = if !emacs_mode then begin
|
||||
print_string "ERROR: emacs is todo lmao";
|
||||
exit 1
|
||||
(* Printf.printf "protocol-version:%d\n%!" protocol_version; *)
|
||||
(* 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; *)
|
||||
(* let* () = common_init ~initial_env in *)
|
||||
(* Emacs.loop () *)
|
||||
end else begin
|
||||
UTop_private.set_ui UTop_private.Console;
|
||||
let term = Lwt_main.run (Lazy.force LTerm.stdout) in
|
||||
let* term = 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. *)
|
||||
Lwt_main.run (Lwt.join [UTop_styles.load (); load_inputrc ()]);
|
||||
let* () = Lwt.join [UTop_styles.load (); load_inputrc ()] in
|
||||
(* Display a welcome message. *)
|
||||
Lwt_main.run (welcome term);
|
||||
let* () = welcome term in
|
||||
(* Common initialization. *)
|
||||
common_init ~initial_env;
|
||||
let* () = common_init ~initial_env in
|
||||
(* 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 ->
|
||||
()
|
||||
Lwt.catch
|
||||
(fun () -> loop term)
|
||||
(function
|
||||
| LTerm_read_line.Interrupt ->
|
||||
return ()
|
||||
| exn -> Lwt.fail exn)
|
||||
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
|
||||
(* TODO: ??????? *)
|
||||
print_string "ERROR: stdout must be tty!";
|
||||
exit 1
|
||||
(* Toploop.read_interactive_input := read_input_classic; *)
|
||||
(* Toploop.loop Format.std_formatter *)
|
||||
end
|
||||
end;
|
||||
end in
|
||||
(* Don't let the standard toplevel run... *)
|
||||
exit 0
|
||||
|
||||
let main_internal ~initial_env =
|
||||
try
|
||||
let main_start_loop ~initial_env : unit =
|
||||
Eio_main.run @@ fun env ->
|
||||
UTop_compat.eio_env := Some env;
|
||||
Lwt_eio.with_event_loop ~debug:false ~clock:env#clock @@ fun _ ->
|
||||
Lwt_eio.run_lwt @@ fun () ->
|
||||
main_aux ~initial_env
|
||||
|
||||
let main_internal ~initial_env : unit =
|
||||
try
|
||||
main_start_loop ~initial_env
|
||||
with exn ->
|
||||
(match exn with
|
||||
#if OCAML_VERSION >= (4,12,0)
|
||||
|
|
@ -1575,7 +1615,7 @@ let interact ?(search_path=[]) ?(build_dir="_build") ~unit ~loc:(fname, lnum, cn
|
|||
List.iter Topdirs.dir_directory (search_path @ visible_paths);
|
||||
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)
|
||||
(fun () -> main_internal ~initial_env:(Some env))
|
||||
with exn ->
|
||||
Location.report_exception Format.err_formatter exn;
|
||||
exit 2
|
||||
|
|
|
|||
Loading…
Reference in New Issue