Compare commits

...

5 Commits

Author SHA1 Message Date
xenia d0d49d5de1 WIP add eio support 2024-04-22 00:15:45 -04:00
tuohy 384b3098c8
Parse escaped escapes before escaped quotes (#449) 2024-04-03 09:57:37 +08:00
Etienne Millon 6b9220d0d7
bump lang dune to 2.7 (#480)
This fixes the `dune subst` instructions.
2024-02-27 14:13:53 +01:00
Etienne Millon d4f6f5f733 Prepare 2.14.0 2024-02-26 14:08:09 +01:00
Leandro Ostera 4a97c4c2e9
feat: make it work on ocaml 5.2 (#470)
Co-authored-by: Rashid Al Muhairi <r.muhairi@pm.me>
2024-02-06 12:51:52 +01:00
10 changed files with 565 additions and 412 deletions

View File

@ -1,3 +1,9 @@
2.14.0 (2024-02-26)
-------------------
* Add support for OCaml 5.2 (#470, fixes #466, @leostera, @ManasJayanth,
@huwaireb)
2.13.1 (2023-07-07)
-------------------

View File

@ -1,4 +1,4 @@
(lang dune 2.0)
(lang dune 2.7)
(formatting (enabled_for dune))
(name utop)

View File

@ -5,3 +5,4 @@
(context (opam (switch utop-414)))
(context (opam (switch utop-500)))
(context (opam (switch utop-510)))
(context (opam (switch utop-520)))

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

View File

@ -288,9 +288,8 @@ let parse_default parse str eos_is_error =
| Syntaxerr.Ill_formed_ast (loc, s) ->
Error ([mkloc loc],
Printf.sprintf "Error: broken invariant in parsetree: %s" s)
| Syntaxerr.Invalid_package_type (loc, s) ->
Error ([mkloc loc],
Printf.sprintf "Invalid package type: %s" s)
| Syntaxerr.Invalid_package_type (loc, err) ->
Error ([mkloc loc], UTop_compat.invalid_package_error_to_string err)
#if OCAML_VERSION >= (5, 0, 0)
| Syntaxerr.Removed_string_set loc ->
Error ([mkloc loc],
@ -358,11 +357,12 @@ let check_phrase phrase =
let open Ast_helper in
with_default_loc loc
(fun () ->
Str.eval
(Exp.fun_ Nolabel None (Pat.construct unit None)
(Exp.letmodule (with_loc loc (Some "_"))
let punit = (Pat.construct unit None) in
let body = (Exp.letmodule ~loc:loc
(with_loc loc (Some "_"))
(Mod.structure (item :: items))
(Exp.construct unit None))))
(Exp.construct unit None)) in
Str.eval (UTop_compat.Exp.fun_ ~loc punit body))
in
let check_phrase = Ptop_def [top_def] in
try
@ -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
@ -828,7 +828,8 @@ let () =
| Compiler-libs re-exports |
+-----------------------------------------------------------------+ *)
let get_load_path () = Load_path.get_paths ()
let get_load_path = UTop_compat.get_load_path
let set_load_path = UTop_compat.set_load_path
module Private = struct

View File

@ -19,11 +19,21 @@ let toploop_all_directive_names () =
Hashtbl.fold (fun dir _ acc -> dir::acc) Toploop.directive_table []
#endif
let set_load_path path =
#if OCAML_VERSION >= (5, 0, 0)
Load_path.init path ~auto_include:Load_path.no_auto_include
let get_load_path () =
#if OCAML_VERSION >= (5, 2, 0)
let {Load_path.visible; hidden} = Load_path.get_paths () in
visible @ hidden
#else
Load_path.init path
Load_path.get_paths ()
#endif
let set_load_path visible =
#if OCAML_VERSION >= (5, 2, 0)
Load_path.init ~auto_include:Load_path.no_auto_include ~visible ~hidden:[]
#elif OCAML_VERSION >= (5, 0, 0)
Load_path.init ~auto_include:Load_path.no_auto_include visible
#else
Load_path.init visible
#endif
let toploop_use_silently fmt name =
@ -55,3 +65,92 @@ let rec is_persistent_path = function
#if OCAML_VERSION >= (5, 1, 0)
| Path.Pextra_ty (p, _) -> is_persistent_path p
#endif
let invalid_package_error_to_string err =
#if OCAML_VERSION >= (5, 2, 0)
(* NOTE: from https://github.com/ocaml/ocaml/blob/9b059b1e7a66e9d2f04d892a4de34c418cd96f69/parsing/parse.ml#L149 *)
let invalid ppf ipt = match ipt with
| Syntaxerr.Parameterized_types ->
Format.fprintf ppf "parametrized types are not supported"
| Constrained_types ->
Format.fprintf ppf "constrained types are not supported"
| Private_types ->
Format.fprintf ppf "private types are not supported"
| Not_with_type ->
Format.fprintf ppf "only %a constraints are supported"
Misc.Style.inline_code "with type t ="
| Neither_identifier_nor_with_type ->
Format.fprintf ppf
"only module type identifier and %a constraints are supported"
Misc.Style.inline_code "with type"
in
let buf = Buffer.create 128 in
let fmt = Format.formatter_of_buffer buf in
Format.fprintf fmt "Invalid package type: %a%!" invalid err;
Buffer.contents buf
#else
err
#endif
module Exp = struct
open Ast_helper
#if OCAML_VERSION >= (5, 2, 0)
open Parsetree
let fun_ ~loc p e =
let args = [{
pparam_loc=loc;
pparam_desc=Pparam_val (Nolabel, None, p);
}] in
(Exp.function_ args None (Pfunction_body e))
#else
let fun_ ~loc p e = Exp.fun_ ~loc Nolabel None p e
#endif
end
let abstract_type_kind =
#if OCAML_VERSION >= (5, 2, 0)
Types.(Type_abstract Definition)
#else
Types.Type_abstract
#endif
let find_in_path_normalized =
#if OCAML_VERSION >= (5, 2, 0)
Misc.find_in_path_normalized
#else
Misc.find_in_path_uncap
#endif
let visible_paths_for_cmt_infos (cmt_infos: Cmt_format.cmt_infos) =
#if OCAML_VERSION >= (5, 2, 0)
cmt_infos.cmt_loadpath.visible
#else
cmt_infos.cmt_loadpath
#endif
let add_cmi_hook f =
let default_load = !Persistent_env.Persistent_signature.load in
#if OCAML_VERSION >= (5, 2, 0)
let load ~allow_hidden ~unit_name =
let res = default_load ~unit_name ~allow_hidden in
#else
let load ~unit_name =
let res = default_load ~unit_name in
#endif
(match res with None -> () | Some x -> f x.cmi);
res
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

View File

@ -394,7 +394,7 @@ let visible_modules () =
(Sys.readdir (if dir = "" then Filename.current_dir_name else dir))
with Sys_error _ ->
acc)
String_set.empty @@ Load_path.get_paths ()
String_set.empty @@ UTop_compat.get_load_path ()
)
let field_name { ld_id = id } = Ident.name id
@ -406,7 +406,11 @@ let add_fields_of_type decl acc =
acc
| Type_record (fields, _) ->
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
#if OCAML_VERSION >= (5, 2, 0)
| Type_abstract _ ->
#else
| Type_abstract ->
#endif
acc
| Type_open ->
acc
@ -421,7 +425,11 @@ let add_names_of_type decl acc =
List.fold_left (fun acc cstr -> add (constructor_name cstr) acc) acc constructors
| Type_record (fields, _) ->
List.fold_left (fun acc field -> add (field_name field) acc) acc fields
#if OCAML_VERSION >= (5, 2, 0)
| Type_abstract _ ->
#else
| Type_abstract ->
#endif
acc
| Type_open ->
acc
@ -839,7 +847,7 @@ let complete ~phrase_terminator ~input =
(fun acc d -> add_files filter acc (Filename.concat d dir))
String_map.empty
(Filename.current_dir_name ::
(Load_path.get_paths ())
(UTop_compat.get_load_path ())
)
else
@ -899,7 +907,7 @@ let complete ~phrase_terminator ~input =
(fun acc d -> add_files filter acc (Filename.concat d dir))
String_map.empty
(Filename.current_dir_name ::
(Load_path.get_paths ())
(UTop_compat.get_load_path ())
)
else
add_files filter String_map.empty (Filename.dirname file)

View File

@ -173,6 +173,7 @@ and symbol idx acc = parse
and cm_string idx= parse
| '"'
{ (String (1, true), idx+1) }
| "\\\\"
| "\\\""
{ let idx2, terminated= string (idx + 2) false lexbuf in
(String (1, terminated), idx2)
@ -222,6 +223,7 @@ and comment idx depth combining= parse
and string idx combining= parse
| '"'
{ (idx + 1, true) }
| "\\\\"
| "\\\""
{ string (idx + 2) false lexbuf }
| uchar as uchar

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
@ -335,14 +337,7 @@ end = struct
let scan_cmis =
let new_cmis = ref [] in
let default_load = !Persistent_env.Persistent_signature.load in
let load ~unit_name =
let res = default_load ~unit_name in
(match res with None -> () | Some x -> new_cmis := x.cmi :: !new_cmis);
res
in
Persistent_env.Persistent_signature.load := load;
UTop_compat.add_cmi_hook (fun cmi -> new_cmis := cmi :: !new_cmis );
fun pp ->
List.iter (fun (cmi : Cmi_format.cmi_infos) ->
walk_sig pp ~path:(Longident.Lident cmi.cmi_name) cmi.cmi_sign
@ -536,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"))
@ -545,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;
@ -567,7 +563,7 @@ let rewrite_rules = [
with_default_loc loc (fun () ->
Exp.apply
(Exp.ident (with_loc loc longident_async_thread_safe_block_on_async_exn))
[(Nolabel, Exp.fun_ Nolabel None punit e)]
[(Nolabel, UTop_compat.Exp.fun_ ~loc punit e)]
)
);
enabled = UTop.auto_run_async;
@ -582,10 +578,10 @@ let rule_path rule =
let env = !Toploop.toplevel_env in
let path =
match Env.find_type_by_name rule.type_to_rewrite env with
| path, { Types.type_kind = Types.Type_abstract
| path, { Types.type_kind = type_kind
; Types.type_private = Asttypes.Public
; Types.type_manifest = Some ty
} -> begin
} when type_kind = UTop_compat.abstract_type_kind -> begin
match get_desc (Ctype.expand_head env ty) with
| Types.Tconstr (path, _, _) -> path
| _ -> path
@ -721,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 ();
@ -732,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) ->
@ -767,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
@ -799,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
@ -843,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 |
@ -1220,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";
@ -1375,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 ()
@ -1383,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 ->
@ -1422,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 =
@ -1435,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
@ -1449,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)
@ -1545,7 +1578,8 @@ let interact ?(search_path=[]) ?(build_dir="_build") ~unit ~loc:(fname, lnum, cn
let search_path = walk build_dir ~init:search_path ~f:(fun dir acc -> dir :: acc) in
let cmt_fname =
try
Misc.find_in_path_uncap search_path (unit ^ ".cmt")
UTop_compat.find_in_path_normalized
search_path (unit ^ ".cmt")
with Not_found ->
Printf.ksprintf failwith "%s.cmt not found in search path!" unit
in
@ -1577,10 +1611,11 @@ let interact ?(search_path=[]) ?(build_dir="_build") ~unit ~loc:(fname, lnum, cn
failwith "Couldn't find location in cmt file"
with Found env ->
try
List.iter Topdirs.dir_directory (search_path @ cmt_infos.cmt_loadpath);
let visible_paths = UTop_compat.visible_paths_for_cmt_infos cmt_infos in
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

View File

@ -10,7 +10,7 @@ homepage: "https://github.com/ocaml-community/utop"
doc: "https://ocaml-community.github.io/utop/"
bug-reports: "https://github.com/ocaml-community/utop/issues"
depends: [
"dune" {>= "2.0"}
"dune" {>= "2.7"}
"ocaml" {>= "4.11.0"}
"base-unix"
"base-threads"
@ -24,9 +24,10 @@ depends: [
"cppo" {>= "1.1.2"}
"alcotest" {with-test}
"xdg" {>= "3.9.0"}
"odoc" {with-doc}
]
build: [
["dune" "subst"] {pinned}
["dune" "subst"] {dev}
[
"dune"
"build"