flambda-backend: Add Jane_syntax Pprintast tests (#1727)

* Add `Pprintast` tests

* Transplant existing pprintast tests

* Add one more interesting test and delimit tests with double semis

* Complain if pprintast produces Jane Syntax attributes/extension nodes

* clarify names according to review

* Update a comment

Author: ncik-roberts

testsuite/tests/comprehensions/syntax.ml

@@ -17,41 +17,6 @@ let this_test_tests_that =
 
 (******************************************************************************)
 
-this_test_tests_that
-  "we print list comprehensions correctly"
-;;
-
-let test_printing parsed =
-  let expr = Parse.expression (Lexing.from_string parsed) in
-  let printed = Pprintast.string_of_expression expr in
-  if parsed = printed then
-    printf
-      "Parsing and printing round-tripped successfully!\n\n\
-       %s\n"
-      parsed
-  else
-    printf
-      "Parsing and printing failed to round-trip:\n\n\
-       %s\n\n\
-       became\n\n\
-       %s\n"
-      parsed printed
-;;
-
-let () =
-  (* The wonky formatting here is the best way to keep the line
-     break visible in the string and also keep things within 80
-     characters here *)
- test_printing
-    "[(i, j)\n\
-    \  for i = 0 to 9 when (i mod 2) = 0 for j = 0 to i when (i > 4) && (j > 4)]";
- (* Check that only user attributes survive pprintast *)
- test_printing
-   "(([((x)[@attr1 ]) for ((x)[@attr2 ]) in (([])[@attr3 ])])[@attr4 ])";
-;;
-
-(******************************************************************************)
-
 this_test_tests_that
   "compiler-generated attributes start with \"jane.\""
 ;;

testsuite/tests/comprehensions/syntax.reference

@@ -1,13 +1,3 @@
-**** Test that we print list comprehensions correctly ****
-
-Parsing and printing round-tripped successfully!
-
-[(i, j)
-  for i = 0 to 9 when (i mod 2) = 0 for j = 0 to i when (i > 4) && (j > 4)]
-Parsing and printing round-tripped successfully!
-
-(([((x)[@attr1 ]) for ((x)[@attr2 ]) in (([])[@attr3 ])])[@attr4 ])
-
 **** Test that compiler-generated attributes start with "jane." ****
 
 User attributes [@...] and extension nodes [%...] found:

testsuite/tests/lib-array/iarray_syntax.ml

@@ -0,0 +1,118 @@
+(* Confirm that Pprintast round-trips with Jane Street experimental syntax.
+   test.ml is the driver that runs this test. test.ml also checks that
+   Pprintast doesn't print the attribute encoding.
+*)
+
+(***********)
+(* Layouts *)
+
+let f (type a : immediate) (x : a) = x;;
+let f (type (a : immediate)) (x : a) = x;;
+let f (type (a : immediate) (b : immediate)) (x : a) = x;;
+
+let f y (type a : immediate) (x : a) = x;;
+let f y (type (a : immediate)) (x : a) = x;;
+let f y (type (a : immediate) (b : immediate)) (x : a) = x;;
+
+let f y (type a : immediate) = y;;
+let f y (type (a : immediate)) = y;;
+let f y (type (a : immediate) (b : immediate)) = y;;
+
+(* Just newtypes, no value parameters *)
+let f (type a : immediate) (type b : immediate)
+      (type (c : immediate) (d : immediate))
+  = ();;
+
+(******************)
+(* Comprehensions *)
+
+(* simple range *)
+[: x for x = 0 to 100 :];;
+[| x for x = 0 to 100 |];;
+[  x for x = 0 to 100   ];;
+
+(* simple in-comprehension *)
+[: x for x in [: 1; 2; 3 :] :];;
+[| x for x in [| 1; 2; 3 |] |];;
+[  x for x in [  1; 2; 3  ]  ];;
+
+(* complex comprehension *)
+[: x + y
+    for x in [: 1; 2; 3 :]
+    for y in [: 4; 5; 6 :]
+    when x + y > 6
+:];;
+[| x + y
+    for x in [| 1; 2; 3 |]
+    for y in [| 4; 5; 6 |]
+    when x + y > 6
+|];;
+[  x + y
+    for x in [ 1; 2; 3 ]
+    for y in [ 4; 5; 6 ]
+    when x + y > 6
+];;
+
+
+(* User-written attributes *)
+([(x[@test.attr1]) for (x[@test.attr2]) in ([][@test.attr3])] [@test.attr4]);;
+
+(*********)
+(* Local *)
+
+(* parameters *)
+let f (local_ x) ~(local_ y) ~z:(local_ z) ?foo:(local_ w = 1) = x + y + z + w;;
+
+(* bindings *)
+let g () =
+  let local_ f = () in
+  let local_ f : 'a . 'a -> 'a = fun x -> x in
+  let local_ f x y = x + y in
+  let local_ f : int -> int = fun z -> z + z in
+  (* nroberts: we should reenable this test when we fix
+   * pprint_ast to put the (int -> int) annotation back in
+   * the correct position. *)
+  (*let local_ f x y : int -> int = fun z -> x + y + z in*)
+  ();;
+
+(* expressions *)
+let g () = local_
+  let f = local_ () in
+  let f x y = local_ (x + y) in
+  local_ ();;
+
+(* types *)
+type record =
+  { global_ field : int
+  ; normal_field : int
+  };;
+
+type 'a parameterized_record = {
+  mutable a: 'a ;
+  global_ c: 'a };;
+
+type fn = local_ int -> local_ int;;
+type nested_fn = (local_ int -> local_ int) -> local_ int;;
+type ('a, 'b) labeled_fn =
+  a:local_ 'a -> ?b:local_ b -> local_ 'a -> (int -> local_ 'b);;
+
+(*******************)
+(* Include functor *)
+
+module T = struct
+  include functor F
+end;;
+
+module type S = sig
+  include functor F
+end;;
+
+(********************)
+(* Immutable arrays *)
+
+let f x =
+  match x with
+  | [::] -> [::]
+  | ([:x:] [@test.attr1]) -> (([:x:])[@test.attr1])
+  | ([:x;y:] [@test.attr2][@test.attr3]) ->
+      ([:x;y:] [@test.attr2][@test.attr3]);;

testsuite/tests/lib-array/iarray_syntax.reference

@@ -1,6 +1,6 @@
 (* TEST
    include ocamlcommon
-   readonly_files = "source.ml"
+   readonly_files = "source.ml source_jane_street.ml"
 *)
 
 (* (c) Alain Frisch / Lexifi *)
@@ -52,14 +52,22 @@ let to_tmp_file print_fun ast =
   close_out oc;
   fn
 
-let test parse_fun pprint print map filename =
+let test parse_fun pprint print map filename ~extra_checks =
   match from_file parse_fun filename with
   | exception exn ->
       Printf.printf "%s: FAIL, CANNOT PARSE\n" filename;
       report_err exn;
       print_endline "====================================================="
   | ast ->
       let str = to_string pprint ast in
+      begin
+        match extra_checks str with
+        | Ok () -> ()
+        | Error reason ->
+            Printf.printf "%s: FAIL, %s\n" filename reason;
+            print_endline str;
+            print_endline"====================================================="
+      end;
       match from_string parse_fun str with
       | exception exn ->
           Printf.printf "%s: FAIL, CANNOT REPARSE\n" filename;
@@ -79,28 +87,73 @@ let test parse_fun pprint print map filename =
             print_endline"====================================================="
           end
 
-let test parse_fun pprint print map filename =
-  try test parse_fun pprint print map filename
+let test parse_fun pprint print map filename ~extra_checks =
+  try test parse_fun pprint print map filename ~extra_checks
   with exn -> report_err exn
 
-let rec process path =
+let rec process path ~extra_checks =
   if Sys.is_directory path then
     let files = Sys.readdir path in
-    Array.iter (fun s -> process (Filename.concat path s)) files
+    Array.iter (fun s -> process (Filename.concat path s) ~extra_checks) files
   else if Filename.check_suffix path ".ml" then
     test
       Parse.implementation
       Pprintast.structure
       Printast.implementation
       (fun mapper -> mapper.Ast_mapper.structure)
       path
+      ~extra_checks
   else if Filename.check_suffix path ".mli" then
     test
       Parse.interface
       Pprintast.signature
       Printast.interface
       (fun mapper -> mapper.Ast_mapper.signature)
       path
+      ~extra_checks
+
+let process ?(extra_checks = fun _ -> Ok ()) text = process text ~extra_checks
+
+(* Produce an error if any attribute/extension node does not start with the
+   text prefix.
+
+   This over-conservatively produces an error for attributes/extension nodes
+   that don't appear literally as '[@' or '[%' followed immediately by an
+   identifier.  Some things that aren't handled:
+      - [@ blah]
+      - [% blah]
+      - [@@blah]
+      - [%%blah]
+
+  We've chosen to keep those constructs out of the test file in preference
+  to updating this logic to properly handle them (which is hard).
+*)
+let check_all_attributes_and_extensions_start_with text ~prefix =
+  let check introduction_string =
+    String.split_on_char '[' text
+    |> List.for_all (fun s ->
+        if String.starts_with s ~prefix:introduction_string
+        then String.starts_with s ~prefix:(introduction_string ^ prefix)
+        else true)
+  in
+  if check "%" && check "@"
+  then Ok ()
+  else
+      Error
+        (Printf.sprintf
+          "Pprintast produced an extension node or attribute that doesn't \
+           begin with `%s'"
+           prefix)
+;;
 
 let () =
-  process "source.ml"
+  process "source.ml";
+  Language_extension.enable_maximal ();
+  process "source_jane_street.ml" ~extra_checks:(fun text ->
+  (* Check that printing Jane Street language extensions produces no more
+     attributes or extension nodes than the input program, all of whose
+     attributes begin with "test". This ensures that Jane Syntax attributes
+     aren't printed.
+   *)
+    check_all_attributes_and_extensions_start_with text ~prefix:"test");
+;;