TMP: Wrap encoded external types in extensions

Signed-off-by: Nathan Rebours <nathan.rebours@ocamlpro.com>

Author: Nathan Rebours

astlib/encoding_505.ml

@@ -5,6 +5,9 @@ module Ext_name = struct
   let ptyp_functor = "ppxlib.migration.ptyp_functor_5_5"
   let preserve_ppat_constraint = "ppxlib.migration.preserve_ppat_constraint_5_5"
   let ptype_kind_external = "ppxlib.migration.ptype_kind_external_5_5"
+  let external_psig = "ppxlib.migration.external_psig_5_5"
+  let external_pstr_type = "ppxlib.migration.external_pstr_type_5_5"
+  let external_pmty_with = "ppxlib.migration.external_pmty_with_5_5"
 end
 
 let invalid_encoding ~loc name =
@@ -104,6 +107,84 @@ module To_504 = struct
         Some (name, ptype_attributes)
     | _ -> None
 
+  let encode_external_psig ~loc psig_desc =
+    let loc = { loc with Location.loc_ghost = true } in
+    let ext =
+      ( { txt = Ext_name.external_psig; loc },
+        PSig [ { psig_loc = loc; psig_desc } ] )
+    in
+    Psig_extension (ext, [])
+
+  let encode_external_psig_type ~loc rec_flag tds =
+    encode_external_psig ~loc (Psig_type (rec_flag, tds))
+
+  let encode_external_psig_typesubst ~loc tds =
+    encode_external_psig ~loc (Psig_typesubst tds)
+
+  let decode_external_psig ~loc payload attrs =
+    match (payload, attrs) with
+    | PSig [ { psig_desc = (Psig_type _ | Psig_typesubst _) as res; _ } ], [] ->
+        res
+    | _ -> invalid_encoding ~loc "external type signature_item_desc"
+
+  let encode_external_pstr_type ~loc rec_flag tds =
+    let loc = { loc with Location.loc_ghost = true } in
+    let pstr_desc = Pstr_type (rec_flag, tds) in
+    let ext =
+      ( { txt = Ext_name.external_pstr_type; loc },
+        PStr [ { pstr_loc = loc; pstr_desc } ] )
+    in
+    Pstr_extension (ext, [])
+
+  let decode_external_pstr_type ~loc payload attrs =
+    match (payload, attrs) with
+    | PStr [ { pstr_desc = Pstr_type _ as res; _ } ], [] -> res
+    | _ -> invalid_encoding ~loc "external type pstr_type"
+
+  let encode_external_pmty_with ~loc mty constraints =
+    let loc = { loc with Location.loc_ghost = true } in
+    let pmd_type =
+      {
+        pmty_loc = loc;
+        pmty_attributes = [];
+        pmty_desc = Pmty_with (mty, constraints);
+      }
+    in
+    let psig_desc =
+      Psig_module
+        {
+          pmd_name = { txt = None; loc };
+          pmd_type;
+          pmd_attributes = [];
+          pmd_loc = loc;
+        }
+    in
+    let ext =
+      ( { txt = Ext_name.external_pmty_with; loc },
+        PSig [ { psig_loc = loc; psig_desc } ] )
+    in
+    Pmty_extension ext
+
+  let decode_external_pmty_with ~loc payload =
+    match payload with
+    | PSig
+        [
+          {
+            psig_desc =
+              Psig_module
+                {
+                  pmd_name = { txt = None; _ };
+                  pmd_attributes = [];
+                  pmd_type =
+                    { pmty_attributes = []; pmty_desc = Pmty_with _ as res; _ };
+                  _;
+                };
+            _;
+          };
+        ] ->
+        res
+    | _ -> invalid_encoding ~loc "external type pmty_with"
+
   let must_preserve_ppat_constraint l =
     List.without_first l ~pred:(fun attr ->
         String.equal attr.attr_name.txt Ext_name.preserve_ppat_constraint)

astlib/encoding_505.mli

@@ -3,6 +3,9 @@ module Ext_name : sig
   val ptyp_functor : string
   val preserve_ppat_constraint : string
   val ptype_kind_external : string
+  val external_psig : string
+  val external_pstr_type : string
+  val external_pmty_with : string
 end
 
 module To_504 : sig
@@ -31,6 +34,26 @@ module To_504 : sig
   val decode_ptype_kind_external :
     type_declaration -> (string * attributes) option
 
+  val encode_external_psig_type :
+    loc:Location.t -> rec_flag -> type_declaration list -> signature_item_desc
+
+  val encode_external_psig_typesubst :
+    loc:Location.t -> type_declaration list -> signature_item_desc
+
+  val decode_external_psig :
+    loc:Location.t -> payload -> attributes -> signature_item_desc
+
+  val encode_external_pstr_type :
+    loc:Location.t -> rec_flag -> type_declaration list -> structure_item_desc
+
+  val decode_external_pstr_type :
+    loc:Location.t -> payload -> attributes -> structure_item_desc
+
+  val encode_external_pmty_with :
+    loc:Location.t -> module_type -> with_constraint list -> module_type_desc
+
+  val decode_external_pmty_with : loc:Location.t -> payload -> module_type_desc
+
   val must_preserve_ppat_constraint : attributes -> attributes option
   (** Returns [None] if the list does not contain
       [@ppxlib.migration.preserve_ppat_constraint_505] or [Some l] where [l] is

astlib/migrate_504_505.ml

@@ -1005,13 +1005,14 @@ and copy_module_type :
        Ast_504.Parsetree.pmty_loc;
        Ast_504.Parsetree.pmty_attributes;
      } ->
+  let loc = copy_location pmty_loc in
   {
-    Ast_505.Parsetree.pmty_desc = copy_module_type_desc pmty_desc;
-    Ast_505.Parsetree.pmty_loc = copy_location pmty_loc;
+    Ast_505.Parsetree.pmty_desc = copy_module_type_desc_with_loc ~loc pmty_desc;
+    Ast_505.Parsetree.pmty_loc = loc;
     Ast_505.Parsetree.pmty_attributes = copy_attributes pmty_attributes;
   }
 
-and copy_module_type_desc :
+and copy_module_type_desc_with_loc ~loc :
     Ast_504.Parsetree.module_type_desc -> Ast_505.Parsetree.module_type_desc =
   function
   | Ast_504.Parsetree.Pmty_ident x0 ->
@@ -1031,6 +1032,9 @@ and copy_module_type_desc :
   | Ast_504.Parsetree.Pmty_alias x0 ->
       Ast_505.Parsetree.Pmty_alias (copy_loc copy_longident x0)
 
+and copy_module_type_desc mty_desc =
+  copy_module_type_desc_with_loc ~loc:Location.none mty_desc
+
 and copy_functor_parameter :
     Ast_504.Parsetree.functor_parameter -> Ast_505.Parsetree.functor_parameter =
   function
@@ -1046,12 +1050,14 @@ and copy_signature : Ast_504.Parsetree.signature -> Ast_505.Parsetree.signature
 and copy_signature_item :
     Ast_504.Parsetree.signature_item -> Ast_505.Parsetree.signature_item =
  fun { Ast_504.Parsetree.psig_desc; Ast_504.Parsetree.psig_loc } ->
+  let loc = copy_location psig_loc in
   {
-    Ast_505.Parsetree.psig_desc = copy_signature_item_desc psig_desc;
-    Ast_505.Parsetree.psig_loc = copy_location psig_loc;
+    Ast_505.Parsetree.psig_desc =
+      copy_signature_item_desc_with_loc ~loc psig_desc;
+    Ast_505.Parsetree.psig_loc = loc;
   }
 
-and copy_signature_item_desc :
+and copy_signature_item_desc_with_loc ~loc :
     Ast_504.Parsetree.signature_item_desc ->
     Ast_505.Parsetree.signature_item_desc = function
   | Ast_504.Parsetree.Psig_value x0 ->
@@ -1086,9 +1092,16 @@ and copy_signature_item_desc :
         (List.map copy_class_type_declaration x0)
   | Ast_504.Parsetree.Psig_attribute x0 ->
       Ast_505.Parsetree.Psig_attribute (copy_attribute x0)
+  | Ast_504.Parsetree.Psig_extension (({ txt; _ }, payload), attr)
+    when String.equal txt Encoding_505.Ext_name.external_psig ->
+      let desc = Encoding_505.To_504.decode_external_psig ~loc payload attr in
+      copy_signature_item_desc_with_loc ~loc desc
   | Ast_504.Parsetree.Psig_extension (x0, x1) ->
       Ast_505.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1)
 
+and copy_signature_item_desc sigi_desc =
+  copy_signature_item_desc_with_loc ~loc:Location.none sigi_desc
+
 and copy_module_declaration :
     Ast_504.Parsetree.module_declaration -> Ast_505.Parsetree.module_declaration
     =
@@ -1255,12 +1268,14 @@ and copy_structure : Ast_504.Parsetree.structure -> Ast_505.Parsetree.structure
 and copy_structure_item :
     Ast_504.Parsetree.structure_item -> Ast_505.Parsetree.structure_item =
  fun { Ast_504.Parsetree.pstr_desc; Ast_504.Parsetree.pstr_loc } ->
+  let loc = copy_location pstr_loc in
   {
-    Ast_505.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc;
-    Ast_505.Parsetree.pstr_loc = copy_location pstr_loc;
+    Ast_505.Parsetree.pstr_desc =
+      copy_structure_item_desc_with_loc ~loc pstr_desc;
+    Ast_505.Parsetree.pstr_loc = loc;
   }
 
-and copy_structure_item_desc :
+and copy_structure_item_desc_with_loc ~loc :
     Ast_504.Parsetree.structure_item_desc ->
     Ast_505.Parsetree.structure_item_desc = function
   | Ast_504.Parsetree.Pstr_eval (x0, x1) ->
@@ -1294,9 +1309,18 @@ and copy_structure_item_desc :
       Ast_505.Parsetree.Pstr_include (copy_include_declaration x0)
   | Ast_504.Parsetree.Pstr_attribute x0 ->
       Ast_505.Parsetree.Pstr_attribute (copy_attribute x0)
+  | Ast_504.Parsetree.Pstr_extension (({ txt; _ }, payload), attr)
+    when String.equal txt Encoding_505.Ext_name.external_pstr_type ->
+      let desc =
+        Encoding_505.To_504.decode_external_pstr_type ~loc payload attr
+      in
+      copy_structure_item_desc_with_loc ~loc desc
   | Ast_504.Parsetree.Pstr_extension (x0, x1) ->
       Ast_505.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1)
 
+and copy_structure_item_desc stri_desc =
+  copy_structure_item_desc_with_loc ~loc:Location.none stri_desc
+
 and copy_value_constraint :
     Ast_504.Parsetree.value_constraint -> Ast_505.Parsetree.value_constraint =
   function