feat: quoted extensions (#2794)

* feat: quoted extensions

* add changelog entry

* fix: structure items

CHANGES.md

@@ -28,6 +28,8 @@
   (@anmonteiro, [#2785](https://github.com/reasonml/reason/pull/2785))
 - Support `type%foo` extension sugar syntax (@anmonteiro,
   [#2790](https://github.com/reasonml/reason/pull/2790))
+- Support quoted extensions (@anmonteiro,
+  [#2794](https://github.com/reasonml/reason/pull/2794))
 
 ## 3.12.0
 

src/reason-parser/reason_declarative_lexer.mll

@@ -188,6 +188,16 @@ let set_lexeme_length buf n = (
                      with pos_cnum = buf.lex_abs_pos + buf.lex_curr_pos};
 )
 
+let compute_quoted_string_idloc {Location.loc_start = orig_loc } shift id =
+  let id_start_pos = orig_loc.Lexing.pos_cnum + shift in
+  let loc_start =
+    Lexing.{orig_loc with pos_cnum = id_start_pos }
+  in
+  let loc_end =
+    Lexing.{orig_loc with pos_cnum = id_start_pos + String.length id}
+  in
+  {Location. loc_start ; loc_end ; loc_ghost = false }
+
 (* This cut comment characters of the current buffer.
  * Operators (including "/*" and "//") are lexed with the same rule, and this
  * function cuts the lexeme at the beginning of an operator. *)
@@ -346,6 +356,9 @@ let dotsymbolchar =
   ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|' '\\' 'a'-'z' 'A'-'Z' '_' '0'-'9']
 let kwdopchar = ['$' '&' '*' '+' '-' '/' '<' '=' '>' '@' '^' '|' '.' '!']
 
+let ident = (lowercase | uppercase) identchar*
+let extattrident = ident ('.' ident)*
+
 let decimal_literal = ['0'-'9'] ['0'-'9' '_']*
 
 let hex_digit =
@@ -447,6 +460,52 @@ rule token state = parse
       let txt = flush_buffer raw_buffer in
       STRING (txt, None, Some delim)
     }
+  | "{%" (extattrident as id) "|"
+    {
+      let orig_loc = Location.curr lexbuf in
+      let string_start = lexbuf.lex_start_p in
+      let start_loc = Location.curr lexbuf in
+      let raw_buffer, _ = get_scratch_buffers state in
+      if not (quoted_string raw_buffer "" lexbuf) then
+        raise_error start_loc Unterminated_string;
+      lexbuf.lex_start_p <- string_start;
+      let txt = flush_buffer raw_buffer in
+      let idloc = compute_quoted_string_idloc orig_loc 2 id in
+      QUOTED_STRING_EXPR (id, idloc, txt, Some "") }
+  | "{%" (extattrident as id) blank+ (lowercase* as delim) "|"
+    { let orig_loc = Location.curr lexbuf in
+      let string_start = lexbuf.lex_start_p in
+      let start_loc = Location.curr lexbuf in
+      let raw_buffer, _ = get_scratch_buffers state in
+      if not (quoted_string raw_buffer delim lexbuf) then
+        raise_error start_loc Unterminated_string;
+      lexbuf.lex_start_p <- string_start;
+      let txt = flush_buffer raw_buffer in
+      let idloc = compute_quoted_string_idloc orig_loc 2 id in
+      QUOTED_STRING_EXPR (id, idloc, txt, Some delim) }
+  | "{%%" (extattrident as id) "|"
+    {
+      let orig_loc = Location.curr lexbuf in
+      let string_start = lexbuf.lex_start_p in
+      let start_loc = Location.curr lexbuf in
+      let raw_buffer, _ = get_scratch_buffers state in
+      if not (quoted_string raw_buffer "" lexbuf) then
+        raise_error start_loc Unterminated_string;
+      lexbuf.lex_start_p <- string_start;
+      let txt = flush_buffer raw_buffer in
+      let idloc = compute_quoted_string_idloc orig_loc 3 id in
+      QUOTED_STRING_ITEM (id, idloc, txt, Some "") }
+  | "{%%" (extattrident as id) blank+ (lowercase* as delim) "|"
+    { let orig_loc = Location.curr lexbuf in
+      let string_start = lexbuf.lex_start_p in
+      let start_loc = Location.curr lexbuf in
+      let raw_buffer, _ = get_scratch_buffers state in
+      if not (quoted_string raw_buffer delim lexbuf) then
+        raise_error start_loc Unterminated_string;
+      lexbuf.lex_start_p <- string_start;
+      let txt = flush_buffer raw_buffer in
+      let idloc = compute_quoted_string_idloc orig_loc 3 id in
+      QUOTED_STRING_ITEM (id, idloc, txt, Some delim) }
   | "'" newline "'"
     { (* newline can span multiple characters
          (if the newline starts with \13)

src/reason-parser/reason_parser.mly

@@ -794,6 +794,13 @@ let wrap_sig_ext ~loc body ext =
   | Some (ext_attrs, ext_id) ->
     Ppxlib.Psig_extension ((ext_id, PSig [mksig ~loc body]), ext_attrs)
 
+let mk_quotedext ~loc (id, idloc, str, delim) =
+  let exp_id = mkloc id idloc in
+  let e =
+    mkexp ~loc ~ghost:true (Pexp_constant (Pconst_string (str, loc, delim)))
+  in
+  (exp_id, Ppxlib.PStr [mkstrexp e []])
+
 let expression_extension ?loc (ext_attrs, ext_id) item_expr =
   let loc = match loc with
     | Some loc -> loc
@@ -1221,6 +1228,10 @@ let add_brace_attr (expr: Ppxlib.expression) =
 %token STAR
 %token <string * string option * string option> STRING
   [@recover.expr ("", None, None)] [@recover.cost 2]
+%token
+  <string * Location.t * string * string option> QUOTED_STRING_EXPR
+%token
+  <string * Location.t * string * string option> QUOTED_STRING_ITEM
 %token STRUCT
 %token THEN
 %token TILDE
@@ -5204,10 +5215,16 @@ item_extension_sugar:
 
 extension:
   LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) }
+  | QUOTED_STRING_EXPR
+    { let loc = mklocation $symbolstartpos $endpos in
+      mk_quotedext ~loc $1 }
 ;
 
 item_extension:
   LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) }
+  | QUOTED_STRING_ITEM
+    { let loc = mklocation $symbolstartpos $endpos in
+      mk_quotedext ~loc $1 }
 ;
 
 payload:

src/reason-parser/reason_pprint_ast.ml

@@ -1129,6 +1129,20 @@ let createFormatter () =
       fn Format.str_formatter term;
       atom (Format.flush_str_formatter ())
 
+    let quoted_ext ?(pct = "%") extension i delim =
+      wrap
+        (fun ppf () ->
+           Format.fprintf
+             ppf
+             "{%s%s%s%s|%s|%s}"
+             pct
+             extension.txt
+             (if delim != "" then " " else "")
+             delim
+             i
+             delim)
+        ()
+
     (* Don't use `trim` since it kills line return too? *)
     let rec beginsWithStar_ line length idx =
       if idx = length
@@ -7710,10 +7724,12 @@ let createFormatter () =
                 | None, _ ->
                   (match expression_extension_sugar x with
                   | None -> Some (self#extension e)
-                  | Some (_, x') ->
+                  | Some (ext, x') ->
                     (match x'.pexp_desc with
                     | Pexp_let _ | Pexp_letop _ | Pexp_letmodule _ ->
                       Some (makeLetSequence (self#letList x))
+                    | Pexp_constant (Pconst_string (i, _, Some delim)) ->
+                      Some (quoted_ext ext i delim)
                     | _ -> Some (self#extension e))))
               | Pexp_open (me, e) ->
                 if self#isSeriesOfOpensFollowedByNonSequencyExpression x
@@ -9212,6 +9228,12 @@ let createFormatter () =
               | Pstr_open od -> self#pstr_open ~extension od
               | Pstr_type (rf, l) -> self#type_def_list ~extension rf l
               | Pstr_typext te -> self#type_extension ~extension te
+              | Pstr_eval
+                  ( { pexp_desc =
+                        Pexp_constant (Pconst_string (i, _, Some delim))
+                    }
+                  , _ ) ->
+                quoted_ext ~pct:"%%" extension i delim
               | _ ->
                 self#attach_std_item_attrs
                   attrs

test/extensions.t/input.re

@@ -388,4 +388,5 @@ let a = 3;
 [%%foo external x: int => int = "caml_prim"];
 external%foo x: int => int = "caml_prim";
 
-
+{%%M.foo| <hello>{x} |};
+let x = {%M.foo bar| <hello>{|x|} |bar};

test/extensions.t/run.t

@@ -389,3 +389,6 @@ Format extensions
   external%foo x: int => int;
   external%foo x: int => int = "caml_prim";
   external%foo x: int => int = "caml_prim";
+
+  {%%M.foo | <hello>{x} |};
+  let x = {%M.foo bar| <hello>{|x|} |bar};