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

Compare commits

base: haskal:d0d49d5de117b375cd5e6e162f69c3164d8e4042
Branches Tags
haskal:main
..
compare: haskal:232a8ffab32a83882c9b9119b1f9a61f56a39c71
Branches Tags
haskal:main

No commits in common. "d0d49d5de117b375cd5e6e162f69c3164d8e4042" and "232a8ffab32a83882c9b9119b1f9a61f56a39c71" have entirely different histories.
d0d49d5de1 ... 232a8ffab3

10 changed files with 412 additions and 565 deletions
Show Stats Expand all files Collapse all files

6
CHANGES.md
View File

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

2
dune-project
View File

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

1
dune-workspace.dev
View File

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

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 eio_main findlib.top lambda-term logs.lwt (libraries compiler-libs.toplevel findlib.top lambda-term logs.lwt threads
lwt_eio threads xdg zed) xdg zed)
(preprocess (preprocess
(action (action
(run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file})))) (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))))

23
src/lib/uTop.ml
View File

@ -288,8 +288,9 @@ let parse_default parse str eos_is_error =
| Syntaxerr.Ill_formed_ast (loc, s) -> | Syntaxerr.Ill_formed_ast (loc, s) ->
Error ([mkloc loc], Error ([mkloc loc],
Printf.sprintf "Error: broken invariant in parsetree: %s" s) Printf.sprintf "Error: broken invariant in parsetree: %s" s)
| Syntaxerr.Invalid_package_type (loc, err) -> | Syntaxerr.Invalid_package_type (loc, s) ->
Error ([mkloc loc], UTop_compat.invalid_package_error_to_string err) Error ([mkloc loc],
Printf.sprintf "Invalid package type: %s" s)
#if OCAML_VERSION >= (5, 0, 0) #if OCAML_VERSION >= (5, 0, 0)
| Syntaxerr.Removed_string_set loc -> | Syntaxerr.Removed_string_set loc ->
Error ([mkloc loc], Error ([mkloc loc],
@ -357,12 +358,11 @@ let check_phrase phrase =
let open Ast_helper in let open Ast_helper in
with_default_loc loc with_default_loc loc
(fun () -> (fun () ->
let punit = (Pat.construct unit None) in Str.eval
let body = (Exp.letmodule ~loc:loc (Exp.fun_ Nolabel None (Pat.construct unit None)
(with_loc loc (Some "_")) (Exp.letmodule (with_loc loc (Some "_"))
(Mod.structure (item :: items)) (Mod.structure (item :: items))
(Exp.construct unit None)) in (Exp.construct unit None))))
Str.eval (UTop_compat.Exp.fun_ ~loc punit body))
in in
let check_phrase = Ptop_def [top_def] in let check_phrase = Ptop_def [top_def] in
try try
@ -712,11 +712,11 @@ let print_error msg =
let handle_findlib_error = function let handle_findlib_error = function
| Failure msg -> | Failure msg ->
UTop_compat.lwt_eio_shim (print_error msg) Lwt_main.run (print_error msg)
| Fl_package_base.No_such_package(pkg, reason) -> | Fl_package_base.No_such_package(pkg, reason) ->
UTop_compat.lwt_eio_shim (print_error (Printf.sprintf "No such package: %s%s\n" pkg (if reason <> "" then " - " ^ reason else ""))) Lwt_main.run (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 ->
UTop_compat.lwt_eio_shim (print_error (Printf.sprintf "Package requires itself: %s\n" pkg)) Lwt_main.run (print_error (Printf.sprintf "Package requires itself: %s\n" pkg))
| exn -> | exn ->
raise exn raise exn
@ -828,8 +828,7 @@ let () =
| Compiler-libs re-exports | | Compiler-libs re-exports |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
let get_load_path = UTop_compat.get_load_path let get_load_path () = Load_path.get_paths ()
let set_load_path = UTop_compat.set_load_path let set_load_path = UTop_compat.set_load_path
module Private = struct module Private = struct

107
src/lib/uTop_compat.ml
View File

@ -19,21 +19,11 @@ let toploop_all_directive_names () =
Hashtbl.fold (fun dir _ acc -> dir::acc) Toploop.directive_table [] Hashtbl.fold (fun dir _ acc -> dir::acc) Toploop.directive_table []
#endif #endif
let get_load_path () = let set_load_path path =
#if OCAML_VERSION >= (5, 2, 0) #if OCAML_VERSION >= (5, 0, 0)
let {Load_path.visible; hidden} = Load_path.get_paths () in Load_path.init path ~auto_include:Load_path.no_auto_include
visible @ hidden
#else #else
Load_path.get_paths () Load_path.init path
#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 #endif
let toploop_use_silently fmt name = let toploop_use_silently fmt name =
@ -65,92 +55,3 @@ let rec is_persistent_path = function
#if OCAML_VERSION >= (5, 1, 0) #if OCAML_VERSION >= (5, 1, 0)
| Path.Pextra_ty (p, _) -> is_persistent_path p | Path.Pextra_ty (p, _) -> is_persistent_path p
#endif #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

14
src/lib/uTop_complete.ml
View File

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

2
src/lib/uTop_lexer.mll
View File

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

779
src/lib/uTop_main.ml
View File

@ -9,8 +9,6 @@
[@@@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
@ -337,7 +335,14 @@ end = struct
let scan_cmis = let scan_cmis =
let new_cmis = ref [] in let new_cmis = ref [] in
UTop_compat.add_cmi_hook (fun cmi -> new_cmis := cmi :: !new_cmis ); 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;
fun pp -> fun pp ->
List.iter (fun (cmi : Cmi_format.cmi_infos) -> List.iter (fun (cmi : Cmi_format.cmi_infos) ->
walk_sig pp ~path:(Longident.Lident cmi.cmi_name) cmi.cmi_sign walk_sig pp ~path:(Longident.Lident cmi.cmi_name) cmi.cmi_sign
@ -531,8 +536,7 @@ 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"))
@ -541,11 +545,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_eio_lwt_run_in_main]; required_values = [longident_lwt_main_run];
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_eio_lwt_run_in_main)) [(Nolabel, e)] Exp.apply (Exp.ident (with_loc loc longident_lwt_main_run)) [(Nolabel, e)]
) )
); );
enabled = UTop.auto_run_lwt; enabled = UTop.auto_run_lwt;
@ -563,7 +567,7 @@ let rewrite_rules = [
with_default_loc loc (fun () -> with_default_loc loc (fun () ->
Exp.apply Exp.apply
(Exp.ident (with_loc loc longident_async_thread_safe_block_on_async_exn)) (Exp.ident (with_loc loc longident_async_thread_safe_block_on_async_exn))
[(Nolabel, UTop_compat.Exp.fun_ ~loc punit e)] [(Nolabel, Exp.fun_ Nolabel None punit e)]
) )
); );
enabled = UTop.auto_run_async; enabled = UTop.auto_run_async;
@ -578,10 +582,10 @@ let rule_path rule =
let env = !Toploop.toplevel_env in let env = !Toploop.toplevel_env in
let path = let path =
match Env.find_type_by_name rule.type_to_rewrite env with match Env.find_type_by_name rule.type_to_rewrite env with
| path, { Types.type_kind = type_kind | path, { Types.type_kind = Types.Type_abstract
; Types.type_private = Asttypes.Public ; Types.type_private = Asttypes.Public
; Types.type_manifest = Some ty ; Types.type_manifest = Some ty
} when type_kind = UTop_compat.abstract_type_kind -> begin } -> begin
match get_desc (Ctype.expand_head env ty) with match get_desc (Ctype.expand_head env ty) with
| Types.Tconstr (path, _, _) -> path | Types.Tconstr (path, _, _) -> path
| _ -> path | _ -> path
@ -717,9 +721,7 @@ 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 cancel_user_code : unit Lazy.t option ref = ref None let rec loop term =
let rec loop term : unit Lwt.t =
(* Reset completion. *) (* Reset completion. *)
UTop_complete.reset (); UTop_complete.reset ();
@ -730,8 +732,8 @@ let rec loop term : unit Lwt.t =
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) ->
@ -765,23 +767,11 @@ let rec loop term : unit Lwt.t =
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;
let* () = begin try (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;
let* () = Lwt_eio.run_eio ignore (execute_phrase true pp phrase);
(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. *) (* Flush everything. *)
Format.pp_print_flush Format.std_formatter (); Format.pp_print_flush Format.std_formatter ();
Format.pp_print_flush Format.err_formatter (); Format.pp_print_flush Format.err_formatter ();
@ -794,10 +784,10 @@ let rec loop term : unit Lwt.t =
match phrase with match phrase with
| Parsetree.Ptop_def _ -> | Parsetree.Ptop_def _ ->
(* The string is an output phrase, colorize it. *) (* The string is an output phrase, colorize it. *)
render_out_phrase term string Lwt_main.run (render_out_phrase term string)
| Parsetree.Ptop_dir _ -> | Parsetree.Ptop_dir _ ->
(* The string is an error message. *) (* The string is an error message. *)
print_error term string Lwt_main.run (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
@ -809,8 +799,7 @@ let rec loop term : unit Lwt.t =
with Not_found -> with Not_found ->
msg msg
in in
print_error term msg Lwt_main.run (print_error term msg));
end in
loop term loop term
| None -> | None ->
loop term loop term
@ -854,330 +843,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 |
@ -1231,16 +1220,15 @@ let typeof sid =
in in
match out_sig_item with match out_sig_item with
| None -> | None ->
UTop_compat.lwt_eio_shim Lwt_main.run (Lazy.force LTerm.stdout >>= fun term ->
(Lazy.force LTerm.stdout >>= fun term -> print_error term "Unknown type\n") 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
UTop_compat.lwt_eio_shim Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> render_out_phrase term str)
(Lazy.force LTerm.stdout >>= fun term -> render_out_phrase term str)
let default_info = { let default_info = {
Toploop.section = "UTop"; Toploop.section = "UTop";
@ -1387,7 +1375,7 @@ let load_init_files dir =
files files
;; ;;
let common_init ~initial_env : unit Lwt.t = let common_init ~initial_env =
(* Initializes toplevel environment. *) (* Initializes toplevel environment. *)
(match initial_env with (match initial_env with
| None -> Toploop.initialize_toplevel_env () | None -> Toploop.initialize_toplevel_env ()
@ -1395,13 +1383,7 @@ let common_init ~initial_env : unit Lwt.t =
(* 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.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> Sys.catch_break true;
(* 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 ->
@ -1440,7 +1422,7 @@ let common_init ~initial_env : unit Lwt.t =
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. *)
let* () = init_history () in Lwt_main.run (init_history ());
(* 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 =
@ -1453,8 +1435,7 @@ let common_init ~initial_env : unit Lwt.t =
(* 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
@ -1468,66 +1449,52 @@ let load_inputrc () =
let protocol_version = 1 let protocol_version = 1
let main_aux ~initial_env : unit Lwt.t = let main_aux ~initial_env =
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;
let* () = if !emacs_mode then begin if !emacs_mode then begin
print_string "ERROR: emacs is todo lmao"; Printf.printf "protocol-version:%d\n%!" protocol_version;
exit 1 UTop_private.set_ui UTop_private.Emacs;
(* Printf.printf "protocol-version:%d\n%!" protocol_version; *) let module Emacs = Emacs (struct end) in
(* UTop_private.set_ui UTop_private.Emacs; *) Printf.printf "Welcome to utop version %s (using OCaml version %s)!\n\n%!" UTop.version Sys.ocaml_version;
(* let module Emacs = Emacs (struct end) in *) common_init ~initial_env;
(* Printf.printf "Welcome to utop version %s (using OCaml version %s)!\n\n%!" UTop.version Sys.ocaml_version; *) Emacs.loop ()
(* 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 = Lazy.force LTerm.stdout in let term = Lwt_main.run (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. *)
let* () = Lwt.join [UTop_styles.load (); load_inputrc ()] in Lwt_main.run (Lwt.join [UTop_styles.load (); load_inputrc ()]);
(* Display a welcome message. *) (* Display a welcome message. *)
let* () = welcome term in Lwt_main.run (welcome term);
(* Common initialization. *) (* Common initialization. *)
let* () = common_init ~initial_env in common_init ~initial_env;
(* 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. *)
Lwt.catch try
(fun () -> loop term) loop term
(function with LTerm_read_line.Interrupt ->
| 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. *)
(* TODO: ??????? *) Toploop.read_interactive_input := read_input_classic;
print_string "ERROR: stdout must be tty!"; Toploop.loop Format.std_formatter
exit 1
(* Toploop.read_interactive_input := read_input_classic; *)
(* Toploop.loop Format.std_formatter *)
end end
end in end;
(* Don't let the standard toplevel run... *) (* Don't let the standard toplevel run... *)
exit 0 exit 0
let main_start_loop ~initial_env : unit = let main_internal ~initial_env =
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_start_loop ~initial_env main_aux ~initial_env
with exn -> with exn ->
(match exn with (match exn with
#if OCAML_VERSION >= (4,12,0) #if OCAML_VERSION >= (4,12,0)
@ -1578,8 +1545,7 @@ 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 search_path = walk build_dir ~init:search_path ~f:(fun dir acc -> dir :: acc) in
let cmt_fname = let cmt_fname =
try try
UTop_compat.find_in_path_normalized Misc.find_in_path_uncap search_path (unit ^ ".cmt")
search_path (unit ^ ".cmt")
with Not_found -> with Not_found ->
Printf.ksprintf failwith "%s.cmt not found in search path!" unit Printf.ksprintf failwith "%s.cmt not found in search path!" unit
in in
@ -1611,11 +1577,10 @@ let interact ?(search_path=[]) ?(build_dir="_build") ~unit ~loc:(fname, lnum, cn
failwith "Couldn't find location in cmt file" failwith "Couldn't find location in cmt file"
with Found env -> with Found env ->
try try
let visible_paths = UTop_compat.visible_paths_for_cmt_infos cmt_infos in List.iter Topdirs.dir_directory (search_path @ cmt_infos.cmt_loadpath);
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;
(fun () -> main_internal ~initial_env:(Some env)) 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

5
utop.opam
View File

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