Merge pull request #100 from Octachron/Support_OCaml_5.4

Update for 5.4

Author: gasche

CHANGES.md

@@ -14,6 +14,11 @@ Unreleased
   type%import loc = Location.t
   ```
 
+  * Support for OCaml 5.4 (???, @octachron)
+
+1.11.0
+------
+
   * Support for OCaml 5.2 (#94, @kit-ty-kate)
 
 1.10.0

src/compat/gen.ml

@@ -17,7 +17,10 @@ let include_table =
   ; ("types_type_kind", [(5, 2); (4, 13)])
   ; ("init_path", [(4, 9)])
   ; ("env_lookup", [(4, 10)])
-  ; ("types_desc", [(4, 14)]) ]
+  ; ("types_desc", [(4, 14)])
+  ; ("tuple", [5,4])
+  ; ("longident", [5,4])
+  ]
 
 let rec gen_compat real_version (f_prefix, version_list) =
   match version_list with

src/compat/longident_ge_000.ml

@@ -0,0 +1,2 @@
+let longident_inj x = x
+let longident_proj x = x

src/compat/longident_ge_504.ml

@@ -0,0 +1,2 @@
+let longident_inj = Location.mknoloc
+let longident_proj x = x.Location.txt

src/compat/tuple_ge_000.ml

@@ -0,0 +1,2 @@
+let tuple f xs =
+  Ppxlib.Ast_helper.Typ.tuple (List.map (fun x -> f x) xs)

src/compat/tuple_ge_504.ml

@@ -0,0 +1,2 @@
+let tuple f xs =
+  Ppxlib.Ast_helper.Typ.tuple (List.map (fun (_,x) -> f x) xs)

src/ppx_import.ml

@@ -33,14 +33,17 @@ let lazy_env =
       Compat.init_path ();
       Ocaml_common.Compmisc.initial_env () )
 
-let string_of_lid lid =
-  let rec print lid acc =
-    match lid with
-    | Longident.Lident s -> s :: acc
-    | Longident.Ldot (lid, id) -> print lid ("." :: id :: acc)
-    | Longident.Lapply (la, lb) -> print la ("(" :: print lb (")" :: acc))
-  in
-  String.concat "" (print lid [])
+let string_of_lid' lid = Format.asprintf "%a" Pprintast.longident lid
+let string_of_lid lid = Format.asprintf "%a" Astlib.Pprintast.longident lid
+
+(* Remove locations *)
+let rec longident_without_loc =
+  let proj x = Compat.longident_proj x in
+  let conv x = longident_without_loc (proj x) in
+  function
+  | Longident.Ldot (x,y) -> Astlib.Longident.Ldot (conv x, proj y)
+  | Longident.Lapply (f,x) ->  Astlib.Longident.Lapply (conv f, conv x)
+  | Longident.Lident x -> Astlib.Longident.Lident x
 
 let try_find_module ~loc env lid =
   (* Note: we are careful to call `Env.lookup_module` and not
@@ -75,7 +78,7 @@ let try_find_module_type ~loc env lid =
         let error =
           Printf.sprintf
             "[%%import]: cannot access the signature of the abstract module %s"
-            (string_of_lid lid)
+            (string_of_lid' lid)
         in
         raise_error ~loc error
       | Some module_type -> module_type )
@@ -106,7 +109,7 @@ let locate_sig ~loc env lid =
   let head, path =
     try
       match Ppxlib.Longident.flatten_exn lid with
-      | head :: path -> (Longident.Lident head, path)
+      | head :: path -> (head, path)
       | _ -> assert false
     with Invalid_argument _ ->
       let error =
@@ -115,9 +118,9 @@ let locate_sig ~loc env lid =
       in
       raise_error ~loc error
   in
+  let chead = Longident.Lident head in
   let head_module_type =
-    match
-      (try_find_module ~loc env head, lazy (try_find_module_type ~loc env head))
+    match (try_find_module ~loc env chead, lazy (try_find_module_type ~loc env chead))
     with
     | Some mty, _ -> mty
     | None, (lazy (Some mty)) -> mty
@@ -147,10 +150,10 @@ let locate_sig ~loc env lid =
     let sub_module_type =
       loop (List.map Compat.migrate_signature_item sig_items)
     in
-    (Longident.Ldot (lid, path_item), sub_module_type)
+    (Astlib.Longident.Ldot(lid,path_item), sub_module_type)
   in
   let _lid, sub_module_type =
-    List.fold_left get_sub_module_type (head, head_module_type) path
+    List.fold_left get_sub_module_type (Astlib.Longident.Lident head, head_module_type) path
   in
   open_module_type ~loc env lid sub_module_type
 
@@ -193,7 +196,7 @@ let get_modtype_decl ~loc sig_items parent_lid elem =
     raise_error ~loc error
   | Some decl -> decl
 
-let longident_of_path = Untypeast.lident_of_path
+let longident_of_path x = longident_without_loc (Untypeast.lident_of_path x)
 
 let mknoloc (txt : 'a) : 'a Ppxlib.Location.loc =
   {txt; loc = Ppxlib.Location.none}
@@ -216,8 +219,7 @@ let rec core_type_of_type_expr ~subst (type_expr : Ocaml_common.Types.type_expr)
       | _ -> lhs
     in
     Ppxlib.Ast_helper.Typ.arrow label lhs (core_type_of_type_expr ~subst rhs)
-  | Ttuple xs ->
-    Ppxlib.Ast_helper.Typ.tuple (List.map (core_type_of_type_expr ~subst) xs)
+  | Ttuple xs -> Compat.tuple (core_type_of_type_expr ~subst) xs
   | Tconstr (path, args, _) -> (
     let lid = longident_of_path path in
     let args = List.map (core_type_of_type_expr ~subst) args in
@@ -426,11 +428,11 @@ let type_declaration ~tool_name ~input_name (type_decl : Ppxlib.type_declaration
                     (string_of_lid lid)
                 in
                 raise_error ~loc error
-              | Lident _ as head_id ->
+              | Lident hid ->
                 (* In this case, we know for sure that the user intends this lident
                    as a type name, so we use Typetexp.find_type and let the failure
                    cases propagate to the user. *)
-                Compat.find_type env ~loc head_id |> snd
+                Compat.find_type env ~loc (Lident hid) |> snd
               | Ldot (parent_id, elem) ->
                 let sig_items = locate_sig ~loc env parent_id in
                 get_type_decl ~loc sig_items parent_id elem
@@ -531,11 +533,11 @@ let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) =
                   (string_of_lid lid)
               in
               raise_error ~loc error
-            | Longident.Lident _ as head_id ->
+            | Longident.Lident head_id ->
               (* In this case, we know for sure that the user intends this lident
                  as a module type name, so we use Typetexp.find_type and
                  let the failure cases propagate to the user. *)
-              Compat.find_modtype env ~loc head_id |> snd
+              Compat.find_modtype env ~loc (Lident head_id) |> snd
             | Longident.Ldot (parent_id, elem) ->
               let sig_items = locate_sig ~loc env parent_id in
               get_modtype_decl ~loc sig_items parent_id elem

src_test/ppx_deriving/test_ppx_import.ml

@@ -40,6 +40,12 @@ module Test_optional : S_optional = struct
   let f ?(opt = 0) () = ignore opt
 end
 
+module Location = struct
+  type t = Location.t
+  let pp = Location.print_loc
+  [%%import type 'a loc = 'a Location.loc [@@deriving show]]
+end
+
 [%%import: type longident = Longident.t [@@deriving show]]
 
 [%%import:
@@ -49,9 +55,12 @@ type package_type =
     core_type := (Parsetree.core_type [@printer Pprintast.core_type]);
     Asttypes.loc :=
       (Asttypes.loc [@polyprinter fun pp fmt x -> pp fmt x.Asttypes.txt]);
-    Longident.t := (Longident.t [@printer pp_longident])] )
+    Longident.t := (Longident.t [@printer pp_longident]);
+     attributes := (Parsetree.attributes [@printer (fun _ _ -> ())])
+   ])
 [@@deriving show]]
 
+
 module type Hashable = [%import: (module Hashtbl.HashedType)]
 
 [%%import: type self_t = Test_self_import.t]