Refactor external type encoding logic

This moves as much of the encoding out of the migration
code as possible.

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

Author: Nathan Rebours

astlib/encoding_505.ml

@@ -61,42 +61,53 @@ module To_504 = struct
         (arg, attr.attr_name, pkg, typ)
     | _ -> invalid_encoding ~loc Ext_name.ptyp_functor
 
-  let encode_ptype_kind_external name =
+  let encode_ptype_kind_external ~loc name attributes =
+    let loc = { loc with Location.loc_ghost = true } in
     let name_attr =
       {
-        attr_name = { txt = name; loc = Location.none };
-        attr_loc = Location.none;
+        attr_name = { txt = name; loc };
+        attr_loc = loc;
         attr_payload = PStr [];
       }
     in
-    let si =
-      { pstr_desc = Pstr_attribute name_attr; pstr_loc = Location.none }
+    let si = { pstr_desc = Pstr_attribute name_attr; pstr_loc = loc } in
+    let flag_attr =
+      {
+        attr_name = { txt = Ext_name.ptype_kind_external; loc };
+        attr_loc = loc;
+        attr_payload = PStr [ si ];
+      }
     in
-    {
-      attr_name = { txt = Ext_name.ptype_kind_external; loc = Location.none };
-      attr_loc = Location.none;
-      attr_payload = PStr [ si ];
-    }
+    (Ptype_abstract, flag_attr :: attributes)
 
-  let decode_ptype_kind_external = function
-    | {
-        attr_name = { txt; _ };
-        attr_payload =
-          PStr
-            [
-              {
-                pstr_desc = Pstr_attribute { attr_name = { txt = name; _ }; _ };
-              };
-            ];
-      }
+  let decode_ptype_kind_external type_decl =
+    let attrs =
+      List.without_first type_decl.ptype_attributes ~pred:(fun attr ->
+          String.equal attr.attr_name.txt Ext_name.ptype_kind_external)
+    in
+    match (type_decl.ptype_kind, attrs) with
+    | ( Ptype_abstract,
+        Some
+          ( {
+              attr_name = { txt; _ };
+              attr_payload =
+                PStr
+                  [
+                    {
+                      pstr_desc =
+                        Pstr_attribute { attr_name = { txt = name; _ }; _ };
+                    };
+                  ];
+            },
+            ptype_attributes ) )
       when String.equal txt Ext_name.ptype_kind_external ->
-        Some name
+        Some (name, ptype_attributes)
     | _ -> None
 
   let must_preserve_ppat_constraint l =
-    List.without_first l
-      ~pred:(fun attr ->
+    List.without_first l ~pred:(fun attr ->
         String.equal attr.attr_name.txt Ext_name.preserve_ppat_constraint)
+    |> Option.map snd
 
   let preserve_ppat_constraint pattern core_type =
     let loc = pattern.ppat_loc in

astlib/encoding_505.mli

@@ -25,8 +25,11 @@ module To_504 : sig
     payload ->
     arg_label * string loc * package_type * core_type
 
-  val encode_ptype_kind_external : string -> attribute
-  val decode_ptype_kind_external : attribute -> string option
+  val encode_ptype_kind_external :
+    loc:Location.t -> string -> attributes -> type_kind * attributes
+
+  val decode_ptype_kind_external :
+    type_declaration -> (string * attributes) option
 
   val must_preserve_ppat_constraint : attributes -> attributes option
   (** Returns [None] if the list does not contain

astlib/migrate_504_505.ml

@@ -614,31 +614,22 @@ and copy_value_description :
 
 and copy_type_declaration :
     Ast_504.Parsetree.type_declaration -> Ast_505.Parsetree.type_declaration =
- fun {
-       Ast_504.Parsetree.ptype_name;
-       Ast_504.Parsetree.ptype_params;
-       Ast_504.Parsetree.ptype_cstrs;
-       Ast_504.Parsetree.ptype_kind;
-       Ast_504.Parsetree.ptype_private;
-       Ast_504.Parsetree.ptype_manifest;
-       Ast_504.Parsetree.ptype_attributes;
-       Ast_504.Parsetree.ptype_loc;
-     } ->
-  let external_name, ptype_attributes =
-    let rec aux so_far = function
-      | [] -> (None, List.rev so_far)
-      | Ast_504.Parsetree.({ attr_name = { txt; _ }; _ } as attr) :: rest
-        when String.equal txt Encoding_505.Ext_name.ptype_kind_external ->
-          ( Encoding_505.To_504.decode_ptype_kind_external attr,
-            List.rev_append so_far rest )
-      | attr :: rest -> aux (attr :: so_far) rest
-    in
-    aux [] ptype_attributes
-  in
-  let ptype_kind =
-    match external_name with
-    | Some name -> Ast_505.Parsetree.Ptype_external name
-    | None -> copy_type_kind ptype_kind
+ fun ({
+        Ast_504.Parsetree.ptype_name;
+        Ast_504.Parsetree.ptype_params;
+        Ast_504.Parsetree.ptype_cstrs;
+        Ast_504.Parsetree.ptype_kind;
+        Ast_504.Parsetree.ptype_private;
+        Ast_504.Parsetree.ptype_manifest;
+        Ast_504.Parsetree.ptype_attributes;
+        Ast_504.Parsetree.ptype_loc;
+      } as td) ->
+  let ptype_kind, ptype_attributes =
+    match Encoding_505.To_504.decode_ptype_kind_external td with
+    | Some (external_name, attributes) ->
+        ( Ast_505.Parsetree.Ptype_external external_name,
+          copy_attributes attributes )
+    | None -> (copy_type_kind ptype_kind, copy_attributes ptype_attributes)
   in
   {
     Ast_505.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name;
@@ -659,7 +650,7 @@ and copy_type_declaration :
     Ast_505.Parsetree.ptype_kind;
     Ast_505.Parsetree.ptype_private = copy_private_flag ptype_private;
     Ast_505.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest;
-    Ast_505.Parsetree.ptype_attributes = copy_attributes ptype_attributes;
+    Ast_505.Parsetree.ptype_attributes;
     Ast_505.Parsetree.ptype_loc = copy_location ptype_loc;
   }
 

astlib/migrate_505_504.ml

@@ -2,6 +2,10 @@ open Stdlib0
 module From = Ast_505
 module To = Ast_504
 
+module External_type = struct
+  type exn += T of string
+end
+
 let copy_location x = x
 
 let rec copy_longident : Ast_505.Longident.t -> Ast_504.Longident.t = function
@@ -612,12 +616,13 @@ and copy_type_declaration :
        Ast_505.Parsetree.ptype_attributes;
        Ast_505.Parsetree.ptype_loc;
      } ->
-  let ptype_attributes =
-    match ptype_kind with
-    | Ptype_external name ->
-        let attr = Encoding_505.To_504.encode_ptype_kind_external name in
-        attr :: copy_attributes ptype_attributes
-    | _ -> copy_attributes ptype_attributes
+  let loc = copy_location ptype_loc in
+  let ptype_kind, ptype_attributes =
+    let attributes = copy_attributes ptype_attributes in
+    match copy_type_kind ptype_kind with
+    | ptype_kind -> (ptype_kind, attributes)
+    | exception External_type.T name ->
+        Encoding_505.To_504.encode_ptype_kind_external ~loc name attributes
   in
   {
     Ast_504.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name;
@@ -635,11 +640,11 @@ and copy_type_declaration :
           let x0, x1, x2 = x in
           (copy_core_type x0, copy_core_type x1, copy_location x2))
         ptype_constraints;
-    Ast_504.Parsetree.ptype_kind = copy_type_kind ptype_kind;
+    Ast_504.Parsetree.ptype_kind;
     Ast_504.Parsetree.ptype_private = copy_private_flag ptype_private;
     Ast_504.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest;
     Ast_504.Parsetree.ptype_attributes;
-    Ast_504.Parsetree.ptype_loc = copy_location ptype_loc;
+    Ast_504.Parsetree.ptype_loc = loc;
   }
 
 and copy_type_kind : Ast_505.Parsetree.type_kind -> Ast_504.Parsetree.type_kind
@@ -650,10 +655,7 @@ and copy_type_kind : Ast_505.Parsetree.type_kind -> Ast_504.Parsetree.type_kind
   | Ast_505.Parsetree.Ptype_record x0 ->
       Ast_504.Parsetree.Ptype_record (List.map copy_label_declaration x0)
   | Ast_505.Parsetree.Ptype_open -> Ast_504.Parsetree.Ptype_open
-  | Ast_505.Parsetree.Ptype_external x0 ->
-      (* Note that copy_type_declaration should handle this for us and we need
-       only put _something_ here. *)
-      Ast_504.Parsetree.Ptype_open
+  | Ast_505.Parsetree.Ptype_external x0 -> raise (External_type.T x0)
 
 and copy_label_declaration :
     Ast_505.Parsetree.label_declaration -> Ast_504.Parsetree.label_declaration =

astlib/stdlib0.ml

@@ -34,11 +34,14 @@ end
 module List = struct
   include List
 
+  (** [without_first l ~pred] return [Some (elm, l')] where [elm] is the first
+      element of [l] that satisfies [pred] and [l'] is [l] without [elm] or
+      [None] if no element of [l] satisfies [pred]. *)
   let without_first list ~pred =
     let rec aux seen = function
       | [] -> None
-      | hd::tl when pred hd -> Some (List.rev_append seen tl)
-      | hd::tl -> aux (hd::seen) tl
+      | hd :: tl when pred hd -> Some (hd, List.rev_append seen tl)
+      | hd :: tl -> aux (hd :: seen) tl
     in
     aux [] list
 end