diff --git a/CHANGES.md b/CHANGES.md index 6ccc2d8..ece3923 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,9 @@ +unreleased +---------- + +* Add support for OCaml 5.2 (#470, fixes #466, @leostera, @ManasJayanth, + @huwaireb) + 2.13.1 (2023-07-07) ------------------- diff --git a/dune-workspace.dev b/dune-workspace.dev index 19ad9d9..d793f42 100644 --- a/dune-workspace.dev +++ b/dune-workspace.dev @@ -5,3 +5,4 @@ (context (opam (switch utop-414))) (context (opam (switch utop-500))) (context (opam (switch utop-510))) +(context (opam (switch utop-520))) diff --git a/src/lib/uTop.ml b/src/lib/uTop.ml index dafcd72..801fd29 100644 --- a/src/lib/uTop.ml +++ b/src/lib/uTop.ml @@ -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 diff --git a/src/lib/uTop_compat.ml b/src/lib/uTop_compat.ml index 23c66a9..b294cbe 100644 --- a/src/lib/uTop_compat.ml +++ b/src/lib/uTop_compat.ml @@ -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 + diff --git a/src/lib/uTop_complete.ml b/src/lib/uTop_complete.ml index 4a5794a..7f480dd 100644 --- a/src/lib/uTop_complete.ml +++ b/src/lib/uTop_complete.ml @@ -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) diff --git a/src/lib/uTop_main.ml b/src/lib/uTop_main.ml index e786f54..3018681 100644 --- a/src/lib/uTop_main.ml +++ b/src/lib/uTop_main.ml @@ -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)