Add support for tagged template strings

src/res_core.ml

@@ -14,6 +14,12 @@ let mkLoc startLoc endLoc = Location.{
   loc_ghost = false;
 }
 
+let rec filter_map xs (f : 'a -> 'b option) =
+  match xs with
+  | [] -> []
+  | y :: ys -> (
+    match f y with None -> filter_map ys f | Some z -> z :: filter_map ys f)
+
 module Recover = struct
   let defaultExpr () =
     let id = Location.mknoloc "rescript.exprhole" in
@@ -137,6 +143,7 @@ let ifLetAttr = (Location.mknoloc "ns.iflet", Parsetree.PStr [])
 let suppressFragileMatchWarningAttr = (Location.mknoloc "warning", Parsetree.PStr [Ast_helper.Str.eval (Ast_helper.Exp.constant (Pconst_string ("-4", None)))])
 let makeBracesAttr loc = (Location.mkloc "ns.braces" loc, Parsetree.PStr [])
 let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr [])
+let taggedTemplateLiteralAttr = (Location.mknoloc "res.taggedTemplate", Parsetree.PStr [])
 
 type stringLiteralState =
   | Start
@@ -2217,6 +2224,85 @@ and parseBinaryExpr ?(context=OrdinaryExpr) ?a p prec =
   (* ) *)
 
 and parseTemplateExpr ?(prefix="js") p =
+  (* TODO: include the location in the parts *)
+  let partPrefix = if prefix = "js" || prefix = "j" then Some(prefix) else None in
+
+  let rec parseParts p =
+    let startPos = p.Parser.startPos in
+    Parser.nextTemplateLiteralToken p;
+    match p.token with
+    | TemplateTail txt ->
+      Parser.next p;
+      let loc = mkLoc startPos p.prevEndPos in
+      let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in
+      let str = Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc (Pconst_string(txt, partPrefix)) in
+      (* Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator *)
+      [(str, None)]
+    | TemplatePart txt ->
+      Parser.next p;
+      let loc = mkLoc startPos p.prevEndPos in
+      let expr = parseExprBlock p in
+      (* let fullLoc = mkLoc startPos p.prevEndPos in *)
+      let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in
+      let str = Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc (Pconst_string(txt, partPrefix)) in
+      (* let next =
+        let a = Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc:fullLoc hiddenOperator [Nolabel, acc; Nolabel, str] in
+        Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator
+          [Nolabel, a; Nolabel, expr]
+      in *)
+      let next = parseParts p in
+      (str, Some(expr)) :: next
+   | token ->
+     Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+     (* Ast_helper.Exp.constant (Pconst_string("", None)) *)
+     []
+  in
+  let parts = parseParts p in
+  let strings = List.map fst parts in
+  let values = filter_map parts snd in
+
+  let genTaggedTemplateCall () =
+    let lident = Longident.Lident prefix in
+    let ident = Ast_helper.Exp.ident ~attrs:[] ~loc:Location.none (Location.mknoloc lident) in
+    let strings_array = Ast_helper.Exp.array ~attrs:[] ~loc:Location.none strings in
+    let values_array = Ast_helper.Exp.array ~attrs:[] ~loc:Location.none values in
+    Ast_helper.Exp.apply
+      ~attrs:[taggedTemplateLiteralAttr]
+      ~loc:Location.none ident
+      [(Nolabel, strings_array); (Nolabel, values_array)]
+  in
+
+  let hiddenOperator =
+    let op = Location.mknoloc (Longident.Lident "^") in
+    Ast_helper.Exp.ident op
+  in
+  let genInterpolatedString () =
+    let fn acc part =
+      let (str, value) = part in
+      let loc = Location.none in
+      let next = match acc with
+        | Some(expr) -> Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator
+          [Nolabel, expr; Nolabel, str]  
+        | None -> str
+      in
+      let result = match value with
+        | Some(expr) -> Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator
+            [Nolabel, next; Nolabel, expr]
+        | None -> next
+      in
+      Some(result)
+    in
+    List.fold_left fn None parts 
+  in
+
+  if prefix = "js" || prefix = "j" then
+    match genInterpolatedString () with
+    | Some(expr) -> expr
+    | None -> Ast_helper.Exp.constant (Pconst_string("", None))
+  else
+    genTaggedTemplateCall ();
+
+(* and parseTemplateExpr ?(prefix="js") p =
   let hiddenOperator =
     let op = Location.mknoloc (Longident.Lident "^") in
     Ast_helper.Exp.ident op
@@ -2269,7 +2355,7 @@ and parseTemplateExpr ?(prefix="js") p =
     parseParts next
  | token ->
    Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
-   Ast_helper.Exp.constant (Pconst_string("", None))
+   Ast_helper.Exp.constant (Pconst_string("", None)) *)
 
 (* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int =>
  * Also overparse constraints:

src/res_parsetree_viewer.ml

@@ -516,6 +516,10 @@ let hasTemplateLiteralAttr attrs = List.exists (fun attr -> match attr with
 | ({Location.txt = "res.template"}, _) -> true
 | _ -> false) attrs
 
+let hasTaggedTemplateLiteralAttr attrs = List.exists (fun attr -> match attr with
+| ({Location.txt = "res.taggedTemplate"}, _) -> true
+| _ -> false) attrs
+
 let isTemplateLiteral expr =
   match expr.pexp_desc with
   | Pexp_apply (

src/res_parsetree_viewer.mli

@@ -110,6 +110,7 @@ val isBlockExpr : Parsetree.expression -> bool
 
 val isTemplateLiteral: Parsetree.expression -> bool
 val hasTemplateLiteralAttr: Parsetree.attributes -> bool
+val hasTaggedTemplateLiteralAttr: Parsetree.attributes -> bool
 
 val collectOrPatternChain:
  Parsetree.pattern -> Parsetree.pattern list

src/res_printer.ml

@@ -3399,6 +3399,46 @@ and printTemplateLiteral expr cmtTbl =
     Doc.text "`"
   ]
 
+and printTaggedTemplateLiteral callExpr args cmtTbl =
+  let (stringsList, valuesList) = match args with
+  | [
+    (_, {Parsetree.pexp_desc = Pexp_array strings});
+    (_, {Parsetree.pexp_desc = Pexp_array values})
+  ] -> (strings, values)
+  | _ -> assert false
+  in
+
+  let strings = List.map (
+    fun x -> match x with
+    | {Parsetree.pexp_desc = Pexp_constant (Pconst_string (txt, _))} -> 
+      printStringContents txt
+    | _ -> assert false
+  ) stringsList in
+
+  let values = List.map (fun x -> 
+    Doc.concat [
+      Doc.text "${";
+      printExpressionWithComments x cmtTbl;
+      Doc.text "}"
+    ]) valuesList in
+
+  let rec process first second =
+    match first, second with
+    | [], [] -> Doc.text ""
+    | a_head :: a_rest, b -> Doc.concat [a_head; process b a_rest]
+    | _ -> assert false
+  in
+
+  let content = process strings values in
+
+  let tag = printExpressionWithComments callExpr cmtTbl in
+  Doc.concat [
+    tag;
+    Doc.text "`";
+    content;
+    Doc.text "`";
+  ]
+
 and printUnaryExpression expr cmtTbl =
   let printUnaryOperator op = Doc.text (
     match op with
@@ -3821,6 +3861,9 @@ and printPexpApply expr cmtTbl =
       args
     ) when ParsetreeViewer.isJsxExpression expr ->
     printJsxExpression lident args cmtTbl
+  | Pexp_apply (callExpr, args) 
+    when ParsetreeViewer.hasTaggedTemplateLiteralAttr expr.pexp_attributes ->
+    printTaggedTemplateLiteral callExpr args cmtTbl
   | Pexp_apply (callExpr, args) ->
     let args = List.map (fun (lbl, arg) ->
       (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)

tests/parsing/errors/structure/expected/gh16B.res.txt

@@ -19,12 +19,12 @@ let log msg =
     (((((({js|> Server: |js})[@res.template ]) ^ msg)[@res.template ]) ^
         (({js||js})[@res.template ]))[@res.template ])
 ;;log
-    (((((((((((({js|Running on: |js})[@res.template ]) ^ address.address)
-              [@res.template ]) ^ (({js|:|js})[@res.template ]))
-            [@res.template ]) ^ (address.port |. string_of_int))
-           ^ (({js| (|js})[@res.template ]))
-         [@res.template ]) ^ address.family)
-        ^ (({js|)|js})[@res.template ]))[@res.template ])
+    (((((((((((((({js|Running on: |js})[@res.template ]) ^ address.address)
+                [@res.template ]) ^ (({js|:|js})[@res.template ]))
+              [@res.template ]) ^ (address.port |. string_of_int))
+            [@res.template ]) ^ (({js| (|js})[@res.template ]))
+          [@res.template ]) ^ address.family)
+        [@res.template ]) ^ (({js|)|js})[@res.template ]))[@res.template ])
 module ClientSet =
   struct
     module T =

tests/parsing/grammar/expressions/expected/es6template.res.txt

@@ -33,46 +33,46 @@ let s =
       (({js|  after|js})[@res.template ]))
   [@res.template ])
 let s =
-  ((((((((({js||js})[@res.template ]) ^ foo)[@res.template ]) ^ (({js||js})
-         [@res.template ]))
-       [@res.template ]) ^ bar)
-      ^ (({js||js})[@res.template ]))
+  (((((((((({js||js})[@res.template ]) ^ foo)[@res.template ]) ^ (({js||js})
+          [@res.template ]))
+        [@res.template ]) ^ bar)
+      [@res.template ]) ^ (({js||js})[@res.template ]))
   [@res.template ])
 let s =
-  (((((((((((({js||js})[@res.template ]) ^ foo)[@res.template ]) ^
-            (({js||js})[@res.template ]))
-          [@res.template ]) ^ bar)
-         ^ (({js||js})[@res.template ]))
-       [@res.template ]) ^ baz)
-      ^ (({js||js})[@res.template ]))
+  (((((((((((((({js||js})[@res.template ]) ^ foo)[@res.template ]) ^
+              (({js||js})[@res.template ]))
+            [@res.template ]) ^ bar)
+          [@res.template ]) ^ (({js||js})[@res.template ]))
+        [@res.template ]) ^ baz)
+      [@res.template ]) ^ (({js||js})[@res.template ]))
   [@res.template ])
 let s =
-  ((((((((({js||js})[@res.template ]) ^ foo)[@res.template ]) ^ (({js| |js})
-         [@res.template ]))
-       [@res.template ]) ^ bar)
-      ^ (({js||js})[@res.template ]))
+  (((((((((({js||js})[@res.template ]) ^ foo)[@res.template ]) ^ (({js| |js})
+          [@res.template ]))
+        [@res.template ]) ^ bar)
+      [@res.template ]) ^ (({js||js})[@res.template ]))
   [@res.template ])
 let s =
-  (((((((((((({js||js})[@res.template ]) ^ foo)[@res.template ]) ^
-            (({js| |js})[@res.template ]))
-          [@res.template ]) ^ bar)
-         ^ (({js| |js})[@res.template ]))
-       [@res.template ]) ^ baz)
-      ^ (({js||js})[@res.template ]))
+  (((((((((((((({js||js})[@res.template ]) ^ foo)[@res.template ]) ^
+              (({js| |js})[@res.template ]))
+            [@res.template ]) ^ bar)
+          [@res.template ]) ^ (({js| |js})[@res.template ]))
+        [@res.template ]) ^ baz)
+      [@res.template ]) ^ (({js||js})[@res.template ]))
   [@res.template ])
 let s =
-  ((((((((({js| before |js})[@res.template ]) ^ foo)[@res.template ]) ^
-         (({js| |js})[@res.template ]))
-       [@res.template ]) ^ bar)
-      ^ (({js| after |js})[@res.template ]))
+  (((((((((({js| before |js})[@res.template ]) ^ foo)[@res.template ]) ^
+          (({js| |js})[@res.template ]))
+        [@res.template ]) ^ bar)
+      [@res.template ]) ^ (({js| after |js})[@res.template ]))
   [@res.template ])
 let s =
-  (((((((((((({js|before |js})[@res.template ]) ^ foo)[@res.template ]) ^
-            (({js| middle |js})[@res.template ]))
-          [@res.template ]) ^ bar)
-         ^ (({js| |js})[@res.template ]))
-       [@res.template ]) ^ baz)
-      ^ (({js| wow |js})[@res.template ]))
+  (((((((((((((({js|before |js})[@res.template ]) ^ foo)[@res.template ]) ^
+              (({js| middle |js})[@res.template ]))
+            [@res.template ]) ^ bar)
+          [@res.template ]) ^ (({js| |js})[@res.template ]))
+        [@res.template ]) ^ baz)
+      [@res.template ]) ^ (({js| wow |js})[@res.template ]))
   [@res.template ])
 let s =
   (({js|
@@ -90,13 +90,13 @@ let s =
 |js})
   [@res.template ])
 let s = (({js|$dollar without $braces $interpolation|js})[@res.template ])
-let s = (({json|null|json})[@res.template ])
+let s = ((json [|(("null")[@res.template ])|] [||])[@res.taggedTemplate ])
 let x = (({js|foo`bar$\foo|js})[@res.template ])
 let x =
-  ((((((((({js|foo`bar$\foo|js})[@res.template ]) ^ a)[@res.template ]) ^
-         (({js| ` |js})[@res.template ]))
-       [@res.template ]) ^ b)
-      ^ (({js| ` xx|js})[@res.template ]))
+  (((((((((({js|foo`bar$\foo|js})[@res.template ]) ^ a)[@res.template ]) ^
+          (({js| ` |js})[@res.template ]))
+        [@res.template ]) ^ b)
+      [@res.template ]) ^ (({js| ` xx|js})[@res.template ]))
   [@res.template ])
 let thisIsFine = (({js|$something|js})[@res.template ])
 let thisIsAlsoFine = (({js|fine$|js})[@res.template ])

tests/printer/expr/expected/templateLiteral.res.txt

@@ -73,7 +73,8 @@ module X = %graphql("
   }
 ")
 
-let cn = css`
+let cn =
+  css`
   display: block;
   color: ${Color.text};
   background-color: ${Color.bg};
@@ -91,7 +92,8 @@ let cn = css`
   padding: ${Size.md + 1 - 2.3 * pad / 4}px;
 `
 
-let box = css`
+let box =
+  css`
   margin: ${ten()}px;
   padding: ${pad}px;
   border: 6px solid ${Color.Border.bg->Polished.lighten(0.3)};