Record written arrow arity before external lowering

CHANGELOG.md

@@ -27,6 +27,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 bare labeled arrow types (`~x: int => string`) getting no arity: they printed identically to their parenthesized form (`(~x: int) => string`) but did not unify with it. https://github.com/rescript-lang/rescript/pull/8563
 - 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
@@ -42,6 +43,7 @@
 
 - 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
+- Record the written parameter count in parsed arrow arity for externals with phantom `@as(...) _` arguments. External processing recounts after erasing phantoms, so the parser no longer needs to pre-decrement the arity or the printer to compensate for it. https://github.com/rescript-lang/rescript/pull/8563
 - 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/syntax/src/res_core.ml

@@ -263,10 +263,6 @@ module Error_messages = struct
     "Spreading JSX children is no longer supported."
 end
 
-module In_external = struct
-  let status = ref false
-end
-
 let ternary_attr = (Location.mknoloc "res.ternary", Parsetree.PStr [])
 let if_let_attr = (Location.mknoloc "res.iflet", Parsetree.PStr [])
 let make_await_attr loc = (Location.mkloc "res.await" loc, Parsetree.PStr [])
@@ -5059,7 +5055,11 @@ and parse_es6_arrow_type ?current_type_name_path ?inline_types_context ~attrs p
         ?inline_types_context p
     in
     let loc = mk_loc start_pos p.prev_end_pos in
-    Ast_helper.Typ.arrow ~loc ~arity:None {attrs; lbl; typ} return_type
+    (* A bare labeled arrow type [~x: t => u] is a complete one-parameter
+       arrow, exactly like its parenthesized form [(~x: t) => u]; it must
+       carry the same arity or the two spellings produce types that print
+       identically but do not unify. *)
+    Ast_helper.Typ.arrow ~loc ~arity:(Some 1) {attrs; lbl; typ} return_type
   | DocComment _ -> assert false
   | _ ->
     let parameters =
@@ -5075,35 +5075,18 @@ and parse_es6_arrow_type ?current_type_name_path ?inline_types_context ~attrs p
         ?inline_types_context p
     in
     let end_pos = p.prev_end_pos in
-    let return_type_arity = 0 in
-    let _paramNum, typ, _arity =
+    let arity = List.length parameters in
+    let typ =
       List.fold_right
-        (fun {attrs; label = arg_lbl; typ; start_pos} (param_num, t, arity) ->
+        (fun {attrs; label = arg_lbl; typ; start_pos} t ->
           let loc = mk_loc start_pos end_pos in
-          let arity =
-            (* Workaround for ~lbl: @as(json`false`) _, which changes the arity *)
-            match arg_lbl with
-            | Labelled _s ->
-              let typ_is_any =
-                match typ.ptyp_desc with
-                | Ptyp_any -> true
-                | _ -> false
-              in
-              let has_as =
-                Ext_list.exists typ.ptyp_attributes (fun (x, _) -> x.txt = "as")
-              in
-              if !In_external.status && typ_is_any && has_as then arity - 1
-              else arity
-            | _ -> arity
-          in
-          let t_arg =
-            Ast_helper.Typ.arrow ~loc ~arity:None {attrs; lbl = arg_lbl; typ} t
-          in
-          if param_num = 1 then
-            (param_num - 1, Ast_uncurried.uncurried_type ~arity t_arg, 1)
-          else (param_num - 1, t_arg, arity + 1))
-        parameters
-        (List.length parameters, return_type, return_type_arity + 1)
+          Ast_helper.Typ.arrow ~loc ~arity:None {attrs; lbl = arg_lbl; typ} t)
+        parameters return_type
+    in
+    let typ =
+      match parameters with
+      | [] -> typ
+      | _ -> Ast_uncurried.uncurried_type ~arity typ
     in
     {
       typ with
@@ -6640,13 +6623,9 @@ and parse_type_definition_or_extension ~attrs p =
 
 (* external value-name : typexp = external-declaration *)
 and parse_external_def ~attrs ~start_pos p =
-  let in_external = !In_external.status in
-  In_external.status := true;
   Parser.leave_breadcrumb p Grammar.External;
   Fun.protect
-    ~finally:(fun () ->
-      Parser.eat_breadcrumb p;
-      In_external.status := in_external)
+    ~finally:(fun () -> Parser.eat_breadcrumb p)
     (fun () ->
       Parser.expect Token.External p;
       let name, loc = parse_lident p in

compiler/syntax/src/res_parsetree_viewer.ml

@@ -1,9 +1,6 @@
 open Parsetree
 
 let arrow_type ?(max_arity = max_int) ct =
-  let has_as_attr attrs =
-    Ext_list.exists attrs (fun (x, _) -> x.Asttypes.txt = "as")
-  in
   let rec process attrs_before acc typ max_arity =
     match typ with
     | _ when max_arity < 0 -> (attrs_before, List.rev acc, typ)
@@ -27,19 +24,7 @@ let arrow_type ?(max_arity = max_int) ct =
      ptyp_desc = Ptyp_arrow {arg = {lbl = Labelled _ | Optional _} as arg; ret};
      ptyp_attributes = _attrs;
     } ->
-      (* Res_core.parse_es6_arrow_type has a workaround that removed an extra arity for the function if the
-         argument is a Ptyp_any with @as attribute i.e. ~x: @as(`{prop: value}`) _.
-
-         When this case is encountered we add that missing arity so the arrow is printed properly.
-      *)
-      let arity =
-        match arg.typ with
-        | {ptyp_desc = Ptyp_any; ptyp_attributes = attrs1}
-          when has_as_attr attrs1 ->
-          max_arity
-        | _ -> max_arity - 1
-      in
-      process attrs_before (arg :: acc) ret arity
+      process attrs_before (arg :: acc) ret (max_arity - 1)
     | typ -> (attrs_before, List.rev acc, typ)
   in
   match ct with

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

@@ -42,7 +42,7 @@ type curriedAnnot = int => int => int
 type nodeAttr = @attr (string => unit)
 type argAttr = (@as("x") ~foo: string, int) => int
 
-// phantom @as arguments in externals (arity != arrow-chain length)
+// phantom @as arguments: written arity differs from lowered call arity
 @val
 external phantom: (~a: int, @as(json`false`) _, ~c: string) => unit = "phantom"
 

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

@@ -42,7 +42,7 @@ type curriedAnnot = int => int => int
 type nodeAttr = @attr (string => unit)
 type argAttr = (@as("x") ~foo: string, int) => int
 
-// phantom @as arguments in externals (arity != arrow-chain length)
+// phantom @as arguments: written arity differs from lowered call arity
 @val
 external phantom: (~a: int, @as(json`false`) _, ~c: string) => unit = "phantom"
 

tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt

@@ -46,5 +46,5 @@ module Error3 =
     type nonrec observation =
       {
       observed: int ;
-      onStep: currentValue:unit -> [%rescript.typehole ] }
+      onStep: currentValue:unit -> [%rescript.typehole ] (a:1) }
   end

tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt

@@ -12,23 +12,23 @@ let (t : a:int -> b:int -> int (a:2)) = xf
 let (t : ?a:int -> ?b:int -> int (a:2)) = xf
 let (t : int -> int -> int -> int (a:1) (a:1) (a:1)) = xf
 let (t : a:int -> b:int -> c:int -> int (a:1) (a:1) (a:1)) = xf
-type nonrec t = f:int -> string
-type nonrec t = ?f:int -> string
-let (f : f:int -> string) = fx
-let (f : ?f:int -> string) = fx
 type nonrec t = f:int -> string (a:1)
-type nonrec t = f:int -> string
+type nonrec t = ?f:int -> string (a:1)
+let (f : f:int -> string (a:1)) = fx
+let (f : ?f:int -> string (a:1)) = fx
+type nonrec t = f:int -> string (a:1)
+type nonrec t = f:int -> string (a:1)
+type nonrec t = f:(int -> string (a:1)) -> float (a:1)
 type nonrec t = f:(int -> string (a:1)) -> float (a:1)
-type nonrec t = f:(int -> string (a:1)) -> float
-type nonrec t = f:int -> string -> float (a:1)
+type nonrec t = f:int -> string -> float (a:1) (a:1)
 type nonrec t =
   a:int[@attrBeforeLblA ] ->
     b:int[@attrBeforeLblB ] -> ((float)[@attr ]) -> unit (a:3)
 type nonrec t =
   ((a:int ->
       ((b:int -> ((float)[@attr ]) -> unit (a:1) (a:1))[@attrBeforeLblB ]) (a:1))
   [@attrBeforeLblA ])
-type nonrec t = a:int[@attr ] -> unit
+type nonrec t = a:int[@attr ] -> unit (a:1)
 type nonrec 'a getInitialPropsFn =
   < query: string dict  ;req: < .. >  nullable   >  ->
     < .. >  Promise.t (a:1)