Add support for tagged template strings

src/res_core.ml

@@ -14,6 +14,16 @@ let mkLoc startLoc endLoc = Location.{
   loc_ghost = false;
 }
 
+let filter_map (f : 'a -> 'b option) xs =
+  let rec aux acc = function
+  | [] -> List.rev acc
+  | y :: ys -> (
+    match f y with
+    | None -> aux acc ys
+    | Some z -> aux (z :: acc) ys
+  )
+  in aux [] xs
+
 module Recover = struct
   let defaultExpr () =
     let id = Location.mknoloc "rescript.exprhole" in
@@ -137,6 +147,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,59 +2228,87 @@ and parseBinaryExpr ?(context=OrdinaryExpr) ?a p prec =
   (* ) *)
 
 and parseTemplateExpr ?(prefix="js") p =
+  let partPrefix = match prefix with
+    | "js" | "j" -> Some(prefix)
+    | _ -> None 
+  in
+  let startPos = p.Parser.startPos in
+
+  let parseParts p =
+    let rec aux acc =
+      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
+        List.rev ((str, None) :: acc)
+      | TemplatePart txt ->
+        Parser.next p;
+        let loc = mkLoc startPos p.prevEndPos in
+        let expr = parseExprBlock p 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
+        aux ((str, Some(expr)) :: acc)
+    | token ->
+      Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+      []
+    in aux []
+  in
+  let parts = parseParts p in
+  let strings = List.map fst parts in
+  let values = filter_map snd parts in
+  let endPos = p.Parser.endPos 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:(mkLoc startPos endPos)
+      ident [(Nolabel, strings_array); (Nolabel, values_array)]
+  in
+
   let hiddenOperator =
     let op = Location.mknoloc (Longident.Lident "^") in
     Ast_helper.Exp.ident op
   in
-  let rec parseParts acc =
-    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, Some prefix)) in
-      Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator
-        [Nolabel, acc; Nolabel, str]
-    | 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, Some prefix)) 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
-      parseParts next
-   | token ->
-     Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
-     Ast_helper.Exp.constant (Pconst_string("", None))
-  in
-  let startPos = p.startPos in
-  Parser.nextTemplateLiteralToken p;
-  match p.token with
-  | TemplateTail txt ->
-    Parser.next p;
-    let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in
-    Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc:(mkLoc startPos p.prevEndPos) (Pconst_string(txt, Some prefix))
-  | TemplatePart txt ->
-    Parser.next p;
-    let constantLoc = 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:constantLoc (Pconst_string(txt, Some prefix)) in
-    let next =
-      Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc:fullLoc hiddenOperator [Nolabel, str; Nolabel, expr]
+  let genInterpolatedString () =
+    let subparts = List.flatten (
+      List.map (fun part -> 
+        match part with
+        | (s, Some(v)) -> [s; v]
+        | (s, None) -> [s]
+      ) 
+      parts)
     in
-    parseParts next
- | token ->
-   Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
-   Ast_helper.Exp.constant (Pconst_string("", None))
+    let exprOption = List.fold_left (
+      fun acc subpart -> 
+        Some(
+          match acc with
+          | Some(expr) ->
+            let loc = (mkLoc
+              (expr.Parsetree.pexp_loc.Location.loc_start)
+              (subpart.Parsetree.pexp_loc.Location.loc_end)
+            ) in
+            Ast_helper.Exp.apply
+              ~attrs:[templateLiteralAttr] ~loc hiddenOperator [Nolabel, expr; Nolabel, subpart]
+          | None -> subpart
+        )
+      )
+      None subparts
+    in match exprOption with
+    | Some(expr) -> expr
+    | None -> Ast_helper.Exp.constant (Pconst_string("", None))
+  in
+
+  match prefix with
+  | "js" | "j" -> genInterpolatedString ()
+  | _ -> genTaggedTemplateCall ()
 
 (* 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 (
@@ -526,6 +530,11 @@ let isTemplateLiteral expr =
   | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true
   | _ -> false
 
+let isTaggedTemplateLiteral expr =
+    match expr with
+    | {pexp_desc = Pexp_apply _; pexp_attributes = attrs} -> hasTaggedTemplateLiteralAttr attrs
+    | _ -> false
+
 (* Blue | Red | Green -> [Blue; Red; Green] *)
 let collectOrPatternChain pat =
   let rec loop pattern chain =

src/res_parsetree_viewer.mli

@@ -109,6 +109,7 @@ val collectPatternsFromListConstruct:
 val isBlockExpr : Parsetree.expression -> bool
 
 val isTemplateLiteral: Parsetree.expression -> bool
+val isTaggedTemplateLiteral: Parsetree.expression -> bool
 val hasTemplateLiteralAttr: Parsetree.attributes -> bool
 
 val collectOrPatternChain:

src/res_printer.ml

@@ -1999,11 +1999,12 @@ and printValueBinding ~recFlag vb cmtTbl i =
             pexp_desc = Pexp_ifthenelse (ifExpr, _, _)
           }  ->
           ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes
-      | { pexp_desc = Pexp_newtype _} -> false
-      | e ->
-          ParsetreeViewer.hasAttributes e.pexp_attributes ||
-          ParsetreeViewer.isArrayAccess e
-        )
+        | { pexp_desc = Pexp_newtype _} -> false
+        | { pexp_attributes = [({Location.txt="res.taggedTemplate"}, _)] } -> false
+        | e ->
+            ParsetreeViewer.hasAttributes e.pexp_attributes ||
+            ParsetreeViewer.isArrayAccess e
+          )
     in
     Doc.group (
       Doc.concat [
@@ -2853,11 +2854,13 @@ and printExpression (e : Parsetree.expression) cmtTbl =
     | extension ->
       printExtension ~atModuleLvl:false extension cmtTbl
     end
-  | Pexp_apply _ ->
+  | Pexp_apply (callExpr, args) ->
     if ParsetreeViewer.isUnaryExpression e then
       printUnaryExpression e cmtTbl
     else if ParsetreeViewer.isTemplateLiteral e then
       printTemplateLiteral e cmtTbl
+    else if ParsetreeViewer.isTaggedTemplateLiteral e then
+      printTaggedTemplateLiteral callExpr args cmtTbl
     else if ParsetreeViewer.isBinaryExpression e then
       printBinaryExpression e cmtTbl
     else
@@ -3399,6 +3402,49 @@ 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 process strings values = 
+    let rec aux acc = function
+      | [], [] -> acc
+      | a_head :: a_rest, b -> 
+        aux (Doc.concat [acc; a_head]) (b, a_rest)
+      | _ -> assert false
+    in
+    aux Doc.nil (strings, values) 
+  in
+
+  let content: Doc.t = 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

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/es6template.res

@@ -43,6 +43,8 @@ let s = `$dollar without $braces $interpolation`
 
 let s = json`null`
 
+let x =  sql`select ${column} from ${table}`
+
 let x = `foo\`bar\$\\foo`
 let x = `foo\`bar\$\\foo${a} \` ${b} \` xx`