diff --git a/src/lib/dune b/src/lib/dune index 1e1658e..6e83b2b 100644 --- a/src/lib/dune +++ b/src/lib/dune @@ -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})))) diff --git a/src/lib/uTop.ml b/src/lib/uTop.ml index 801fd29..e1b24b9 100644 --- a/src/lib/uTop.ml +++ b/src/lib/uTop.ml @@ -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 diff --git a/src/lib/uTop_compat.ml b/src/lib/uTop_compat.ml index b294cbe..d9f3a66 100644 --- a/src/lib/uTop_compat.ml +++ b/src/lib/uTop_compat.ml @@ -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 + diff --git a/src/lib/uTop_main.ml b/src/lib/uTop_main.ml index 3018681..161dbf4 100644 --- a/src/lib/uTop_main.ml +++ b/src/lib/uTop_main.ml @@ -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