Add support for labeled tuple patterns

Signed-off-by: Nathan Rebours <[email protected]>

Author: Nathan Rebours

astlib/encoding_504.ml

@@ -1,6 +1,7 @@
 module Ext_name = struct
   let ptyp_labeled_tuple = "ppxlib.migration.ptyp_labeled_tuple_504"
   let pexp_labeled_tuple = "ppxlib.migration.pexp_labeled_tuple_504"
+  let ppat_labeled_tuple = "ppxlib.migration.ppat_labeled_tuple_504"
 end
 
 let invalid_encoding ~loc name =
@@ -12,6 +13,9 @@ module type AST = sig
   type core_type_desc
   type expression
   type expression_desc
+  type pattern
+  type pattern_desc
+  type closed_flag
 
   module Construct : sig
     val ptyp_extension_desc : string Location.loc -> payload -> core_type_desc
@@ -26,6 +30,12 @@ module type AST = sig
       loc:Location.t -> string -> expression option -> expression
 
     val pstr_eval : loc:Location.t -> expression -> payload
+    val ppat_extension_desc : string Location.loc -> payload -> pattern_desc
+    val ppat_tuple : loc:Location.t -> pattern list -> pattern
+    val ppat_var : loc:Location.t -> string -> pattern
+    val ppat_any : loc:Location.t -> pattern
+    val ppat : pattern -> payload
+    val closed_flag_to_string : closed_flag -> string
   end
 
   module Destruct : sig
@@ -36,6 +46,11 @@ module type AST = sig
     val pstr_eval : payload -> expression option
     val pexp_tuple : expression -> expression list option
     val pexp_variant : expression -> (string * expression option) option
+    val ppat : payload -> pattern option
+    val ppat_tuple : pattern -> pattern list option
+    val ppat_var : pattern -> string option
+    val ppat_any : pattern -> unit option
+    val closed_flag_from_string : string -> closed_flag option
   end
 end
 
@@ -124,9 +139,66 @@ module Make (X : AST) = struct
     match res with
     | Some res -> res
     | None -> invalid_encoding ~loc Ext_name.pexp_labeled_tuple
+
+  let encode_ppat_labeled_tuple ~loc pats closed_flag =
+    let payload =
+      let flag =
+        let s = X.Construct.closed_flag_to_string closed_flag in
+        X.Construct.ppat_var ~loc s
+      in
+      let pats =
+        let l =
+          List.map
+            (fun (label_opt, pat) ->
+              let label =
+                match label_opt with
+                | None -> X.Construct.ppat_any ~loc
+                | Some s -> X.Construct.ppat_var ~loc s
+              in
+              X.Construct.ppat_tuple ~loc [ label; pat ])
+            pats
+        in
+        X.Construct.ppat_tuple ~loc l
+      in
+      X.Construct.ppat_tuple ~loc [ pats; flag ]
+    in
+    X.Construct.ppat_extension_desc
+      { txt = Ext_name.ppat_labeled_tuple; loc }
+      (X.Construct.ppat payload)
+
+  let decode_ppat_labeled_tuple ~loc payload =
+    let open Stdlib0.Option.Op in
+    let res =
+      let* pat = X.Destruct.ppat payload in
+      let* pats_and_flag = X.Destruct.ppat_tuple pat in
+      match pats_and_flag with
+      | [ pats; flag ] ->
+          let* flag_s = X.Destruct.ppat_var flag in
+          let* closed_flag = X.Destruct.closed_flag_from_string flag_s in
+          let* pat_list = X.Destruct.ppat_tuple pats in
+          let* pats =
+            Stdlib0.Option.List.map pat_list ~f:(fun pat ->
+                let* pat_pair = X.Destruct.ppat_tuple pat in
+                match pat_pair with
+                | [ label; pat ] -> (
+                    match
+                      (X.Destruct.ppat_var label, X.Destruct.ppat_any label)
+                    with
+                    | Some s, _ -> Some (Some s, pat)
+                    | _, Some () -> Some (None, pat)
+                    | None, None -> None)
+                | _ -> None)
+          in
+          Some (pats, closed_flag)
+      | _ -> None
+    in
+    match res with
+    | Some res -> res
+    | None -> invalid_encoding ~loc Ext_name.ppat_labeled_tuple
 end
 
 module Ast_503 = struct
+  include Ast_503.Asttypes
   include Ast_503.Parsetree
 
   module Construct = struct
@@ -136,6 +208,9 @@ module Ast_503 = struct
     let expression ~loc pexp_desc =
       { pexp_desc; pexp_loc = loc; pexp_attributes = []; pexp_loc_stack = [] }
 
+    let pattern ~loc ppat_desc =
+      { ppat_desc; ppat_loc = loc; ppat_attributes = []; ppat_loc_stack = [] }
+
     let ptyp_extension_desc name payload = Ptyp_extension (name, payload)
     let ptyp_tuple ~loc typs = core_type ~loc (Ptyp_tuple typs)
     let ptyp_var ~loc s = core_type ~loc (Ptyp_var s)
@@ -149,6 +224,13 @@ module Ast_503 = struct
 
     let pstr_eval ~loc expr =
       PStr [ { pstr_desc = Pstr_eval (expr, []); pstr_loc = loc } ]
+
+    let ppat_extension_desc name payload = Ppat_extension (name, payload)
+    let ppat_tuple ~loc l = pattern ~loc (Ppat_tuple l)
+    let ppat_var ~loc txt = pattern ~loc (Ppat_var { txt; loc })
+    let ppat_any ~loc = pattern ~loc Ppat_any
+    let ppat pat = PPat (pat, None)
+    let closed_flag_to_string = function Closed -> "closed_" | Open -> "open_"
   end
 
   module Destruct = struct
@@ -175,10 +257,28 @@ module Ast_503 = struct
     let pexp_variant = function
       | { pexp_desc = Pexp_variant (s, e); _ } -> Some (s, e)
       | _ -> None
+
+    let ppat = function PPat (pat, None) -> Some pat | _ -> None
+
+    let ppat_tuple = function
+      | { ppat_desc = Ppat_tuple pats; _ } -> Some pats
+      | _ -> None
+
+    let ppat_var = function
+      | { ppat_desc = Ppat_var { txt; _ }; _ } -> Some txt
+      | _ -> None
+
+    let ppat_any = function { ppat_desc = Ppat_any; _ } -> Some () | _ -> None
+
+    let closed_flag_from_string = function
+      | "closed_" -> Some Closed
+      | "open_" -> Some Open
+      | _ -> None
   end
 end
 
 module Ast_502 = struct
+  include Ast_502.Asttypes
   include Ast_502.Parsetree
 
   module Construct = struct
@@ -188,6 +288,9 @@ module Ast_502 = struct
     let expression ~loc pexp_desc =
       { pexp_desc; pexp_loc = loc; pexp_attributes = []; pexp_loc_stack = [] }
 
+    let pattern ~loc ppat_desc =
+      { ppat_desc; ppat_loc = loc; ppat_attributes = []; ppat_loc_stack = [] }
+
     let ptyp_extension_desc name payload = Ptyp_extension (name, payload)
     let ptyp_tuple ~loc typs = core_type ~loc (Ptyp_tuple typs)
     let ptyp_var ~loc s = core_type ~loc (Ptyp_var s)
@@ -201,6 +304,13 @@ module Ast_502 = struct
 
     let pstr_eval ~loc expr =
       PStr [ { pstr_desc = Pstr_eval (expr, []); pstr_loc = loc } ]
+
+    let ppat_extension_desc name payload = Ppat_extension (name, payload)
+    let ppat_tuple ~loc l = pattern ~loc (Ppat_tuple l)
+    let ppat_var ~loc txt = pattern ~loc (Ppat_var { txt; loc })
+    let ppat_any ~loc = pattern ~loc Ppat_any
+    let ppat pat = PPat (pat, None)
+    let closed_flag_to_string = function Closed -> "closed_" | Open -> "open_"
   end
 
   module Destruct = struct
@@ -227,6 +337,23 @@ module Ast_502 = struct
     let pexp_variant = function
       | { pexp_desc = Pexp_variant (s, e); _ } -> Some (s, e)
       | _ -> None
+
+    let ppat = function PPat (pat, None) -> Some pat | _ -> None
+
+    let ppat_tuple = function
+      | { ppat_desc = Ppat_tuple pats; _ } -> Some pats
+      | _ -> None
+
+    let ppat_var = function
+      | { ppat_desc = Ppat_var { txt; _ }; _ } -> Some txt
+      | _ -> None
+
+    let ppat_any = function { ppat_desc = Ppat_any; _ } -> Some () | _ -> None
+
+    let closed_flag_from_string = function
+      | "closed_" -> Some Closed
+      | "open_" -> Some Open
+      | _ -> None
   end
 end
 

astlib/encoding_504.mli

@@ -1,9 +1,11 @@
 module Ext_name : sig
   val ptyp_labeled_tuple : string
   val pexp_labeled_tuple : string
+  val ppat_labeled_tuple : string
 end
 
 module To_503 : sig
+  open Ast_503.Asttypes
   open Ast_503.Parsetree
 
   val encode_ptyp_labeled_tuple :
@@ -17,9 +19,19 @@ module To_503 : sig
 
   val decode_pexp_labeled_tuple :
     loc:Location.t -> payload -> (string option * expression) list
+
+  val encode_ppat_labeled_tuple :
+    loc:Location.t ->
+    (string option * pattern) list ->
+    closed_flag ->
+    pattern_desc
+
+  val decode_ppat_labeled_tuple :
+    loc:Location.t -> payload -> (string option * pattern) list * closed_flag
 end
 
 module To_502 : sig
+  open Ast_502.Asttypes
   open Ast_502.Parsetree
 
   val encode_ptyp_labeled_tuple :
@@ -33,4 +45,13 @@ module To_502 : sig
 
   val decode_pexp_labeled_tuple :
     loc:Location.t -> payload -> (string option * expression) list
+
+  val encode_ppat_labeled_tuple :
+    loc:Location.t ->
+    (string option * pattern) list ->
+    closed_flag ->
+    pattern_desc
+
+  val decode_ppat_labeled_tuple :
+    loc:Location.t -> payload -> (string option * pattern) list * closed_flag
 end

astlib/migrate_503_504.ml

@@ -356,10 +356,14 @@ and copy_pattern_desc_with_loc :
         (copy_loc (fun x -> Option.map (fun x -> x) x) x0)
   | Ast_503.Parsetree.Ppat_exception x0 ->
       Ast_504.Parsetree.Ppat_exception (copy_pattern x0)
-  | Ast_503.Parsetree.Ppat_extension
-      ( { txt = "ppxlib.migration.ppat_effect"; _ },
-        PPat ({ ppat_desc = Ppat_tuple [ e; c ]; _ }, None) ) ->
-      Ast_504.Parsetree.Ppat_effect (copy_pattern e, copy_pattern c)
+  | Ast_503.Parsetree.Ppat_extension ({ txt; loc }, payload)
+    when String.equal txt Encoding_504.Ext_name.ppat_labeled_tuple ->
+      let pats, flag =
+        Encoding_504.To_503.decode_ppat_labeled_tuple ~loc payload
+      in
+      Ast_504.Parsetree.Ppat_tuple
+        ( List.map (fun (lbl, pat) -> (lbl, copy_pattern pat)) pats,
+          copy_closed_flag flag )
   | Ast_503.Parsetree.Ppat_extension x0 ->
       Ast_504.Parsetree.Ppat_extension (copy_extension x0)
   | Ast_503.Parsetree.Ppat_open (x0, x1) ->

astlib/migrate_504_503.ml

@@ -321,15 +321,16 @@ and copy_pattern_desc loc :
       Ast_503.Parsetree.Ppat_constant (copy_constant x0)
   | Ast_504.Parsetree.Ppat_interval (x0, x1) ->
       Ast_503.Parsetree.Ppat_interval (copy_constant x0, copy_constant x1)
-  | Ast_504.Parsetree.Ppat_tuple (x0, _) ->
-      let args =
-        List.map
-          (function
-            | None, arg -> arg
-            | Some l, _ -> migration_error loc "labelled tuples")
-          x0
+  | Ast_504.Parsetree.Ppat_tuple (x0, flag) -> (
+      let flag = copy_closed_flag flag in
+      let args = List.map (fun (lbl, pat) -> (lbl, copy_pattern pat)) x0 in
+      let has_label =
+        List.exists (function Some _, _ -> true | _ -> false) args
       in
-      Ast_503.Parsetree.Ppat_tuple (List.map copy_pattern args)
+      match (has_label, flag) with
+      | true, _ | false, Open ->
+          Encoding_504.To_503.encode_ppat_labeled_tuple ~loc args flag
+      | _, _ -> Ast_503.Parsetree.Ppat_tuple (List.map snd args))
   | Ast_504.Parsetree.Ppat_construct (x0, x1) ->
       Ast_503.Parsetree.Ppat_construct
         ( copy_loc copy_Longident_t x0,

src/ast_builder.ml

@@ -276,6 +276,12 @@ module Default = struct
     in
     { pexp_desc; pexp_loc = loc; pexp_attributes = []; pexp_loc_stack = [] }
 
+  let ppat_labeled_tuple ~loc l flag =
+    let ppat_desc =
+      Astlib__.Encoding_504.To_502.encode_ppat_labeled_tuple ~loc l flag
+    in
+    { ppat_desc; ppat_loc = loc; ppat_attributes = []; ppat_loc_stack = [] }
+
   let pexp_tuple_opt ~loc l =
     match l with [] -> None | _ :: _ -> Some (pexp_tuple ~loc l)
 
@@ -569,6 +575,7 @@ end) : S = struct
   let ptyp_tuple l = Default.ptyp_tuple ~loc l
   let ptyp_labeled_tuple l = Default.ptyp_labeled_tuple ~loc l
   let pexp_labeled_tuple l = Default.pexp_labeled_tuple ~loc l
+  let ppat_labeled_tuple l flag = Default.ppat_labeled_tuple ~loc l flag
   let pexp_tuple_opt l = Default.pexp_tuple_opt ~loc l
   let ppat_tuple_opt l = Default.ppat_tuple_opt ~loc l
   let ptyp_poly vars ty = Default.ptyp_poly ~loc vars ty

src/ast_builder_intf.ml

@@ -174,6 +174,10 @@ module type Additional_helpers = sig
   val pexp_labeled_tuple :
     ((string option * expression) list -> expression) with_loc
   (** Returns an encoded labeled tuple expression as introduced in OCaml 5.4. *)
+
+  val ppat_labeled_tuple :
+    ((string option * pattern) list -> closed_flag -> pattern) with_loc
+  (** Returns an encoded labeled tuple pattern as introduced in OCaml 5.4. *)
 end
 
 module type Located = sig

src/ast_pattern.ml

@@ -309,3 +309,20 @@ let pexp_labeled_tuple (T f0) =
           let k = f0 ctx loc x0 k in
           k
       | _ -> fail loc "labeled tuple")
+
+let ppat_labeled_tuple (T f0) =
+  T
+    (fun ctx _loc x k ->
+      let loc = x.ppat_loc in
+      let x = x.ppat_desc in
+      match x with
+      | Ppat_extension ({ txt; _ }, payload)
+        when String.equal txt Astlib__.Encoding_504.Ext_name.ppat_labeled_tuple
+        ->
+          let x0 =
+            Astlib__.Encoding_504.To_502.decode_ppat_labeled_tuple ~loc payload
+          in
+          ctx.matched <- ctx.matched + 1;
+          let k = f0 ctx loc x0 k in
+          k
+      | _ -> fail loc "labeled tuple")

src/ast_pattern.mli

@@ -235,3 +235,12 @@ val pexp_labeled_tuple :
     It will fail on a regular tuple expression and as a consequence, if it
     matches, at least one expression in the tuple is guaranteed to be labeled.
 *)
+
+val ppat_labeled_tuple :
+  ((string option * pattern) list * closed_flag, 'a, 'b) t ->
+  (pattern, 'a, 'b) t
+(** Match over an encoded OCaml 5.4 labeled tuple pattern.
+
+    It will fail on a regular tuple expression and as a consequence, if it
+    matches, either at least one pattern in the tuple is guaranteed to be
+    labeled or the flag to be [Open]. *)