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

feat: make it work on ocaml 5.2 (#470) 

Co-authored-by: Rashid Al Muhairi <r.muhairi@pm.me>
This commit is contained in:
Leandro Ostera 2024-02-06 12:51:52 +01:00 committed by GitHub
parent 232a8ffab3
commit 4a97c4c2e9
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
6 changed files with 126 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
CHANGES.md
View File

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

1
dune-workspace.dev
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)))

17
src/lib/uTop.ml
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
@ -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

95
src/lib/uTop_compat.ml
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,80 @@ 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

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

21
src/lib/uTop_main.ml
View File

@ -335,14 +335,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
@ -567,7 +560,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 +575,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
@ -1545,7 +1538,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,7 +1571,8 @@ 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)