Update 5.6 support: primitive alias

CHANGES.md

@@ -1,6 +1,8 @@
 unreleased
 ----------
 
+- Add support for OCaml 5.6 primitive aliases (#642, @NathanReb)
+
 0.38.0
 ------
 

astlib/ast_506.ml

@@ -560,17 +560,36 @@ module Parsetree = struct
     {
       pval_name: string loc;
       pval_type: core_type;
-      pval_prim: string list;
       pval_attributes: attributes;  (** [... [\@\@id1] [\@\@id2]] *)
       pval_loc: Location.t;
     }
-  (** Values of type {!value_description} represents:
-      - [val x: T],
-        when {{!value_description.pval_prim}[pval_prim]} is [[]]
-      - [external x: T = "s1" ... "sn"]
-        when {{!value_description.pval_prim}[pval_prim]} is [["s1";..."sn"]]
+  (** Values of type {!value_description} represent [val x: T]. *)
+
+  (** {2 Primitive descriptions} *)
+
+  and primitive_description (*IF_CURRENT = Parsetree.primitive_description *) =
+    {
+      pprim_name: string loc;
+      pprim_kind: primitive_kind;
+      pprim_attributes: attributes;
+      pprim_loc: Location.t
+    }
+  (** Values of type {!primitive_description} represent:
+      - [external x: T = "s1" ... "sn"] when
+        {{!primitive_description.pprim_kind}[pprim_kind]} is
+        [Pprim_decl (T, ["s1";..."sn"])].
+      - [external x: T = M.y] when {{!primitive_description.pprim_kind}[pprim_kind]}
+        is [Pprim_alias (Some T, M.y)]
+      - [external x = M.y] when {{!primitive_description.pprim_kind}[pprim_kind]}
+        is [Pprim_alias (None, M.y)]
   *)
 
+  and primitive_kind (*IF_CURRENT = Parsetree.primitive_kind *) =
+    | Pprim_decl of core_type * string list
+    | Pprim_alias of core_type option * Longident.t loc
+    (** See the comment on {{!primitive_description}[primitive_description]}. *)
+
+
   (** {2 Type declarations} *)
 
   and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) =
@@ -952,9 +971,11 @@ module Parsetree = struct
 
   and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) =
     | Psig_value of value_description
-    (** - [val x: T]
-        - [external x: T = "s1" ... "sn"]
-    *)
+    (** [val x: T] *)
+    | Psig_primitive of primitive_description
+    (** - [external x: T = "s1" ... "sn" ]
+        - [external x = y]
+        - [external x: T = y] *)
     | Psig_type of rec_flag * type_declaration list
     (** [type t1 = ... and ... and tn  = ...] *)
     | Psig_typesubst of type_declaration list
@@ -1102,9 +1123,12 @@ module Parsetree = struct
         - [let rec P1 = E1 and ... and Pn = EN ]
           when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}.
     *)
-    | Pstr_primitive of value_description
-    (** - [val x: T]
-        - [external x: T = "s1" ... "sn" ]*)
+    | Pstr_val of value_description
+    (** [val x: T] *)
+    | Pstr_primitive of primitive_description
+    (** - [external x: T = "s1" ... "sn" ]
+        - [external x = y]
+        - [external x: T = y] *)
     | Pstr_type of rec_flag * type_declaration list
     (** [type t1 = ... and ... and tn = ...] *)
     | Pstr_typext of type_extension  (** [type t1 += ...] *)

astlib/encoding_506.ml

@@ -0,0 +1,100 @@
+open Stdlib0
+
+module Ext_name = struct
+  let pstr_primitive_alias = "ppxlib.migration.pstr_primitive_alias_5_6"
+  let psig_primitive_alias = "ppxlib.migration.psig_primitive_alias_5_6"
+  let none = "ppxlib.migration.none_5_6"
+  let primitive_alias = "ppxlib.migration.primitive_alias_5_6"
+end
+
+let invalid_encoding ~loc name =
+  Location.raise_errorf ~loc "Invalid %s encoding" name
+
+module To_505 = struct
+  open Ast_505.Asttypes
+  open Ast_505.Parsetree
+
+  let encode_typ_opt ~loc typ_opt =
+    match typ_opt with
+    | Some typ -> typ
+    | None ->
+        let ptyp_desc =
+          Ptyp_extension ({ txt = Ext_name.none; loc }, PStr [])
+        in
+        { ptyp_desc; ptyp_loc = loc; ptyp_attributes = []; ptyp_loc_stack = [] }
+
+  let decode_typ_opt ~loc core_type =
+    match core_type.ptyp_desc with
+    | Ptyp_extension ({ txt; _ }, payload) when String.equal txt Ext_name.none
+      -> (
+        match payload with
+        | PStr [] -> None
+        | _ -> invalid_encoding ~loc Ext_name.none)
+    | _ -> Some core_type
+
+  let encode_alias ~loc lident_loc =
+    let attr_name = { txt = Ext_name.primitive_alias; loc } in
+    let ident_expr =
+      let pexp_desc = Pexp_ident lident_loc in
+      { pexp_desc; pexp_loc = loc; pexp_attributes = []; pexp_loc_stack = [] }
+    in
+    let ident_stri =
+      let pstr_desc = Pstr_eval (ident_expr, []) in
+      { pstr_desc; pstr_loc = loc }
+    in
+    let attr_payload = PStr [ ident_stri ] in
+    { attr_name; attr_payload; attr_loc = loc }
+
+  let decode_alias ~loc attr_payload =
+    match attr_payload with
+    | PStr
+        [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident ident; _ }, []) } ]
+      ->
+        ident
+    | _ -> invalid_encoding ~loc Ext_name.primitive_alias
+
+  let encode_primitive_alias ~loc pval_name typ_opt ident attrs =
+    let pval_type = encode_typ_opt ~loc typ_opt in
+    let alias_attr = encode_alias ~loc ident in
+    let pval_attributes = alias_attr :: attrs in
+    let vd =
+      { pval_name; pval_type; pval_attributes; pval_loc = loc; pval_prim = [] }
+    in
+    let stri = { pstr_desc = Pstr_primitive vd; pstr_loc = loc } in
+    PStr [ stri ]
+
+  let decode_primitive_alias ~loc ~name payload =
+    match payload with
+    | PStr [ { pstr_desc = Pstr_primitive vd; _ } ] -> (
+        let alias_attr_and_remainder =
+          List.without_first vd.pval_attributes ~pred:(fun a ->
+              String.equal a.attr_name.txt Ext_name.primitive_alias)
+        in
+        match alias_attr_and_remainder with
+        | None -> invalid_encoding ~loc name
+        | Some (alias_attr, remainder_attrs) ->
+            let lident_loc = decode_alias ~loc alias_attr.attr_payload in
+            let typ_opt = decode_typ_opt ~loc vd.pval_type in
+            (vd.pval_name, typ_opt, lident_loc, remainder_attrs))
+    | _ -> invalid_encoding ~loc name
+
+  let encode_psig_primitive_alias ~loc pval_name typ_opt ident attrs =
+    let payload = encode_primitive_alias ~loc pval_name typ_opt ident attrs in
+    Psig_extension (({ txt = Ext_name.psig_primitive_alias; loc }, payload), [])
+
+  let decode_psig_primitive_alias ~loc payload attrs =
+    match attrs with
+    | [] ->
+        decode_primitive_alias ~loc ~name:Ext_name.psig_primitive_alias payload
+    | _ -> invalid_encoding ~loc Ext_name.psig_primitive_alias
+
+  let encode_pstr_primitive_alias ~loc pval_name typ_opt ident attrs =
+    let payload = encode_primitive_alias ~loc pval_name typ_opt ident attrs in
+    Pstr_extension (({ txt = Ext_name.pstr_primitive_alias; loc }, payload), [])
+
+  let decode_pstr_primitive_alias ~loc payload attrs =
+    match attrs with
+    | [] ->
+        decode_primitive_alias ~loc ~name:Ext_name.pstr_primitive_alias payload
+    | _ -> invalid_encoding ~loc Ext_name.psig_primitive_alias
+end

astlib/encoding_506.mli

@@ -0,0 +1,38 @@
+module Ext_name : sig
+  val pstr_primitive_alias : string
+  val psig_primitive_alias : string
+end
+
+module To_505 : sig
+  open Ast_505
+  open Asttypes
+  open Parsetree
+
+  val encode_psig_primitive_alias :
+    loc:Location.t ->
+    string loc ->
+    core_type option ->
+    Longident.t loc ->
+    attributes ->
+    signature_item_desc
+
+  val decode_psig_primitive_alias :
+    loc:Location.t ->
+    payload ->
+    attributes ->
+    string loc * core_type option * Longident.t loc * attributes
+
+  val encode_pstr_primitive_alias :
+    loc:Location.t ->
+    string loc ->
+    core_type option ->
+    Longident.t loc ->
+    attributes ->
+    structure_item_desc
+
+  val decode_pstr_primitive_alias :
+    loc:Location.t ->
+    payload ->
+    attributes ->
+    string loc * core_type option * Longident.t loc * attributes
+end

astlib/migrate_505_506.ml

@@ -545,13 +545,18 @@ and copy_value_description :
        Ast_505.Parsetree.pval_attributes;
        Ast_505.Parsetree.pval_loc;
      } ->
-  {
-    Ast_506.Parsetree.pval_name = copy_loc (fun x -> x) pval_name;
-    Ast_506.Parsetree.pval_type = copy_core_type pval_type;
-    Ast_506.Parsetree.pval_prim = List.map (fun x -> x) pval_prim;
-    Ast_506.Parsetree.pval_attributes = copy_attributes pval_attributes;
-    Ast_506.Parsetree.pval_loc = copy_location pval_loc;
-  }
+  match pval_prim with
+  | [] ->
+      {
+        Ast_506.Parsetree.pval_name = copy_loc (fun x -> x) pval_name;
+        Ast_506.Parsetree.pval_type = copy_core_type pval_type;
+        Ast_506.Parsetree.pval_attributes = copy_attributes pval_attributes;
+        Ast_506.Parsetree.pval_loc = copy_location pval_loc;
+      }
+  | _ ->
+      Location.raise_errorf ~loc:pval_loc
+        "Ppxlib migration error: value_description with pval_prim <> [] cannot \
+         be migrated from Ocaml 5.5 to 5.6"
 
 and copy_type_declaration :
     Ast_505.Parsetree.type_declaration -> Ast_506.Parsetree.type_declaration =
@@ -981,16 +986,31 @@ and copy_signature : Ast_505.Parsetree.signature -> Ast_506.Parsetree.signature
 and copy_signature_item :
     Ast_505.Parsetree.signature_item -> Ast_506.Parsetree.signature_item =
  fun { Ast_505.Parsetree.psig_desc; Ast_505.Parsetree.psig_loc } ->
+  let loc = copy_location psig_loc in
   {
-    Ast_506.Parsetree.psig_desc = copy_signature_item_desc psig_desc;
-    Ast_506.Parsetree.psig_loc = copy_location psig_loc;
+    Ast_506.Parsetree.psig_desc =
+      copy_signature_item_desc_with_loc ~loc psig_desc;
+    Ast_506.Parsetree.psig_loc = loc;
   }
 
-and copy_signature_item_desc :
+and copy_signature_item_desc_with_loc ~loc :
     Ast_505.Parsetree.signature_item_desc ->
     Ast_506.Parsetree.signature_item_desc = function
-  | Ast_505.Parsetree.Psig_value x0 ->
-      Ast_506.Parsetree.Psig_value (copy_value_description x0)
+  | Ast_505.Parsetree.Psig_value x0 -> (
+      match x0.pval_prim with
+      | [] -> Ast_506.Parsetree.Psig_value (copy_value_description x0)
+      | prims ->
+          let pprim_name = copy_loc (fun x -> x) x0.pval_name in
+          let typ = copy_core_type x0.pval_type in
+          let pprim_attributes = copy_attributes x0.pval_attributes in
+          let pprim_loc = copy_location x0.pval_loc in
+          Ast_506.Parsetree.Psig_primitive
+            {
+              pprim_name;
+              pprim_kind = Pprim_decl (typ, prims);
+              pprim_attributes;
+              pprim_loc;
+            })
   | Ast_505.Parsetree.Psig_type (x0, x1) ->
       Ast_506.Parsetree.Psig_type
         (copy_rec_flag x0, List.map copy_type_declaration x1)
@@ -1021,9 +1041,24 @@ and copy_signature_item_desc :
         (List.map copy_class_type_declaration x0)
   | Ast_505.Parsetree.Psig_attribute x0 ->
       Ast_506.Parsetree.Psig_attribute (copy_attribute x0)
+  | Ast_505.Parsetree.Psig_extension (({ txt; _ }, payload), attrs)
+    when String.equal txt Encoding_506.Ext_name.psig_primitive_alias ->
+      let name, typ, lident_loc, rem_attrs =
+        Encoding_506.To_505.decode_psig_primitive_alias ~loc payload attrs
+      in
+      let pprim_name = copy_loc (fun x -> x) name in
+      let typ_opt = Option.map copy_core_type typ in
+      let alias = copy_loc copy_longident lident_loc in
+      let pprim_attributes = copy_attributes rem_attrs in
+      let pprim_kind = Ast_506.Parsetree.Pprim_alias (typ_opt, alias) in
+      Ast_506.Parsetree.Psig_primitive
+        { pprim_name; pprim_kind; pprim_loc = loc; pprim_attributes }
   | Ast_505.Parsetree.Psig_extension (x0, x1) ->
       Ast_506.Parsetree.Psig_extension (copy_extension x0, copy_attributes x1)
 
+and copy_signature_item_desc sigid =
+  copy_signature_item_desc_with_loc ~loc:Location.none
+
 and copy_module_declaration :
     Ast_505.Parsetree.module_declaration -> Ast_506.Parsetree.module_declaration
     =
@@ -1190,21 +1225,36 @@ and copy_structure : Ast_505.Parsetree.structure -> Ast_506.Parsetree.structure
 and copy_structure_item :
     Ast_505.Parsetree.structure_item -> Ast_506.Parsetree.structure_item =
  fun { Ast_505.Parsetree.pstr_desc; Ast_505.Parsetree.pstr_loc } ->
+  let loc = copy_location pstr_loc in
   {
-    Ast_506.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc;
-    Ast_506.Parsetree.pstr_loc = copy_location pstr_loc;
+    Ast_506.Parsetree.pstr_desc =
+      copy_structure_item_desc_with_loc ~loc pstr_desc;
+    Ast_506.Parsetree.pstr_loc = loc;
   }
 
-and copy_structure_item_desc :
+and copy_structure_item_desc_with_loc ~loc :
     Ast_505.Parsetree.structure_item_desc ->
     Ast_506.Parsetree.structure_item_desc = function
   | Ast_505.Parsetree.Pstr_eval (x0, x1) ->
       Ast_506.Parsetree.Pstr_eval (copy_expression x0, copy_attributes x1)
   | Ast_505.Parsetree.Pstr_value (x0, x1) ->
       Ast_506.Parsetree.Pstr_value
         (copy_rec_flag x0, List.map copy_value_binding x1)
-  | Ast_505.Parsetree.Pstr_primitive x0 ->
-      Ast_506.Parsetree.Pstr_primitive (copy_value_description x0)
+  | Ast_505.Parsetree.Pstr_primitive x0 -> (
+      match x0.pval_prim with
+      | [] -> Ast_506.Parsetree.Pstr_val (copy_value_description x0)
+      | prims ->
+          let pprim_name = copy_loc (fun x -> x) x0.pval_name in
+          let typ = copy_core_type x0.pval_type in
+          let pprim_attributes = copy_attributes x0.pval_attributes in
+          let pprim_loc = copy_location x0.pval_loc in
+          Ast_506.Parsetree.Pstr_primitive
+            {
+              pprim_name;
+              pprim_kind = Pprim_decl (typ, prims);
+              pprim_attributes;
+              pprim_loc;
+            })
   | Ast_505.Parsetree.Pstr_type (x0, x1) ->
       Ast_506.Parsetree.Pstr_type
         (copy_rec_flag x0, List.map copy_type_declaration x1)
@@ -1229,9 +1279,24 @@ and copy_structure_item_desc :
       Ast_506.Parsetree.Pstr_include (copy_include_declaration x0)
   | Ast_505.Parsetree.Pstr_attribute x0 ->
       Ast_506.Parsetree.Pstr_attribute (copy_attribute x0)
+  | Ast_505.Parsetree.Pstr_extension (({ txt; _ }, payload), attrs)
+    when String.equal txt Encoding_506.Ext_name.pstr_primitive_alias ->
+      let name, typ, lident_loc, rem_attrs =
+        Encoding_506.To_505.decode_pstr_primitive_alias ~loc payload attrs
+      in
+      let pprim_name = copy_loc (fun x -> x) name in
+      let typ_opt = Option.map copy_core_type typ in
+      let alias = copy_loc copy_longident lident_loc in
+      let pprim_attributes = copy_attributes rem_attrs in
+      let pprim_kind = Ast_506.Parsetree.Pprim_alias (typ_opt, alias) in
+      Ast_506.Parsetree.Pstr_primitive
+        { pprim_name; pprim_kind; pprim_loc = loc; pprim_attributes }
   | Ast_505.Parsetree.Pstr_extension (x0, x1) ->
       Ast_506.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_505.Parsetree.value_constraint -> Ast_506.Parsetree.value_constraint =
   function