Add provisional %raw syntax for fixed external arguments

changes/raw-external-arguments.feature.md

@@ -0,0 +1 @@
+- Add `%raw(...)` arguments for externals, for example `external assign: (%raw("{}"), t) => t = "Object.assign"`. The string contains the raw JavaScript value supplied by the binding, and the argument is omitted at call sites. The legacy `` @as(json`...`) _ ``, `@as("...") _`, and `@as(1) _` forms now emit a deprecation warning and are formatted as `%raw(...)`. https://github.com/rescript-lang/rescript/pull/8876

compiler/ext/config.ml

@@ -2,9 +2,9 @@ let cmi_magic_number = "Caml1999I038"
 
 (* Magic numbers for marshaled values of the *current* parsetree, whose layout
    changes across compiler versions. *)
-and ast_impl_magic_number = "ResImpl01317"
+and ast_impl_magic_number = "ResImpl01318"
 
-and ast_intf_magic_number = "ResIntf01317"
+and ast_intf_magic_number = "ResIntf01318"
 
 (* 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

compiler/frontend/ast_attributes.ml

@@ -194,16 +194,17 @@ let as_const (attrs : t) =
                         _ );
                 };
               ] -> (
-            (* Check that it is a valid object literal. *)
+            (* Check that it is exactly one JavaScript literal. *)
             match
               Classify_function.classify
                 ~check:
                   (pexp_loc, Bs_flow_ast_utils.flow_deli_offset (Some "json"))
                 s
             with
-            | Js_literal _ -> Json s
+            | Js_literal _ when Classify_function.is_fixed_literal s -> Json s
             | _ ->
-              Location.raise_errorf ~loc:pexp_loc "an object literal expected")
+              Location.raise_errorf ~loc:pexp_loc
+                "The json payload must be a JavaScript literal")
           | _ -> Bs_syntaxerr.err loc Expect_int_or_string_or_json_literal)))
 
 let locg = Location.none

compiler/frontend/ast_external_process.ml

@@ -399,12 +399,32 @@ type response = {
 }
 
 (* A fixed argument means what [@as(value) _] means, so decode it with the
-   same reader. *)
-let fixed_arg_type
+   same reader. [%raw] is JavaScript source and must be exactly one literal.
+   As for [@as(value) _], attributes such as [@ignore] have no effect next to
+   the value, so they are reported as unused. *)
+let fixed_arg_type ~attrs
     ((value, loc) : Parsetree.fixed_value Location.loc * Location.t) =
-  match Ast_attributes.as_const [Ast_fixed_arg.to_attribute ~loc value] with
-  | Some cst -> arg_cst_of_as_const cst
-  | None -> Bs_syntaxerr.err loc Expect_int_or_string_or_json_literal
+  let arg_type =
+    match value.txt with
+    | Pfixed_raw source ->
+      let source = Ast_raw.js_source source in
+      if Classify_function.is_fixed_literal source then
+        External_arg_spec.Arg_cst (External_arg_spec.cst_json source)
+      else
+        Location.raise_errorf ~loc:value.loc
+          "The %%raw payload must be a JavaScript literal"
+    | Pfixed_int _ | Pfixed_string _ | Pfixed_template _ | Pfixed_json _ -> (
+      match Ast_attributes.as_const [Ast_fixed_arg.to_attribute ~loc value] with
+      | Some cst -> arg_cst_of_as_const cst
+      | None -> Bs_syntaxerr.err loc Expect_int_or_string_or_json_literal)
+  in
+  Bs_ast_invariant.warn_discarded_unused_attributes attrs;
+  arg_type
+
+(* A fixed argument is always passed, so it has nothing to make optional. *)
+let reject_optional_fixed
+    ((_, loc) : Parsetree.fixed_value Location.loc * Location.t) =
+  Location.raise_errorf ~loc "A %%raw argument cannot be optional"
 
 (* The label and type of an argument. A fixed argument is typed as its [_], so
    the checks for [@as(value) _] apply to it unchanged. Its location ends with
@@ -415,7 +435,7 @@ let arg_parts (arg : Parsetree.arg) =
   | Parg_fixed {attrs; lbl; value; loc} ->
     ( lbl,
       attrs,
-      Ast_helper.Typ.any ~loc:(Ast_fixed_arg.underscore_loc loc) (),
+      Ast_helper.Typ.any ~loc:(Ast_fixed_arg.closing_loc loc) (),
       Some (value, loc) )
 
 let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
@@ -469,7 +489,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
               in
               let obj_arg_type =
                 match fixed with
-                | Some fixed -> fixed_arg_type fixed
+                | Some fixed -> fixed_arg_type ~attrs:param_attrs fixed
                 | None -> refine_obj_arg_type ~nolabel:false ty
               in
               match obj_arg_type with
@@ -528,7 +548,11 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
                 | Some alias -> alias
                 | None -> label
               in
-              let obj_arg_type = get_opt_arg_type ~nolabel:false ty in
+              let obj_arg_type =
+                match fixed with
+                | Some fixed -> reject_optional_fixed fixed
+                | None -> get_opt_arg_type ~nolabel:false ty
+              in
               match obj_arg_type with
               | Ignore ->
                 ( External_arg_spec.empty_kind obj_arg_type,
@@ -932,7 +956,7 @@ let handle_attributes (loc : Location.t) (type_annotation : Parsetree.core_type)
       Ext_list.fold_right arg_types_ty
         (([], [], 0) : External_arg_spec.params * Parsetree.arg list * int)
         (fun param_type (arg_type_specs, arg_types, i) ->
-          let arg_label, _, ty, fixed = arg_parts param_type in
+          let arg_label, param_attrs, ty, fixed = arg_parts param_type in
           (if i = 0 && splice then
              match arg_label with
              | Optional _ ->
@@ -955,7 +979,11 @@ let handle_attributes (loc : Location.t) (type_annotation : Parsetree.core_type)
                 new_arg_types ) =
             match arg_label with
             | Optional {txt = s} -> (
-              let arg_type = get_opt_arg_type ~nolabel:false ty in
+              let arg_type =
+                match fixed with
+                | Some fixed -> reject_optional_fixed fixed
+                | None -> get_opt_arg_type ~nolabel:false ty
+              in
               match arg_type with
               | Poly_var _ ->
                 (* ?x:([`x of int ] [@string]) does not make sense *)
@@ -967,7 +995,7 @@ let handle_attributes (loc : Location.t) (type_annotation : Parsetree.core_type)
             | Labelled _ -> (
               let arg_type =
                 match fixed with
-                | Some fixed -> fixed_arg_type fixed
+                | Some fixed -> fixed_arg_type ~attrs:param_attrs fixed
                 | None -> refine_arg_type ~nolabel:false ty
               in
               ( Arg_label,
@@ -978,7 +1006,7 @@ let handle_attributes (loc : Location.t) (type_annotation : Parsetree.core_type)
             | Nolabel -> (
               let arg_type =
                 match fixed with
-                | Some fixed -> fixed_arg_type fixed
+                | Some fixed -> fixed_arg_type ~attrs:param_attrs fixed
                 | None -> refine_arg_type ~nolabel:true ty
               in
               ( Arg_empty,

compiler/ml/ast_fixed_arg.ml

@@ -1,7 +1,7 @@
 open Parsetree
 
 let of_payload (payload : payload) : fixed_value Location.loc option =
-  match payload with
+  match Ast_payload.unwrap_payload_expression payload with
   (* A payload with attributes stays an attribute, which keeps them. *)
   | PStr
       [
@@ -39,6 +39,9 @@ let to_expression ?(loc = Location.none) (value : fixed_value) : expression =
     Ast_helper.Exp.tagged_template ~loc
       (Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "json") loc))
       [source] []
+  | Pfixed_raw source ->
+    Ast_helper.Exp.constant ~loc
+      (Ast_helper.Const.string (Ast_raw.js_source source))
 
 let to_attribute ?(loc = Location.none) (value : fixed_value Location.loc) :
     attribute =
@@ -49,11 +52,10 @@ let to_attribute ?(loc = Location.none) (value : fixed_value Location.loc) :
           (to_expression ~loc:value.loc value.txt);
       ] )
 
-(* [@as(value) _] on a direct argument becomes [Parg_fixed]. An argument with
-   an invalid payload stays as written, so external processing reports it as
-   before. So do the rare arguments that [Parg_fixed] could not print back as
-   written: a [_] with other attributes too, and a braced payload such as
-   [@as({1})]. *)
+(* [@as(value) _] on a direct argument becomes [Parg_fixed], which prints as
+   [%raw(...)]. The [_]'s other attributes become the argument's. An argument
+   with an invalid payload or a second [@as] stays as written, so external
+   processing reports it as before. *)
 let normalize_arg (arg : arg) : arg =
   match arg with
   | Parg_type
@@ -64,20 +66,22 @@ let normalize_arg (arg : arg) : arg =
         Some (List.rev before, loc, payload, after)
       | attr :: after -> split (attr :: before) after
     in
+    let is_as (({txt}, _) : attribute) = txt = "as" in
     match split [] ptyp_attributes with
-    | Some ([], as_loc, payload, []) -> (
+    | None -> arg
+    | Some (_, _, _, after) when List.exists is_as after -> arg
+    | Some (before, as_loc, payload, after) -> (
       match of_payload payload with
       | None -> arg
       | Some value ->
         let loc =
           if as_loc = Location.none then ptyp_loc
           else {as_loc with loc_end = ptyp_loc.loc_end}
         in
-        Parg_fixed {attrs; lbl; value; loc})
-    | Some _ | None -> arg)
+        Parg_fixed {attrs = attrs @ before @ after; lbl; value; loc}))
   | Parg_type _ | Parg_fixed _ -> arg
 
-let underscore_loc (loc : Location.t) =
+let closing_loc (loc : Location.t) =
   if loc.loc_ghost then loc
   else
     {
@@ -93,6 +97,49 @@ let as_name_loc (loc : Location.t) =
       loc_end = {loc.loc_start with pos_cnum = loc.loc_start.pos_cnum + 3};
     }
 
+let quote_js_string semantic =
+  "\"" ^ String_literal.encode_js_string semantic ^ "\""
+
+(* Spell a ReScript integer literal as a JavaScript one. Underscore separators
+   need ES2021, and a decimal literal with a leading zero is a legacy octal
+   literal, which strict-mode JavaScript rejects. *)
+let js_integer_source source =
+  let source = String.concat "" (String.split_on_char '_' source) in
+  let sign, digits =
+    if source <> "" && source.[0] = '-' then
+      ("-", String.sub source 1 (String.length source - 1))
+    else ("", source)
+  in
+  let length = String.length digits in
+  let has_radix_prefix =
+    length > 1
+    && digits.[0] = '0'
+    &&
+    match digits.[1] with
+    | 'x' | 'X' | 'o' | 'O' | 'b' | 'B' -> true
+    | _ -> false
+  in
+  if has_radix_prefix then sign ^ digits
+  else
+    let rec first_significant i =
+      if i < length - 1 && digits.[i] = '0' then first_significant (i + 1)
+      else i
+    in
+    let start = first_significant 0 in
+    sign ^ String.sub digits start (length - start)
+
+let js_source (value : fixed_value) =
+  match value with
+  | Pfixed_int source -> js_integer_source source.txt
+  | Pfixed_string payload ->
+    quote_js_string (String_literal.string_semantic payload)
+  | Pfixed_template source -> (
+    match String_literal.decode_js_template_escapes source.txt with
+    | Some semantic -> quote_js_string semantic
+    | None -> "`" ^ source.txt ^ "`")
+  | Pfixed_json source -> source.txt
+  | Pfixed_raw source -> Ast_raw.js_source source
+
 let normalize_external_type (typ : core_type) : core_type =
   match typ.ptyp_desc with
   | Ptyp_arrow {params; ret} ->

compiler/ml/ast_fixed_arg.mli

@@ -2,7 +2,7 @@
 
 val of_payload : Parsetree.payload -> Parsetree.fixed_value Location.loc option
 (** The fixed value denoted by an [@as] payload: an integer, a string, a
-    non-interpolated backquoted string, or a [json] literal. *)
+    non-interpolated backquoted string, or a [json] literal, braced or not. *)
 
 val to_expression :
   ?loc:Location.t -> Parsetree.fixed_value -> Parsetree.expression
@@ -12,8 +12,12 @@ val to_attribute :
   ?loc:Location.t -> Parsetree.fixed_value Location.loc -> Parsetree.attribute
 (** The [@as] attribute that spells [value], with its name located at [loc]. *)
 
-val underscore_loc : Location.t -> Location.t
-(** The location of the [_] that ends a fixed argument located at [loc]. *)
+val closing_loc : Location.t -> Location.t
+(** The location of the last character of a fixed argument located at [loc]:
+    the [)] of [%raw(...)] or the [_] of [@as(value) _]. *)
+
+val js_source : Parsetree.fixed_value -> string
+(** The JavaScript source of a fixed value, as [%raw] spells it. *)
 
 val as_name_loc : Location.t -> Location.t
 (** The location of the [@as] that starts a fixed argument located at [loc]. *)

compiler/ml/ast_iterator.ml

@@ -110,6 +110,7 @@ module T = struct
             match value.txt with
             | Pfixed_int source | Pfixed_template source | Pfixed_json source ->
               sub.location sub source.loc
+            | Pfixed_raw source -> sub.location sub (Ast_raw.source_loc source)
             | Pfixed_string _ -> ()))
         params;
       sub.typ sub ret

compiler/ml/ast_mapper.ml

@@ -115,6 +115,7 @@ module T = struct
                  | Pfixed_template source ->
                    Pfixed_template (map_loc sub source)
                  | Pfixed_json source -> Pfixed_json (map_loc sub source)
+                 | Pfixed_raw source -> Pfixed_raw (map_raw_source sub source)
                in
                Parsetree.Parg_fixed
                  {

compiler/ml/ast_mapper_to0.ml

@@ -200,22 +200,33 @@ module T = struct
             match arg with
             | Parg_type {attrs; lbl; typ} -> (lbl, attrs, sub.typ sub typ)
             | Parg_fixed {attrs; lbl; value; loc} ->
-              (* v0 spells a fixed argument [_ [@as value]], with [json] as a
-                 [json]-delimited string, as before [json] was an ordinary
-                 tagged template. [@as] and [_] get their own locations, from
-                 which [Ast_fixed_arg] restores the argument's. *)
+              (* v0 spells a fixed argument [_ [@as value]], with JavaScript
+                 source as a [json]-delimited string, as before [%raw] and
+                 before [json] was an ordinary tagged template. [@as] and [_]
+                 get their own locations, from which [Ast_fixed_arg] restores
+                 the argument's. *)
               let as_loc = Ast_fixed_arg.as_name_loc loc in
               let as_attr =
                 match value.txt with
-                | Pfixed_json source ->
+                | (Pfixed_json _ | Pfixed_raw _) as fixed ->
+                  let source, source_loc =
+                    match fixed with
+                    | Pfixed_raw source ->
+                      (Ast_raw.js_source source, Ast_raw.source_loc source)
+                    | Pfixed_json source
+                    | Pfixed_int source
+                    | Pfixed_template source ->
+                      (source.txt, source.loc)
+                    | Pfixed_string _ -> assert false
+                  in
                   ( {txt = "as"; loc = sub.location sub as_loc},
                     Pt.PStr
                       [
                         Ast_helper0.Str.eval
                           ~loc:(sub.location sub value.loc)
                           (Ast_helper0.Exp.constant
-                             ~loc:(sub.location sub source.loc)
-                             (Pt.Pconst_string (source.txt, Some "json")));
+                             ~loc:(sub.location sub source_loc)
+                             (Pt.Pconst_string (source, Some "json")));
                       ] )
                 | Pfixed_int _ | Pfixed_string _ | Pfixed_template _ ->
                   sub.attribute sub
@@ -224,7 +235,7 @@ module T = struct
               ( lbl,
                 attrs,
                 Ast_helper0.Typ.any
-                  ~loc:(sub.location sub (Ast_fixed_arg.underscore_loc loc))
+                  ~loc:(sub.location sub (Ast_fixed_arg.closing_loc loc))
                   ~attrs:[as_attr] () )
           in
           let lbl = Asttypes.to_noloc arg_lbl in