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

WIP add eio support

This commit is contained in:
xenia 2024-04-22 00:15:45 -04:00
parent 384b3098c8
commit d0d49d5de1
4 changed files with 433 additions and 381 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/lib/dune
View File

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

6
src/lib/uTop.ml
View 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

12
src/lib/uTop_compat.ml
View File

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

792
src/lib/uTop_main.ml
View File

@ -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,27 +765,39 @@ let rec loop term =
let buffer = Buffer.create 1024 in
let pp = Format.formatter_of_buffer buffer in
UTop_private.set_margin pp;
(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);
(* 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
UTop_history.add_output UTop.stashable_session_history string;
match phrase with
| Parsetree.Ptop_def _ ->
(* The string is an output phrase, colorize it. *)
Lwt_main.run (render_out_phrase term string)
| Parsetree.Ptop_dir _ ->
(* The string is an error message. *)
Lwt_main.run (print_error term string)
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;
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 ();
flush stdout;
flush stderr;
(* Get the string printed. *)
Format.pp_print_flush pp ();
let string = Buffer.contents buffer in
UTop_history.add_output UTop.stashable_session_history string;
match phrase with
| Parsetree.Ptop_def _ ->
(* The string is an output phrase, colorize it. *)
render_out_phrase term string
| Parsetree.Ptop_dir _ ->
(* The string is an error message. *)
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 =
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_aux ~initial_env
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