Harden the Parsetree0 PPX bridge

AGENTS.md

@@ -278,6 +278,14 @@ The compiler is designed for fast feedback loops and scales to large codebases:
 - Include appropriate tests with all changes
 - Build must pass before committing
 
+### Stacked pull requests
+
+When a PR depends on another unmerged PR, create a native GitHub stack with
+`gh stack` rather than only targeting the preceding feature branch. Keep the
+branches linear and in the same repository, and list branches or PRs from
+bottom to top. For existing PRs, use `gh stack link BOTTOM_PR [NEXT_PR...]`,
+then verify that GitHub reports stack metadata and runs CI for every PR.
+
 ### Code Quality
 
 - Follow existing patterns in the codebase

CHANGELOG.md

@@ -28,6 +28,7 @@
 
 - Preserve parentheses around multiplication, division, and modulo expressions used as exponents. https://github.com/rescript-lang/rescript/pull/8550
 - Enforce function arity in interface/module inclusion and type coercion. Previously a curried implementation (e.g. `int => int => int`) could satisfy an uncurried interface (`(int, int) => int`) or be coerced to it, which could miscompile calls made through the interface type. Such mismatches are now compile errors with an explanatory hint. https://github.com/rescript-lang/rescript/pull/8559
+- Fix losses of fidelity when code passes through an external PPX: the internal `@res.async` marker no longer leaks into the program, attributes on an arrow type or on an `await` expression are no longer dropped or relocated (previously this could crash the formatter), JSX elements keep their closing tag, and PPX-emitted OCaml-style `function` is desugared instead of crashing the compiler. https://github.com/rescript-lang/rescript/pull/8561
 - Preserve multibyte characters when wrapping long source lines in compiler code frames. https://github.com/rescript-lang/rescript/pull/8520
 - Fix reanalyze optional-argument diagnostics for functions passed or returned as first-class values. https://github.com/rescript-lang/rescript/pull/8321
 - Prevent the developer playground from loading stale compiler and library assets after PR preview updates. https://github.com/rescript-lang/rescript/pull/8556
@@ -42,6 +43,7 @@
 
 - Sync the platform npm package's compiler binaries (`packages/@rescript/<platform>/bin`) via dune promotion on every `dune build`, instead of Makefile/CI copy steps that only ran when make did: a plain `dune build` can no longer leave `cli/*.js` and the test harnesses running a stale compiler. https://github.com/rescript-lang/rescript/pull/8560
 - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555
+- Give marshaled current-parsetree streams (`-as-pp`, `res_parser -print binary`) their own magic numbers, distinct from the frozen Parsetree0 wire format used for external PPXes. https://github.com/rescript-lang/rescript/pull/8561
 - Add the `-check-lam` compiler option, enable Lambda invariant checking in compiler tests, and remove build-profile-dependent checking. https://github.com/rescript-lang/rescript/pull/8534
 - Replace `-bs-diagnose` with `-debug-ir` and make IR diagnostic artifacts deterministic, compilation-local, and easy to clean. https://github.com/rescript-lang/rescript/pull/8535
 - Replace CPPO-based browser conditionals with Dune-selected native and playground compiler implementations. https://github.com/rescript-lang/rescript/pull/8541

compiler/common/ml_binary.ml

@@ -27,8 +27,8 @@ type _ kind = Ml : Parsetree.structure kind | Mli : Parsetree.signature kind
 type ast0 = Impl of Parsetree0.structure | Intf of Parsetree0.signature
 
 let magic_of_ast0 : ast0 -> string = function
-  | Impl _ -> Config.ast_impl_magic_number
-  | Intf _ -> Config.ast_intf_magic_number
+  | Impl _ -> Config.ast0_impl_magic_number
+  | Intf _ -> Config.ast0_intf_magic_number
 
 let to_ast0 : type a. a kind -> a -> ast0 =
  fun kind ast ->
@@ -59,5 +59,5 @@ let ast0_roundtrip : type a. a kind -> a -> a =
   | Mli -> ast |> to_ast0 Mli |> ast0_to_signature
 
 let magic_of_kind : type a. a kind -> string = function
-  | Ml -> Config.ast_impl_magic_number
-  | Mli -> Config.ast_intf_magic_number
+  | Ml -> Config.ast0_impl_magic_number
+  | Mli -> Config.ast0_intf_magic_number

compiler/ext/config.ml

@@ -1,8 +1,17 @@
 let cmi_magic_number = "Caml1999I022"
 
-and ast_impl_magic_number = "Caml1999M022"
+(* Magic numbers for marshaled values of the *current* parsetree, whose layout
+   changes across compiler versions. *)
+and ast_impl_magic_number = "ResImpl01300"
 
-and ast_intf_magic_number = "Caml1999N022"
+and ast_intf_magic_number = "ResIntf01300"
+
+(* Magic numbers of the frozen Parsetree0 (OCaml 4.06) layout used on the
+   external-PPX wire. They must never be written in front of a
+   current-parsetree value. *)
+and ast0_impl_magic_number = "Caml1999M022"
+
+and ast0_intf_magic_number = "Caml1999N022"
 
 and cmt_magic_number = "Caml1999T022"
 

compiler/ext/config.mli

@@ -19,13 +19,23 @@
 val load_path : string list ref
 
 val cmi_magic_number : string
-
 (* Magic number for compiled interface files *)
+
 val ast_intf_magic_number : string
+(* Magic number for a marshaled current-parsetree signature (layout changes
+   across compiler versions; distinct from the frozen Parsetree0 wire format) *)
 
-(* Magic number for file holding an interface syntax tree *)
 val ast_impl_magic_number : string
+(* Magic number for a marshaled current-parsetree structure (layout changes
+   across compiler versions; distinct from the frozen Parsetree0 wire format) *)
+
+val ast0_intf_magic_number : string
+(* Magic number for a frozen Parsetree0 (OCaml 4.06) interface syntax tree, as
+   used on the external-PPX wire *)
+
+val ast0_impl_magic_number : string
+(* Magic number for a frozen Parsetree0 (OCaml 4.06) implementation syntax
+   tree, as used on the external-PPX wire *)
 
-(* Magic number for file holding an implementation syntax tree *)
 val cmt_magic_number : string
 (* Magic number for compiled interface files *)

compiler/ml/ast_mapper_from0.ml

@@ -141,8 +141,24 @@ module T = struct
     | Ptyp_var s -> Typ.var ~loc ~attrs s
     | Ptyp_arrow (lbl, t1, t2) ->
       let lbl = Asttypes.to_arg_label lbl in
-      Typ.arrow ~loc ~arity:None
-        {attrs; lbl; typ = sub.typ sub t1}
+      (* [Ast_mapper_to0] flattens the current parsetree's node/argument
+         attribute split into the v0 arrow's single attribute list, marking
+         the boundary with [_res.arrow_node_attrs] when node attributes are
+         present: node attributes come before the marker, argument attributes
+         after it. Without a marker, everything is an argument attribute. *)
+      let node_attrs, arg_attrs =
+        let rec split acc = function
+          | ({txt = "_res.arrow_node_attrs"}, _) :: rest ->
+            Some (List.rev acc, rest)
+          | a :: rest -> split (a :: acc) rest
+          | [] -> None
+        in
+        match split [] attrs with
+        | Some (node_attrs, arg_attrs) -> (node_attrs, arg_attrs)
+        | None -> ([], attrs)
+      in
+      Typ.arrow ~loc ~attrs:node_attrs ~arity:None
+        {attrs = arg_attrs; lbl; typ = sub.typ sub t1}
         (sub.typ sub t2)
     | Ptyp_tuple tyl -> Typ.tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
     | Ptyp_constr (lid, tl) -> (
@@ -345,13 +361,6 @@ module E = struct
         | _ -> false)
       attrs
 
-  let remove_await_attribute attrs =
-    List.filter
-      (function
-        | {Location.txt = "res.await"}, _ -> false
-        | _ -> true)
-      attrs
-
   let extract_for_of_attribute attrs =
     List.find_map
       (function
@@ -468,20 +477,46 @@ module E = struct
     in
     match desc with
     | _ when has_await_attribute attrs ->
-      let attrs = remove_await_attribute e.pexp_attributes in
-      let e = sub.expr sub {e with pexp_attributes = attrs} in
-      await ~loc e
+      (* [Ast_mapper_to0] merges the await node's attributes and the inner
+         expression's attributes into the one v0 slot, with [res.await] as
+         the boundary: await-node attributes before it, inner attributes
+         after it. *)
+      let await_attrs0, inner_attrs0 =
+        let rec split acc = function
+          | ({Location.txt = "res.await"}, _) :: rest -> (List.rev acc, rest)
+          | a :: rest -> split (a :: acc) rest
+          | [] -> (List.rev acc, [])
+        in
+        split [] e.pexp_attributes
+      in
+      let inner = sub.expr sub {e with pexp_attributes = inner_attrs0} in
+      await ~loc ~attrs:(sub.attributes sub await_attrs0) inner
     | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
     | Pexp_constant x -> constant ~loc ~attrs (map_constant x)
     | Pexp_let (r, vbs, e) ->
       let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e)
     | Pexp_fun (lab, def, p, e) ->
       let lab = Asttypes.to_arg_label lab in
       let async = Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.async") in
+      (* [res.async] is bridge metadata added by [Ast_mapper_to0]; it is
+         decoded into the [async] flag and must not survive as a real
+         attribute. *)
+      let attrs = attrs |> List.filter (fun ({txt}, _) -> txt <> "res.async") in
       fun_ ~loc ~attrs ~async ~arity:None lab
         (map_opt (sub.expr sub) def)
         (sub.pat sub p) (sub.expr sub e)
-    | Pexp_function _ -> assert false
+    | Pexp_function cases ->
+      (* The current parsetree has no [function] construct; it can only come
+         from an external PPX emitting OCaml-style [function | p -> e].
+         Desugar to [fun x -> match x with | p -> e] with an unshadowable
+         parameter name, as the OCaml parser would. *)
+      let param = "*function*" in
+      let pat = Pat.var ~loc (Location.mkloc param loc) in
+      let scrutinee =
+        ident ~loc (Location.mkloc (Longident.Lident param) loc)
+      in
+      let body = match_ ~loc scrutinee (sub.cases sub cases) in
+      fun_ ~loc ~attrs ~async:false ~arity:None Nolabel None pat body
     | Pexp_apply ({pexp_desc = Pexp_ident tag_name}, args)
       when has_jsx_attribute () -> (
       let attrs = attrs |> List.filter (fun ({txt}, _) -> txt <> "JSX") in
@@ -502,8 +537,18 @@ module E = struct
       match children with
       | None -> jsx_unary_element ~loc ~attrs jsx_tag_name props
       | Some children ->
+        (* The v0 encoding has no closing-tag information; synthesize one
+           matching the opening tag, otherwise the printer emits an element
+           that is never closed. *)
+        let closing_tag =
+          {
+            Pt.jsx_closing_container_tag_start = Lexing.dummy_pos;
+            jsx_closing_container_tag_name = jsx_tag_name;
+            jsx_closing_container_tag_end = Lexing.dummy_pos;
+          }
+        in
         jsx_container_element ~loc ~attrs jsx_tag_name props Lexing.dummy_pos
-          children None)
+          children (Some closing_tag))
     | Pexp_apply (e, l) ->
       let e =
         match (e.pexp_desc, l) with

compiler/ml/ast_mapper_to0.ml

@@ -124,10 +124,22 @@ module T = struct
     | Ptyp_var s -> var ~loc ~attrs s
     | Ptyp_arrow {arg; ret; arity} -> (
       let lbl = Asttypes.to_noloc arg.lbl in
+      (* v0 arrows have a single attribute slot for what the current parsetree
+         splits into node attributes and argument attributes. Keep the split
+         recoverable: when node attributes are present, separate the two lists
+         with an internal marker that [Ast_mapper_from0] strips again. Without
+         node attributes (the common case) the encoding is unchanged. *)
+      let arg_attrs = sub.attributes sub arg.attrs in
+      let merged_attrs =
+        if attrs = [] then arg_attrs
+        else
+          attrs
+          @ ({txt = "_res.arrow_node_attrs"; loc = Location.none}, Pt.PStr [])
+            :: arg_attrs
+      in
       let typ0 =
-        arrow ~loc
-          ~attrs:(attrs @ sub.attributes sub arg.attrs)
-          lbl (sub.typ sub arg.typ) (sub.typ sub ret)
+        arrow ~loc ~attrs:merged_attrs lbl (sub.typ sub arg.typ)
+          (sub.typ sub ret)
       in
       match arity with
       | None -> typ0
@@ -526,11 +538,16 @@ module E = struct
       open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
     | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
     | Pexp_await e ->
+      (* Single v0 attribute slot for two nodes: the await node's own
+         attributes go in front of the [res.await] marker, the inner
+         expression's attributes after it, so [Ast_mapper_from0] can split
+         them again. *)
       let e = sub.expr sub e in
       {
         e with
         pexp_attributes =
-          (Location.mknoloc "res.await", Pt.PStr []) :: e.pexp_attributes;
+          attrs
+          @ ((Location.mknoloc "res.await", Pt.PStr []) :: e.pexp_attributes);
       }
     | Pexp_jsx_element
         (Jsx_fragment

compiler/syntax/src/res_parsetree_viewer.ml

@@ -13,6 +13,12 @@ let arrow_type ?(max_arity = max_int) ct =
     | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel; attrs = []} as arg; ret}}
       ->
       process attrs_before (arg :: acc) ret (max_arity - 1)
+    | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel} as arg; ret}} when acc = []
+      ->
+      (* The head argument is always consumed, attributes or not: returning
+         the input node itself as the "return type" would make the printer
+         recurse forever. *)
+      process attrs_before (arg :: acc) ret (max_arity - 1)
     | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel}}; ptyp_attributes = _attrs}
       as return_type ->
       let args = List.rev acc in

tests/ounit_tests/ounit_ast_mapper0_tests.ml

@@ -67,6 +67,37 @@ let test_record_rest_roundtrips_through_ast0 _ =
     ()
   | _ -> assert_failure "Expected record rest after ast0 roundtrip"
 
+let map_expr0 e =
+  Ast_mapper_from0.default_mapper.expr Ast_mapper_from0.default_mapper e
+
+(* A PPX can emit OCaml-style [function | p -> e]; the bridge must desugar it
+   to [fun x -> match x with | p -> e] rather than crash. *)
+let test_function_cases_desugar_to_fun_match _ =
+  let case0 =
+    {
+      Parsetree0.pc_lhs = Ast_helper0.Pat.any ~loc ();
+      pc_guard = None;
+      pc_rhs =
+        Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer ("1", None));
+    }
+  in
+  let expr = map_expr0 (Ast_helper0.Exp.function_ ~loc [case0]) in
+  match expr.pexp_desc with
+  | Parsetree.Pexp_fun
+      {
+        arg_label = Nolabel;
+        default = None;
+        lhs = {ppat_desc = Ppat_var {txt = param}};
+        rhs =
+          {
+            pexp_desc =
+              Pexp_match ({pexp_desc = Pexp_ident {txt = Lident scrutinee}}, [_]);
+          };
+      } ->
+    OUnit.assert_equal ~msg:"scrutinee is the introduced parameter" param
+      scrutinee
+  | _ -> assert_failure "Expected fun x -> match x with ... after desugaring"
+
 let suites =
   __FILE__
   >::: [
@@ -76,4 +107,6 @@ let suites =
          >:: test_malformed_internal_record_rest_attr_fails;
          "record_rest_roundtrips_through_ast0"
          >:: test_record_rest_roundtrips_through_ast0;
+         "function_cases_desugar_to_fun_match"
+         >:: test_function_cases_desugar_to_fun_match;
        ]

tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res

@@ -0,0 +1,50 @@
+// Round-trip coverage for functions and arrow types through the
+// Parsetree0 bridge (ast_mapper_to0 / ast_mapper_from0).
+
+// n-ary functions and arity-1 sugar
+let add = (a, b, c) => a + b + c
+let id = x => x
+
+// labeled, optional, and default parameters
+let labeled = (~x, ~y) => x - y
+let optional = (~x=?, ~y=1, z) => {
+  switch x {
+  | Some(x) => x + y + z
+  | None => y + z
+  }
+}
+
+// async functions, with and without newtypes
+let fetch = async (url, ~timeout) => url ++ Int.toString(timeout)
+let poly = async (type a, x: a) => x
+let f = async (type a, ()) => await Promise.resolve()
+
+// await with attributes on both the await node and the inner expression
+let g = async () => @outer await (@inner Promise.resolve(1))
+
+// nested and curried-looking shapes must stay distinct
+let curried = a => b => a + b
+let nested = (a, b) => (c, d) => a + b + c + d
+
+// underscore apply sugar
+let underscore = add(1, _, 3)
+
+// explicit partial application
+let partial = add(1, ...)
+
+// arrow types: labeled, optional, uncurried groups, nested functions
+type cb = (~x: int, ~y: float) => string
+type opt = (~x: int=?, unit) => int
+type nested2 = (int, int) => (string, string) => bool
+type curriedAnnot = int => int => int
+
+// attributes on the arrow node vs on an argument
+type nodeAttr = @attr (string => unit)
+type argAttr = (@as("x") ~foo: string, int) => int
+
+// phantom @as arguments in externals (arity != arrow-chain length)
+@val
+external phantom: (~a: int, @as(json`false`) _, ~c: string) => unit = "phantom"
+
+// external with uncurried callback argument
+@val external onEvent: (string, (~event: string) => unit) => unit = "on"

tests/syntax_tests/data/ast-mapping/expected/ForAwaitOfExpressions.res.txt

@@ -1,18 +1,16 @@
 // Test for await..of AST mapping
 
-let testForAwaitOf =
-  @res.async
-  async () => {
-    let iterable = asyncIterable
+let testForAwaitOf = async () => {
+  let iterable = asyncIterable
 
-    // Basic for await..of
-    for await x of iterable {
-      Console.log(x)
-    }
+  // Basic for await..of
+  for await x of iterable {
+    Console.log(x)
+  }
 
-    // Nested async loop body
-    for await item of iterable {
-      let result = await Promise.resolve(item + 1)
-      Console.log(result)
-    }
+  // Nested async loop body
+  for await item of iterable {
+    let result = await Promise.resolve(item + 1)
+    Console.log(result)
   }
+}