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

Co-authored-by: Rashid Al Muhairi <[email protected]>

Author: leostera

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

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

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

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.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 path
+  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
+

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)

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)