flambda-backend: Fix layout annotation encoding to work better with p…

…pxlib (#2234)

* add jane prefix

* add test

parsing/jane_syntax.ml

@@ -211,7 +211,7 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) :
     let structure_item_of_none =
       { pstr_desc =
           Pstr_attribute
-            { attr_name = Location.mknoloc "none";
+            { attr_name = Location.mknoloc "jane.none";
               attr_payload = PStr [];
               attr_loc = Location.none
             };
@@ -278,7 +278,8 @@ module Make_payload_protocol_of_stringable (Stringable : Stringable) :
         | _ -> raise Unexpected
 
       let is_none_structure_item = function
-        | { pstr_desc = Pstr_attribute { attr_name = { txt = "none" } } } ->
+        | { pstr_desc = Pstr_attribute { attr_name = { txt = "jane.none" } } }
+          ->
           true
         | _ -> false
 

testsuite/tests/parsetree/source_jane_street.ml

@@ -9,6 +9,7 @@
 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 (type (a : immediate) (b : immediate) c) (x : a) = x;;
 
 let f y (type a : immediate) (x : a) = x;;
 let f y (type (a : immediate)) (x : a) = x;;
@@ -17,6 +18,8 @@ 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;;
+let f y (type (a : immediate) (b : immediate) c) = y;;
+
 
 (* Just newtypes, no value parameters *)
 let f (type a : immediate) (type b : immediate)

testsuite/tests/parsetree/test.ml

@@ -61,7 +61,7 @@ let test parse_fun pprint print map filename ~extra_checks =
   | ast ->
       let str = to_string pprint ast in
       begin
-        match extra_checks str with
+        match extra_checks (to_string print ast) str with
         | Ok () -> ()
         | Error reason ->
             Printf.printf "%s: FAIL, %s\n" filename reason;
@@ -112,7 +112,7 @@ let rec process path ~extra_checks =
       path
       ~extra_checks
 
-let process ?(extra_checks = fun _ -> Ok ()) text = process text ~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.
@@ -128,7 +128,7 @@ let process ?(extra_checks = fun _ -> Ok ()) text = process text ~extra_checks
   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_all_printed_attributes_and_extensions_start_with text ~prefix =
   let check introduction_string =
     String.split_on_char '[' text
     |> List.for_all (fun s ->
@@ -146,14 +146,46 @@ let check_all_attributes_and_extensions_start_with text ~prefix =
            prefix)
 ;;
 
+let check_all_ast_attributes_and_extensions_start_with raw_parsetree_str ~prefixes =
+  (* Sadly can't use Ast_mapper here because it decodes Jane Syntax by default and
+     we will need quite a bit of code duplication for it to work for this use case. *)
+  let check introduction_string =
+    Misc.Stdlib.String.split_on_string ~split_on:(introduction_string ^ " \"")
+      raw_parsetree_str
+    |> List.tl
+    |> List.for_all (fun s ->
+          List.exists
+            (fun prefix -> String.starts_with s ~prefix)
+            prefixes)
+  in
+  if check "extension" && check "attribute"
+  then Ok ()
+  else
+      Error
+        (Printf.sprintf
+          "Printast produced an extension node or attribute that doesn't \
+           begin with one of [%s]"
+           (String.concat ", " prefixes))
+;;
+
 let () =
   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
+  process "source_jane_street.ml" ~extra_checks:(fun raw_parsetree_str text ->
+  (* Additionally check that:
+
+     1. Jane Street language extensions only use "extension." and "jane." prefixed
+     attributes and exntensions for its parsetree encoding. This is important for
+     ppx support.
+
+     2. 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");
+    Result.bind
+      (check_all_ast_attributes_and_extensions_start_with raw_parsetree_str
+        ~prefixes:["extension."; "jane."; "test."])
+      (fun () -> check_all_printed_attributes_and_extensions_start_with text
+                    ~prefix:"test"));
 ;;