diff --git a/src/res_core.ml b/src/res_core.ml index c8532e01..e0129f79 100644 --- a/src/res_core.ml +++ b/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: diff --git a/src/res_parsetree_viewer.ml b/src/res_parsetree_viewer.ml index 3bb2da3d..09f17cd9 100644 --- a/src/res_parsetree_viewer.ml +++ b/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 = diff --git a/src/res_parsetree_viewer.mli b/src/res_parsetree_viewer.mli index 65a67367..b75f63dc 100644 --- a/src/res_parsetree_viewer.mli +++ b/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: diff --git a/src/res_printer.ml b/src/res_printer.ml index 42d2de77..b1f1935f 100644 --- a/src/res_printer.ml +++ b/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 diff --git a/tests/parsing/errors/structure/expected/gh16B.res.txt b/tests/parsing/errors/structure/expected/gh16B.res.txt index 23cfa8a5..3580faf6 100644 --- a/tests/parsing/errors/structure/expected/gh16B.res.txt +++ b/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 = diff --git a/tests/parsing/grammar/expressions/es6template.res b/tests/parsing/grammar/expressions/es6template.res index a110baff..5937eb95 100644 --- a/tests/parsing/grammar/expressions/es6template.res +++ b/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` diff --git a/tests/parsing/grammar/expressions/expected/es6template.res.txt b/tests/parsing/grammar/expressions/expected/es6template.res.txt index a179529e..b1d33d1c 100644 --- a/tests/parsing/grammar/expressions/expected/es6template.res.txt +++ b/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,18 @@ 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 = + ((sql + [|(("select ")[@res.template ]);((" from ")[@res.template ]);(("") + [@res.template ])|] [|column;table|]) + [@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 ]) diff --git a/tests/printer/other/expected/ocamlString.ml.txt b/tests/printer/other/expected/ocamlString.res.txt similarity index 68% rename from tests/printer/other/expected/ocamlString.ml.txt rename to tests/printer/other/expected/ocamlString.res.txt index 15048c77..54b25701 100644 --- a/tests/printer/other/expected/ocamlString.ml.txt +++ b/tests/printer/other/expected/ocamlString.res.txt @@ -9,18 +9,18 @@ let x = "foo\o012bar" let x = "😁 this works now 😆" let x = `😁 this works now 😆` -/* The `//` should not result into an extra comment */ +// The `//` should not result into an extra comment let x = j`https://www.apple.com` let x = `https://www.apple.com` let x = `https://www.apple.com` -let x = `https://www.apple.com` +let x = "https://www.apple.com" let x = sql`https://www.apple.com` -/* /* */ should not result in an extra comments */ +// /* */ should not result in an extra comments let x = j`/* https://www.apple.com */` let x = `/* https://www.apple.com*/` let x = `/*https://www.apple.com*/` -let x = `/*https://www.apple.com*/` +let x = "/*https://www.apple.com*/" let x = sql`/*https://www.apple.com*/` -let x = `\`https://\${appleWebsite}\`` +let x = `https://${appleWebsite}` diff --git a/tests/printer/other/ocamlString.ml b/tests/printer/other/ocamlString.ml deleted file mode 100644 index a054d8c7..00000000 --- a/tests/printer/other/ocamlString.ml +++ /dev/null @@ -1,27 +0,0 @@ -let x = "\132\149\166" - -let s = "\123 \o111 \xA0" - -let x = "foo\010bar" -let x = "foo\x0Abar" -let x = "foo\o012bar" - -let x = "😁 this works now 😆" -let x = {|😁 this works now 😆|} - - -(* The `//` should not result into an extra comment *) -let x = {j|https://www.apple.com|j} -let x = {|https://www.apple.com|} -let x = {js|https://www.apple.com|js} -let x = {|https://www.apple.com|} -let x = {sql|https://www.apple.com|sql} - -(* /* */ should not result in an extra comments *) -let x = {j|/* https://www.apple.com */|j} -let x = {|/* https://www.apple.com*/|} -let x = {js|/*https://www.apple.com*/|js} -let x = {|/*https://www.apple.com*/|} -let x = {sql|/*https://www.apple.com*/|sql} - -let x = {js|`https://${appleWebsite}`|js} diff --git a/tests/printer/other/ocamlString.res b/tests/printer/other/ocamlString.res new file mode 100644 index 00000000..8f638b19 --- /dev/null +++ b/tests/printer/other/ocamlString.res @@ -0,0 +1,27 @@ +let x = "\132\149\166" + +let s = "\123 \o111 \xA0" + +let x = "foo\010bar" +let x = "foo\x0Abar" +let x = "foo\o012bar" + +let x = "😁 this works now 😆" +let x = `😁 this works now 😆` + + +// The `//` should not result into an extra comment +let x = j`https://www.apple.com` +let x = `https://www.apple.com` +let x = js`https://www.apple.com` +let x = "https://www.apple.com" +let x = sql`https://www.apple.com` + +// /* */ should not result in an extra comments +let x = j`/* https://www.apple.com */` +let x = `/* https://www.apple.com*/` +let x = js`/*https://www.apple.com*/` +let x = "/*https://www.apple.com*/" +let x = sql`/*https://www.apple.com*/` + +let x = js`https://${appleWebsite}`