Preserve attributed list payload tuples across AST0 conversions

Signed-off-by: Christoph Knittel <ck@cca.io>

Author: cknitt

compiler/ml/ast_mapper_from0.ml

@@ -195,9 +195,11 @@ let remove_constructor_args_attr (attrs : Pt.attributes) =
 
    Decoding consumes the internal marker and restores the source list.
    Ordinary constructors also accept PPX-produced [explicit_arity] and
-   [ocaml.explicit_arity] attributes, and always split the list constructor
-   [::]. Other unmarked v0 tuples remain a single syntactic payload; Typecore
-   resolves semantic grouping once it knows the constructor declaration.
+   [ocaml.explicit_arity] attributes, and split the list constructor [::] when
+   its tuple has no attributes. Attributed cons tuples remain one payload so
+   their attributes survive another v0 conversion. Other unmarked v0 tuples
+   also remain a single syntactic payload; Typecore resolves semantic grouping
+   once it knows the constructor declaration.
 
    The tuple used to encode multiple arguments carries the argument-list
    location, preserving its parentheses span. For a single argument, v0
@@ -905,6 +907,10 @@ module E = struct
         decode_args ~map:(sub.expr sub)
           ~tuple_args:(fun arg ->
             match arg.pexp_desc with
+            | Pexp_tuple _
+              when lid.txt = Longident.Lident "::" && arg.pexp_attributes <> []
+              ->
+              None
             | Pexp_tuple args -> Some args
             | _ -> None)
           ~split_tuple:
@@ -1163,6 +1169,9 @@ module P = struct
         decode_args ~map:(sub.pat sub)
           ~tuple_args:(fun arg ->
             match arg.ppat_desc with
+            | Ppat_tuple _
+              when l.txt = Longident.Lident "::" && arg.ppat_attributes <> [] ->
+              None
             | Ppat_tuple args -> Some args
             | _ -> None)
           ~split_tuple:

compiler/ml/pprintast.ml

@@ -465,10 +465,8 @@ and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit =
     | Ppat_construct ({txt = Lident ("()" | "[]"); _}, _) ->
       simple_pattern ctxt f x
     | Ppat_construct (({txt; _} as li), {txt = po}) -> (
-      if
-        (* FIXME The third field always false *)
-        txt = Lident "::"
-      then pp f "%a" pattern_list_helper x
+      if txt = Lident "::" && List.length po = 2 then
+        pp f "%a" pattern_list_helper x
       else
         match po with
         | [] -> pp f "%a" longident_loc li

compiler/syntax/src/res_comments_table.ml

@@ -296,15 +296,21 @@ let partition_between_lines start_line end_line comments =
 let rec collect_list_patterns acc pattern =
   let open Parsetree in
   match pattern.ppat_desc with
-  | Ppat_construct ({txt = Longident.Lident "::"}, {txt = [pat; rest]}) ->
+  | Ppat_construct ({txt = Longident.Lident "::"}, {txt = [pat; rest]})
+  | Ppat_construct
+      ( {txt = Longident.Lident "::"},
+        {txt = [{ppat_desc = Ppat_tuple [pat; rest]}]} ) ->
     collect_list_patterns (pat :: acc) rest
   | Ppat_construct ({txt = Longident.Lident "[]"}, {txt = []}) -> List.rev acc
   | _ -> List.rev (pattern :: acc)
 
 let rec collect_list_exprs acc expr =
   let open Parsetree in
   match expr.pexp_desc with
-  | Pexp_construct ({txt = Longident.Lident "::"}, {txt = [expr; rest]}) ->
+  | Pexp_construct ({txt = Longident.Lident "::"}, {txt = [expr; rest]})
+  | Pexp_construct
+      ( {txt = Longident.Lident "::"},
+        {txt = [{pexp_desc = Pexp_tuple [expr; rest]}]} ) ->
     collect_list_exprs (expr :: acc) rest
   | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> List.rev acc
   | _ -> List.rev (expr :: acc)

compiler/syntax/src/res_parsetree_viewer.ml

@@ -70,7 +70,10 @@ let collect_list_expressions expr =
   let rec collect acc expr =
     match expr.pexp_desc with
     | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None)
-    | Pexp_construct ({txt = Longident.Lident "::"}, {txt = hd :: [tail]}) ->
+    | Pexp_construct ({txt = Longident.Lident "::"}, {txt = hd :: [tail]})
+    | Pexp_construct
+        ( {txt = Longident.Lident "::"},
+          {txt = [{pexp_desc = Pexp_tuple [hd; tail]}]} ) ->
       collect (hd :: acc) tail
     | _ -> (List.rev acc, Some expr)
   in
@@ -642,7 +645,10 @@ let mod_expr_functor mod_expr =
 let rec collect_patterns_from_list_construct acc pattern =
   let open Parsetree in
   match pattern.ppat_desc with
-  | Ppat_construct ({txt = Longident.Lident "::"}, {txt = [pat; rest]}) ->
+  | Ppat_construct ({txt = Longident.Lident "::"}, {txt = [pat; rest]})
+  | Ppat_construct
+      ( {txt = Longident.Lident "::"},
+        {txt = [{ppat_desc = Ppat_tuple [pat; rest]}]} ) ->
     collect_patterns_from_list_construct (pat :: acc) rest
   | _ -> (List.rev acc, pattern)
 

tests/ounit_tests/ounit_ast_mapper0_tests.ml

@@ -195,13 +195,13 @@ let attr_names attrs = List.map (fun ({Location.txt}, _) -> txt) attrs
 let test_list_constructor_wire_shape _ =
   let lid name = Location.mknoloc (Longident.Lident name) in
   List.iter
-    (fun attrs ->
+    (fun (attrs, payload_attrs) ->
       let expr0 =
         List.fold_right
           (fun value tail ->
             Ast_helper0.Exp.construct ~loc ~attrs (lid "::")
               (Some
-                 (Ast_helper0.Exp.tuple ~loc
+                 (Ast_helper0.Exp.tuple ~loc ~attrs:payload_attrs
                     [
                       Ast_helper0.Exp.constant ~loc
                         (Parsetree0.Pconst_integer (value, None));
@@ -215,24 +215,46 @@ let test_list_constructor_wire_shape _ =
           (fun name tail ->
             Ast_helper0.Pat.construct ~loc ~attrs (lid "::")
               (Some
-                 (Ast_helper0.Pat.tuple ~loc
+                 (Ast_helper0.Pat.tuple ~loc ~attrs:payload_attrs
                     [Ast_helper0.Pat.var ~loc (Location.mknoloc name); tail])))
           ["head"; "next"]
           (Ast_helper0.Pat.construct ~loc (lid "[]") None)
       in
       let expr = map_expr0 expr0 in
       let pat = map_pat0 pat0 in
-      (match (expr.pexp_desc, pat.ppat_desc) with
-      | Pexp_construct (_, {txt = [_; _]}), Ppat_construct (_, {txt = [_; _]})
-        ->
+      (match (payload_attrs, expr.pexp_desc, pat.ppat_desc) with
+      | ( [],
+          Pexp_construct (_, {txt = [_; _]}),
+          Ppat_construct (_, {txt = [_; _]}) ) ->
+        ()
+      | ( _ :: _,
+          Pexp_construct (_, {txt = [{pexp_desc = Pexp_tuple [_; _]}]}),
+          Ppat_construct (_, {txt = [{ppat_desc = Ppat_tuple [_; _]}]}) ) ->
         ()
       | _ ->
-        assert_failure "Unmarked cons payloads must decode to two arguments");
+        assert_failure "Attributed cons payloads must retain their tuple node");
       OUnit.assert_equal ~msg:"list expression wire shape and attributes" expr0
         (map_expr_to0 expr);
       OUnit.assert_equal ~msg:"list pattern wire shape and attributes" pat0
-        (map_pat_to0 pat))
-    [[]; [attr "public_attr" (Parsetree0.PStr [])]]
+        (map_pat_to0 pat);
+      let structure =
+        [
+          Ast_helper.Str.value ~loc Nonrecursive [Ast_helper.Vb.mk ~loc pat expr];
+        ]
+      in
+      ignore (Typemod.type_structure Env.initial_safe_string structure loc);
+      let printed =
+        Res_printer.print_implementation structure ~comments:[] ~width:80
+      in
+      let parsed =
+        Res_driver.parse_implementation_from_source
+          ~display_filename:"ListPayloadAttributes.res" ~source:printed
+      in
+      OUnit.assert_bool "attributed list payloads remain printable"
+        (not parsed.invalid);
+      ignore (Format.asprintf "%a" Pprintast.structure structure))
+    (let attrs = [attr "public_attr" (Parsetree0.PStr [])] in
+     [([], []); (attrs, []); ([], attrs); (attrs, attrs)])
 
 let test_constructor_args_roundtrip_through_ast0 _ =
   let int_expr value =