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) (public_name utop)
(wrapped false) (wrapped false)
(modes byte) (modes byte)
(libraries compiler-libs.toplevel findlib.top lambda-term logs.lwt threads (libraries compiler-libs.toplevel eio_main findlib.top lambda-term logs.lwt
xdg zed) lwt_eio threads xdg zed)
(preprocess (preprocess
(action (action
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file})))) (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 let handle_findlib_error = function
| Failure msg -> | Failure msg ->
Lwt_main.run (print_error msg) UTop_compat.lwt_eio_shim (print_error msg)
| Fl_package_base.No_such_package(pkg, reason) -> | 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 -> | 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 -> | exn ->
raise exn raise exn

12
src/lib/uTop_compat.ml
View File

@ -142,3 +142,15 @@ let add_cmi_hook f =
in in
Persistent_env.Persistent_signature.load := load 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"] [@@@warning "-7-9-27-32-33"]
open Eio.Std
open Lwt.Syntax
open Lwt_react open Lwt_react
open LTerm_dlist open LTerm_dlist
open LTerm_text open LTerm_text
@ -529,7 +531,8 @@ type rewrite_rule = {
(* Whether the rule is enabled or not. *) (* 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 = let longident_async_thread_safe_block_on_async_exn =
Longident.(Ldot (Ldot (Lident "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")); type_to_rewrite = Longident.(Ldot (Lident "Lwt", "t"));
path_to_rewrite = None; path_to_rewrite = None;
required_values = [longident_lwt_main_run]; required_values = [longident_eio_lwt_run_in_main];
rewrite = (fun loc e -> rewrite = (fun loc e ->
let open Ast_helper in let open Ast_helper in
with_default_loc loc (fun () -> 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; enabled = UTop.auto_run_lwt;
@ -714,7 +717,9 @@ let print_error term msg =
LTerm.set_style term LTerm_style.none >>= fun () -> LTerm.set_style term LTerm_style.none >>= fun () ->
LTerm.flush term 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. *) (* Reset completion. *)
UTop_complete.reset (); UTop_complete.reset ();
@ -725,8 +730,8 @@ let rec loop term =
LTerm_dlist.iter_l (fun f -> f ()) UTop.new_command_hooks; LTerm_dlist.iter_l (fun f -> f ()) UTop.new_command_hooks;
(* Read interactively user input. *) (* Read interactively user input. *)
let phrase_opt = let* phrase_opt =
Lwt_main.run ( (
Lwt.finalize Lwt.finalize
(fun () -> (fun () ->
read_phrase term >>= fun (result, warnings) -> read_phrase term >>= fun (result, warnings) ->
@ -760,27 +765,39 @@ let rec loop term =
let buffer = Buffer.create 1024 in let buffer = Buffer.create 1024 in
let pp = Format.formatter_of_buffer buffer in let pp = Format.formatter_of_buffer buffer in
UTop_private.set_margin pp; UTop_private.set_margin pp;
(try let* () = begin try
Env.reset_cache_toplevel (); Env.reset_cache_toplevel ();
if !Clflags.dump_parsetree then Printast.top_phrase pp phrase; if !Clflags.dump_parsetree then Printast.top_phrase pp phrase;
if !Clflags.dump_source then Pprintast.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
(* Flush everything. *) (fun () ->
Format.pp_print_flush Format.std_formatter (); Switch.run @@ fun sw ->
Format.pp_print_flush Format.err_formatter (); Switch.on_release sw (fun () -> cancel_user_code := None);
flush stdout; try
flush stderr; Eio.Cancel.sub @@ fun cc ->
(* Get the string printed. *) cancel_user_code := Some (lazy begin
Format.pp_print_flush pp (); try Eio.Cancel.cancel cc Sys.Break with Invalid_argument _ -> ()
let string = Buffer.contents buffer in end);
UTop_history.add_output UTop.stashable_session_history string; ignore (execute_phrase true pp phrase)
match phrase with with Eio.Cancel.Cancelled Sys.Break ->
| Parsetree.Ptop_def _ -> UTop_compat.lwt_eio_shim (LTerm.fprintl term "Interrupted.")
(* The string is an output phrase, colorize it. *) ) in
Lwt_main.run (render_out_phrase term string) (* Flush everything. *)
| Parsetree.Ptop_dir _ -> Format.pp_print_flush Format.std_formatter ();
(* The string is an error message. *) Format.pp_print_flush Format.err_formatter ();
Lwt_main.run (print_error term string) 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 -> with exn ->
(* The only possible errors are directive errors. *) (* The only possible errors are directive errors. *)
let msg = UTop.get_message Errors.report_error exn in let msg = UTop.get_message Errors.report_error exn in
@ -792,7 +809,8 @@ let rec loop term =
with Not_found -> with Not_found ->
msg msg
in in
Lwt_main.run (print_error term msg)); print_error term msg
end in
loop term loop term
| None -> | None ->
loop term loop term
@ -836,330 +854,330 @@ let welcome term =
| Classic mode | | Classic mode |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
let read_input_classic prompt buffer len = (* let read_input_classic prompt buffer len = *)
let rec loop i = (* let rec loop i = *)
if i = len then (* if i = len then *)
return (i, false) (* return (i, false) *)
else (* else *)
Lwt_io.read_char_opt Lwt_io.stdin >>= function (* Lwt_io.read_char_opt Lwt_io.stdin >>= function *)
| Some c -> (* | Some c -> *)
Bytes.set buffer i c; (* Bytes.set buffer i c; *)
if c = '\n' then (* if c = '\n' then *)
return (i + 1, false) (* return (i + 1, false) *)
else (* else *)
loop (i + 1) (* loop (i + 1) *)
| None -> (* | None -> *)
return (i, true) (* return (i, true) *)
in (* in *)
Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >>= fun () -> loop 0) (* Lwt_main.run (Lwt_io.write Lwt_io.stdout prompt >>= fun () -> loop 0) *)
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Emacs mode | | Emacs mode |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
module Emacs(M : sig end) = struct (* module Emacs(M : sig end) = struct *)
(* *)
(* Copy standard output, which will be used to send commands. *) (* (* Copy standard output, which will be used to send commands. *) *)
let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout) (* let command_oc = Unix.out_channel_of_descr (Unix.dup Unix.stdout) *)
(* *)
let split_at ?(trim=false) ch str = (* let split_at ?(trim=false) ch str = *)
let rec aux acc i j = (* let rec aux acc i j = *)
if j = String.length str then (* if j = String.length str then *)
if trim && i = j then (* if trim && i = j then *)
acc (* acc *)
else (* else *)
(String.sub str i (j - i)) :: acc (* (String.sub str i (j - i)) :: acc *)
else if str.[j] = ch then (* else if str.[j] = ch then *)
aux (String.sub str i (j - i) :: acc) (j + 1) (j + 1) (* aux (String.sub str i (j - i) :: acc) (j + 1) (j + 1) *)
else (* else *)
aux acc i (j + 1) (* aux acc i (j + 1) *)
in (* in *)
List.rev (aux [] 0 0) (* List.rev (aux [] 0 0) *)
(* *)
(* +---------------------------------------------------------------+ (* (* +---------------------------------------------------------------+ *)
| Sending commands to Emacs | (* | Sending commands to Emacs | *)
+---------------------------------------------------------------+ *) (* +---------------------------------------------------------------+ *) *)
(* *)
(* Mutex used to send commands to Emacs. *) (* (* Mutex used to send commands to Emacs. *) *)
let command_mutex = Mutex.create () (* let command_mutex = Mutex.create () *)
(* *)
let send command argument = (* let send command argument = *)
Mutex.lock command_mutex; (* Mutex.lock command_mutex; *)
output_string command_oc command; (* output_string command_oc command; *)
output_char command_oc ':'; (* output_char command_oc ':'; *)
output_string command_oc argument; (* output_string command_oc argument; *)
output_char command_oc '\n'; (* output_char command_oc '\n'; *)
flush command_oc; (* flush command_oc; *)
Mutex.unlock command_mutex (* Mutex.unlock command_mutex *)
(* *)
(* Keep the [utop-phrase-terminator] variable of the emacs part in sync. *) (* (* Keep the [utop-phrase-terminator] variable of the emacs part in sync. *) *)
let () = (* let () = *)
S.keep (S.map (send "phrase-terminator") UTop.phrase_terminator) (* S.keep (S.map (send "phrase-terminator") UTop.phrase_terminator) *)
(* *)
(* +---------------------------------------------------------------+ (* (* +---------------------------------------------------------------+ *)
| Standard outputs redirection | (* | Standard outputs redirection | *)
+---------------------------------------------------------------+ *) (* +---------------------------------------------------------------+ *) *)
(* *)
(* The output of ocaml (stdout and stderr) is redirected so the (* (* The output of ocaml (stdout and stderr) is redirected so the *)
emacs parts of utop can recognize it. *) (* emacs parts of utop can recognize it. *) *)
(* *)
(* Continuously copy the output of ocaml to Emacs. *) (* (* Continuously copy the output of ocaml to Emacs. *) *)
let rec copy_output which ic = (* let rec copy_output which ic = *)
let line = input_line ic in (* let line = input_line ic in *)
send which line; (* send which line; *)
copy_output which ic (* copy_output which ic *)
(* *)
(* Create a thread which redirect the given output: *) (* (* Create a thread which redirect the given output: *) *)
let redirect which fd = (* let redirect which fd = *)
let fdr, fdw = Unix.pipe () in (* let fdr, fdw = Unix.pipe () in *)
Unix.dup2 fdw fd; (* Unix.dup2 fdw fd; *)
Unix.close fdw; (* Unix.close fdw; *)
Thread.create (copy_output which) (Unix.in_channel_of_descr fdr) (* Thread.create (copy_output which) (Unix.in_channel_of_descr fdr) *)
(* *)
(* Redirects stdout and stderr: *) (* (* Redirects stdout and stderr: *) *)
let _ = redirect "stdout" Unix.stdout (* let _ = redirect "stdout" Unix.stdout *)
let _ = redirect "stderr" Unix.stderr (* let _ = redirect "stderr" Unix.stderr *)
(* *)
(* +---------------------------------------------------------------+ (* (* +---------------------------------------------------------------+ *)
| Loop | (* | Loop | *)
+---------------------------------------------------------------+ *) (* +---------------------------------------------------------------+ *) *)
(* *)
let read_line () = (* let read_line () = *)
let behavior = Sys.signal Sys.sigint Sys.Signal_ignore in (* let behavior = Sys.signal Sys.sigint Sys.Signal_ignore in *)
try (* try *)
let line = Lwt_main.run (Lwt_io.read_line_opt Lwt_io.stdin) in (* let line = Lwt_main.run (Lwt_io.read_line_opt Lwt_io.stdin) in *)
Sys.set_signal Sys.sigint behavior; (* Sys.set_signal Sys.sigint behavior; *)
line (* line *)
with exn -> (* with exn -> *)
Sys.set_signal Sys.sigint behavior; (* Sys.set_signal Sys.sigint behavior; *)
raise exn (* raise exn *)
(* *)
let read_command () = (* let read_command () = *)
match read_line () with (* match read_line () with *)
| None -> (* | None -> *)
None (* None *)
| Some line -> (* | Some line -> *)
match try Some (String.index line ':') with Not_found -> None with (* match try Some (String.index line ':') with Not_found -> None with *)
| None -> (* | None -> *)
send "stderr" "':' missing!"; (* send "stderr" "':' missing!"; *)
exit 1 (* exit 1 *)
| Some idx -> (* | Some idx -> *)
Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1))) (* Some (String.sub line 0 idx, String.sub line (idx + 1) (String.length line - (idx + 1))) *)
(* *)
let read_data () = (* let read_data () = *)
let buf = Buffer.create 1024 in (* let buf = Buffer.create 1024 in *)
let rec loop first = (* let rec loop first = *)
match read_command () with (* match read_command () with *)
| None -> (* | None -> *)
send "stderr" "'end' command missing!"; (* send "stderr" "'end' command missing!"; *)
exit 1 (* exit 1 *)
| Some ("data", data) -> (* | Some ("data", data) -> *)
if not first then Buffer.add_char buf '\n'; (* if not first then Buffer.add_char buf '\n'; *)
Buffer.add_string buf data; (* Buffer.add_string buf data; *)
loop false (* loop false *)
| Some ("end", _) -> (* | Some ("end", _) -> *)
Buffer.contents buf (* Buffer.contents buf *)
| Some (command, argument) -> (* | Some (command, argument) -> *)
Printf.ksprintf (send "stderr") "'data' or 'end' command expected, got %S!" command; (* Printf.ksprintf (send "stderr") "'data' or 'end' command expected, got %S!" command; *)
exit 1 (* exit 1 *)
in (* in *)
loop true (* loop true *)
(* *)
let process_checked_phrase phrase = (* let process_checked_phrase phrase = *)
(* Rewrite toplevel expressions. *) (* (* Rewrite toplevel expressions. *) *)
let phrase = rewrite phrase in (* let phrase = rewrite phrase in *)
try (* try *)
Env.reset_cache_toplevel (); (* Env.reset_cache_toplevel (); *)
ignore (execute_phrase true Format.std_formatter phrase); (* ignore (execute_phrase true Format.std_formatter phrase); *)
true (* true *)
with exn -> (* with exn -> *)
(* The only possible errors are directive errors. *) (* (* The only possible errors are directive errors. *) *)
let msg = UTop.get_message Errors.report_error exn in (* let msg = UTop.get_message Errors.report_error exn in *)
(* Skip the dumb location. *) (* (* Skip the dumb location. *) *)
let msg = (* let msg = *)
try (* try *)
let idx = String.index msg '\n' + 1 in (* let idx = String.index msg '\n' + 1 in *)
String.sub msg idx (String.length msg - idx) (* String.sub msg idx (String.length msg - idx) *)
with Not_found -> (* with Not_found -> *)
msg (* msg *)
in (* in *)
List.iter (send "stderr") (split_at ~trim:true '\n' msg); (* List.iter (send "stderr") (split_at ~trim:true '\n' msg); *)
false (* false *)
(* *)
let process_input add_to_history eos_is_error = (* let process_input add_to_history eos_is_error = *)
let input = read_data () in (* let input = read_data () in *)
let input_zed= Zed_string.unsafe_of_utf8 input in (* let input_zed= Zed_string.unsafe_of_utf8 input in *)
let result, warnings = parse_and_check input ~eos_is_error in (* let result, warnings = parse_and_check input ~eos_is_error in *)
match result with (* match result with *)
| UTop.Value phrase -> (* | UTop.Value phrase -> *)
send "accept" ""; (* send "accept" ""; *)
List.iter (send "stderr") (split_at ~trim:true '\n' warnings); (* List.iter (send "stderr") (split_at ~trim:true '\n' warnings); *)
if add_to_history then LTerm_history.add UTop.history input_zed; (* if add_to_history then LTerm_history.add UTop.history input_zed; *)
ignore (process_checked_phrase phrase) (* ignore (process_checked_phrase phrase) *)
| UTop.Error (locs, msg) -> (* | UTop.Error (locs, msg) -> *)
send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs)); (* 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); (* List.iter (send "stderr") (split_at ~trim:true '\n' warnings); *)
if add_to_history then LTerm_history.add UTop.history input_zed; (* if add_to_history then LTerm_history.add UTop.history input_zed; *)
List.iter (send "stderr") (split_at ~trim:true '\n' msg) (* List.iter (send "stderr") (split_at ~trim:true '\n' msg) *)
(* *)
let send_error locs msg warnings = (* let send_error locs msg warnings = *)
send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs)); (* send "accept" (String.concat "," (List.map (fun (a, b) -> Printf.sprintf "%d,%d" a b) locs)); *)
match warnings with (* match warnings with *)
| Some warnings -> List.iter (send "stderr") (split_at ~trim:true '\n' warnings) (* | Some warnings -> List.iter (send "stderr") (split_at ~trim:true '\n' warnings) *)
| None -> (); (* | None -> (); *)
List.iter (send "stderr") (split_at ~trim:true '\n' msg) (* List.iter (send "stderr") (split_at ~trim:true '\n' msg) *)
(* *)
let process_input_multi () = (* let process_input_multi () = *)
let input = read_data () in (* let input = read_data () in *)
let result, warnings = parse_input_multi input in (* let result, warnings = parse_input_multi input in *)
let typecheck phrase = (* let typecheck phrase = *)
match UTop.check_phrase phrase with (* match UTop.check_phrase phrase with *)
| None -> None (* | None -> None *)
| Some (locs, msg, lines) -> Some (convert_loc_line input locs lines, msg) (* | Some (locs, msg, lines) -> Some (convert_loc_line input locs lines, msg) *)
in (* in *)
match result with (* match result with *)
| UTop.Value phrases -> (* | UTop.Value phrases -> *)
send "accept" ""; (* send "accept" ""; *)
List.iter (send "stderr") (split_at ~trim:true '\n' warnings); (* List.iter (send "stderr") (split_at ~trim:true '\n' warnings); *)
let rec loop = function (* let rec loop = function *)
| (phrase::more_phrases) -> begin (* | (phrase::more_phrases) -> begin *)
match typecheck phrase with (* match typecheck phrase with *)
| Some (locs, msg) -> (* | Some (locs, msg) -> *)
send_error locs msg None (* send_error locs msg None *)
| None -> (* | None -> *)
let success = process_checked_phrase phrase in (* let success = process_checked_phrase phrase in *)
if success then (* if success then *)
loop more_phrases (* loop more_phrases *)
else (* else *)
() (* () *)
end (* end *)
| [] -> (* | [] -> *)
() (* () *)
in (* in *)
loop phrases (* loop phrases *)
| UTop.Error (locs, msg) -> (* | UTop.Error (locs, msg) -> *)
send_error locs msg (Some warnings) (* send_error locs msg (Some warnings) *)
(* *)
let rec loop () = (* let rec loop () = *)
(* Reset completion. *) (* (* Reset completion. *) *)
UTop_complete.reset (); (* UTop_complete.reset (); *)
(* *)
(* Increment the command counter. *) (* (* Increment the command counter. *) *)
UTop_private.set_count (S.value UTop_private.count + 1); (* UTop_private.set_count (S.value UTop_private.count + 1); *)
(* *)
(* Call hooks. *) (* (* Call hooks. *) *)
LTerm_dlist.iter_l (fun f -> f ()) UTop.new_command_hooks; (* LTerm_dlist.iter_l (fun f -> f ()) UTop.new_command_hooks; *)
(* *)
(* Tell emacs we are ready. *) (* (* Tell emacs we are ready. *) *)
send "prompt" ""; (* send "prompt" ""; *)
(* *)
loop_commands (LTerm_history.contents UTop.history) [] (* loop_commands (LTerm_history.contents UTop.history) [] *)
(* *)
and loop_commands history_prev history_next = (* and loop_commands history_prev history_next = *)
match read_command () with (* match read_command () with *)
| None -> (* | None -> *)
() (* () *)
| Some ("input", arg) -> (* | Some ("input", arg) -> *)
let args = split_at ',' arg in (* let args = split_at ',' arg in *)
let allow_incomplete = List.mem "allow-incomplete" args (* let allow_incomplete = List.mem "allow-incomplete" args *)
and add_to_history = List.mem "add-to-history" args in (* and add_to_history = List.mem "add-to-history" args in *)
let continue = (* let continue = *)
try (* try *)
process_input add_to_history (not allow_incomplete); (* process_input add_to_history (not allow_incomplete); *)
false (* false *)
with UTop.Need_more -> (* with UTop.Need_more -> *)
send "continue" ""; (* send "continue" ""; *)
true (* true *)
in (* in *)
if continue then (* if continue then *)
loop_commands history_prev history_next (* loop_commands history_prev history_next *)
else (* else *)
loop () (* loop () *)
| Some ("input-multi", _) -> (* | Some ("input-multi", _) -> *)
let continue = (* let continue = *)
try (* try *)
process_input_multi (); (* process_input_multi (); *)
false (* false *)
with UTop.Need_more -> (* with UTop.Need_more -> *)
send "continue" ""; (* send "continue" ""; *)
true (* true *)
in (* in *)
if continue then (* if continue then *)
loop_commands history_prev history_next (* loop_commands history_prev history_next *)
else (* else *)
loop () (* loop () *)
| Some ("complete-company", _) -> (* | Some ("complete-company", _) -> *)
let input = read_data () in (* let input = read_data () in *)
let _, words = (* let _, words = *)
UTop_complete.complete (* UTop_complete.complete *)
~phrase_terminator:(UTop.get_phrase_terminator ()) (* ~phrase_terminator:(UTop.get_phrase_terminator ()) *)
~input (* ~input *)
in (* in *)
send "completion-start" ""; (* send "completion-start" ""; *)
List.iter (fun (w, _) -> send "completion" w) words; (* List.iter (fun (w, _) -> send "completion" w) words; *)
send "completion-stop" ""; (* send "completion-stop" ""; *)
loop_commands history_prev history_next (* loop_commands history_prev history_next *)
| Some ("complete", _) -> (* | Some ("complete", _) -> *)
let input = read_data () in (* let input = read_data () in *)
let start, words = (* let start, words = *)
UTop_complete.complete (* UTop_complete.complete *)
~phrase_terminator:(UTop.get_phrase_terminator ()) (* ~phrase_terminator:(UTop.get_phrase_terminator ()) *)
~input (* ~input *)
in (* in *)
let words = List.map fst words in (* let words = List.map fst words in *)
let prefix = LTerm_read_line.common_prefix words in (* let prefix = LTerm_read_line.common_prefix words in *)
let index = String.length input - start in (* let index = String.length input - start in *)
let suffix = (* let suffix = *)
if index > 0 && index <= String.length prefix then (* if index > 0 && index <= String.length prefix then *)
String.sub prefix index (String.length prefix - index) (* String.sub prefix index (String.length prefix - index) *)
else (* else *)
"" (* "" *)
in (* in *)
if suffix = "" then begin (* if suffix = "" then begin *)
send "completion-start" ""; (* send "completion-start" ""; *)
List.iter (send "completion") words; (* List.iter (send "completion") words; *)
send "completion-stop" ""; (* send "completion-stop" ""; *)
end else (* end else *)
send "completion-word" suffix; (* send "completion-word" suffix; *)
loop_commands history_prev history_next (* loop_commands history_prev history_next *)
| Some ("history-prev", _) -> begin (* | Some ("history-prev", _) -> begin *)
let input = read_data () in (* let input = read_data () in *)
match history_prev with (* match history_prev with *)
| [] -> (* | [] -> *)
send "history-bound" ""; (* send "history-bound" ""; *)
loop_commands history_prev history_next (* loop_commands history_prev history_next *)
| entry :: history_prev -> (* | entry :: history_prev -> *)
List.iter (send "history-data") (split_at '\n' (Zed_string.to_utf8 entry)); (* List.iter (send "history-data") (split_at '\n' (Zed_string.to_utf8 entry)); *)
send "history-end" ""; (* send "history-end" ""; *)
loop_commands history_prev (input :: history_next) (* loop_commands history_prev (input :: history_next) *)
end (* end *)
| Some ("history-next", _) -> begin (* | Some ("history-next", _) -> begin *)
let input = read_data () in (* let input = read_data () in *)
match history_next with (* match history_next with *)
| [] -> (* | [] -> *)
send "history-bound" ""; (* send "history-bound" ""; *)
loop_commands history_prev history_next (* loop_commands history_prev history_next *)
| entry :: history_next -> (* | entry :: history_next -> *)
List.iter (send "history-data") (split_at '\n' entry); (* List.iter (send "history-data") (split_at '\n' entry); *)
send "history-end" ""; (* send "history-end" ""; *)
loop_commands ((Zed_string.unsafe_of_utf8 input) :: history_prev) history_next (* loop_commands ((Zed_string.unsafe_of_utf8 input) :: history_prev) history_next *)
end (* end *)
| Some ("exit", code) -> (* | Some ("exit", code) -> *)
exit (int_of_string code) (* exit (int_of_string code) *)
| Some ("save-history", code) -> (* | Some ("save-history", code) -> *)
Lwt_main.run (save_history ()); (* Lwt_main.run (save_history ()); *)
loop_commands history_prev history_next (* loop_commands history_prev history_next *)
| Some ("require", package) -> begin (* | Some ("require", package) -> begin *)
try (* try *)
Topfind.load_deeply [package] (* Topfind.load_deeply [package] *)
with Fl_package_base.No_such_package(pkg, reason) -> (* with Fl_package_base.No_such_package(pkg, reason) -> *)
send "no-such-package" pkg (* send "no-such-package" pkg *)
end; (* end; *)
loop_commands history_prev history_next (* loop_commands history_prev history_next *)
| Some (command, _) -> (* | Some (command, _) -> *)
Printf.ksprintf (send "stderr") "unrecognized command %S!" command; (* Printf.ksprintf (send "stderr") "unrecognized command %S!" command; *)
exit 1 (* exit 1 *)
end (* end *)
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Extra macros | | Extra macros |
@ -1213,15 +1231,16 @@ let typeof sid =
in in
match out_sig_item with match out_sig_item with
| None -> | None ->
Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> UTop_compat.lwt_eio_shim
print_error term "Unknown type\n") (Lazy.force LTerm.stdout >>= fun term -> print_error term "Unknown type\n")
| Some osig -> | Some osig ->
let buf = Buffer.create 128 in let buf = Buffer.create 128 in
let pp = Format.formatter_of_buffer buf in let pp = Format.formatter_of_buffer buf in
!Toploop.print_out_signature pp [osig]; !Toploop.print_out_signature pp [osig];
Format.pp_print_newline pp (); Format.pp_print_newline pp ();
let str = Buffer.contents buf in 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 = { let default_info = {
Toploop.section = "UTop"; Toploop.section = "UTop";
@ -1368,7 +1387,7 @@ let load_init_files dir =
files files
;; ;;
let common_init ~initial_env = let common_init ~initial_env : unit Lwt.t =
(* Initializes toplevel environment. *) (* Initializes toplevel environment. *)
(match initial_env with (match initial_env with
| None -> Toploop.initialize_toplevel_env () | None -> Toploop.initialize_toplevel_env ()
@ -1376,7 +1395,13 @@ let common_init ~initial_env =
(* Set the global input name. *) (* Set the global input name. *)
Location.input_name := UTop.input_name; Location.input_name := UTop.input_name;
(* Make sure SIGINT is catched while executing OCaml code. *) (* 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. *) (* Load system init files. *)
(match try Some (Sys.getenv "OCAML_TOPLEVEL_PATH") with Not_found -> None with (match try Some (Sys.getenv "OCAML_TOPLEVEL_PATH") with Not_found -> None with
| Some dir -> | Some dir ->
@ -1415,7 +1440,7 @@ let common_init ~initial_env =
ignore (toploop_use_silently Format.err_formatter fn : bool)); ignore (toploop_use_silently Format.err_formatter fn : bool));
(* Load history after the initialization file so the user can change (* Load history after the initialization file so the user can change
the history file name. *) the history file name. *)
Lwt_main.run (init_history ()); let* () = init_history () in
(* Install signal handlers. *) (* Install signal handlers. *)
let behavior = Sys.Signal_handle (fun signo -> raise (Term signo)) in let behavior = Sys.Signal_handle (fun signo -> raise (Term signo)) in
let catch signo = let catch signo =
@ -1428,7 +1453,8 @@ let common_init ~initial_env =
(* We lost the terminal. *) (* We lost the terminal. *)
catch Sys.sighup; catch Sys.sighup;
(* Termination request. *) (* Termination request. *)
catch Sys.sigterm catch Sys.sigterm;
return ()
let load_inputrc () = let load_inputrc () =
Lwt.catch Lwt.catch
@ -1442,52 +1468,66 @@ let load_inputrc () =
let protocol_version = 1 let protocol_version = 1
let main_aux ~initial_env = let main_aux ~initial_env : unit Lwt.t =
Arg.parse args file_argument usage; Arg.parse args file_argument usage;
#if OCAML_VERSION >= (5, 0, 0) && OCAML_VERSION < (5, 1, 0) #if OCAML_VERSION >= (5, 0, 0) && OCAML_VERSION < (5, 1, 0)
Topcommon.load_topdirs_signature (); Topcommon.load_topdirs_signature ();
#endif #endif
if not (prepare ()) then exit 2; if not (prepare ()) then exit 2;
if !emacs_mode then begin let* () = if !emacs_mode then begin
Printf.printf "protocol-version:%d\n%!" protocol_version; print_string "ERROR: emacs is todo lmao";
UTop_private.set_ui UTop_private.Emacs; exit 1
let module Emacs = Emacs (struct end) in (* Printf.printf "protocol-version:%d\n%!" protocol_version; *)
Printf.printf "Welcome to utop version %s (using OCaml version %s)!\n\n%!" UTop.version Sys.ocaml_version; (* UTop_private.set_ui UTop_private.Emacs; *)
common_init ~initial_env; (* let module Emacs = Emacs (struct end) in *)
Emacs.loop () (* 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 end else begin
UTop_private.set_ui UTop_private.Console; 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 if LTerm.incoming_is_a_tty term && LTerm.outgoing_is_a_tty term then begin
(* Set the initial size. *) (* Set the initial size. *)
UTop_private.set_size (S.const (LTerm.size term)); UTop_private.set_size (S.const (LTerm.size term));
(* Load user data. *) (* 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. *) (* Display a welcome message. *)
Lwt_main.run (welcome term); let* () = welcome term in
(* Common initialization. *) (* Common initialization. *)
common_init ~initial_env; let* () = common_init ~initial_env in
(* Print help message. *) (* Print help message. *)
print_string "\nType #utop_help for help about using utop.\n\n"; print_string "\nType #utop_help for help about using utop.\n\n";
flush stdout; flush stdout;
(* Main loop. *) (* Main loop. *)
try Lwt.catch
loop term (fun () -> loop term)
with LTerm_read_line.Interrupt -> (function
() | LTerm_read_line.Interrupt ->
return ()
| exn -> Lwt.fail exn)
end else begin end else begin
(* Use the standard toplevel. Just make sure that Lwt threads can (* Use the standard toplevel. Just make sure that Lwt threads can
run while reading phrases. *) run while reading phrases. *)
Toploop.read_interactive_input := read_input_classic; (* TODO: ??????? *)
Toploop.loop Format.std_formatter print_string "ERROR: stdout must be tty!";
exit 1
(* Toploop.read_interactive_input := read_input_classic; *)
(* Toploop.loop Format.std_formatter *)
end end
end; end in
(* Don't let the standard toplevel run... *) (* Don't let the standard toplevel run... *)
exit 0 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 try
main_aux ~initial_env main_start_loop ~initial_env
with exn -> with exn ->
(match exn with (match exn with
#if OCAML_VERSION >= (4,12,0) #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); List.iter Topdirs.dir_directory (search_path @ visible_paths);
let env = Envaux.env_of_only_summary env in let env = Envaux.env_of_only_summary env in
List.iter (fun (V (name, v)) -> Toploop.setvalue name (Obj.repr v)) values; 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 -> with exn ->
Location.report_exception Format.err_formatter exn; Location.report_exception Format.err_formatter exn;
exit 2 exit 2