Refactor $(...) and $$(...) parsingwip/dollar-dollar

3 files changed, 22 insertions, 33 deletions

diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index bfb39c8f7b..ca88716f34 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -258,9 +258,9 @@ data AnnKeywordId
     | AnnOpenEQ  -- ^ '[|'
     | AnnOpenEQU -- ^ '[|', unicode variant
     | AnnOpenP   -- ^ '('
-    | AnnOpenPE  -- ^ '$('
-    | AnnOpenPTE -- ^ '$$('
     | AnnOpenS   -- ^ '['
+    | AnnDollar          -- ^ prefix '$'   -- TemplateHaskell
+    | AnnDollarDollar    -- ^ prefix '$$'  -- TemplateHaskell
     | AnnPackageName
     | AnnPattern
     | AnnProc
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 1a61aac18d..5b7ae94655 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -376,10 +376,6 @@ $tab          { warnTab }
   "[t|"       / { ifExtension ThQuotesBit } { token ITopenTypQuote }
   "|]"        / { ifExtension ThQuotesBit } { token (ITcloseQuote NormalSyntax) }
   "||]"       / { ifExtension ThQuotesBit } { token ITcloseTExpQuote }
-  \$ @varid   / { ifExtension ThBit }       { skip_one_varid ITidEscape }
-  "$$" @varid / { ifExtension ThBit }       { skip_two_varid ITidTyEscape }
-  "$("        / { ifExtension ThBit }       { token ITparenEscape }
-  "$$("       / { ifExtension ThBit }       { token ITparenTyEscape }
 
   "[" @varid "|"  / { ifExtension QqBit }   { lex_quasiquote_tok }
 
@@ -725,10 +721,8 @@ data Token
   | ITcloseQuote IsUnicodeSyntax        --  |]
   | ITopenTExpQuote HasE                --  [|| or [e||
   | ITcloseTExpQuote                    --  ||]
-  | ITidEscape   FastString             --  $x
-  | ITparenEscape                       --  $(
-  | ITidTyEscape   FastString           --  $$x
-  | ITparenTyEscape                     --  $$(
+  | ITdollar                            --  $
+  | ITdollardollar                      --  $$
   | ITtyQuote                           --  ''
   | ITquasiQuote (FastString,FastString,RealSrcSpan)
     -- ITquasiQuote(quoter, quote, loc)
@@ -3007,8 +3001,6 @@ isALRopen ITobrack        = True
 isALRopen ITocurly        = True
 -- GHC Extensions:
 isALRopen IToubxparen     = True
-isALRopen ITparenEscape   = True
-isALRopen ITparenTyEscape = True
 isALRopen _               = False
 
 isALRclose :: Token -> Bool
@@ -3100,6 +3092,14 @@ varsym_override _ occ_sort s | s == fsLit "~" =
   case occ_sort of
     VarsymPrefix -> ITtilde
     _ -> ITvarsym s
+varsym_override exts occ_sort s | ThBit `xtest` exts, s == fsLit "$" =
+  case occ_sort of
+    VarsymPrefix -> ITdollar
+    _ -> ITvarsym s
+varsym_override exts occ_sort s | ThBit `xtest` exts, s == fsLit "$$" =
+  case occ_sort of
+    VarsymPrefix -> ITdollardollar
+    _ -> ITvarsym s
 varsym_override _ _ s = ITvarsym s
 
 reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index e969e31e1e..a195dde59e 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -93,7 +93,7 @@ import Util             ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )
 import GhcPrelude
 }
 
-%expect 237 -- shift/reduce conflicts
+%expect 232 -- shift/reduce conflicts
 
 {- Last updated: 04 June 2018
 
@@ -610,10 +610,8 @@ are the most common patterns, rewritten as regular expressions for clarity:
 '|]'            { L _ (ITcloseQuote _) }
 '[||'           { L _ (ITopenTExpQuote _) }
 '||]'           { L _ ITcloseTExpQuote  }
-TH_ID_SPLICE    { L _ (ITidEscape _)  }     -- $x
-'$('            { L _ ITparenEscape   }     -- $( exp )
-TH_ID_TY_SPLICE { L _ (ITidTyEscape _)  }   -- $$x
-'$$('           { L _ ITparenTyEscape   }   -- $$( exp )
+PREFIX_DOLLAR   { L _ ITdollar }
+PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar }
 TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T
 TH_QUASIQUOTE   { L _ (ITquasiQuote _) }
 TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
@@ -2857,22 +2855,15 @@ splice_exp :: { LHsExpr GhcPs }
         | splice_typed   { mapLoc (HsSpliceE noExtField) $1 }
 
 splice_untyped :: { Located (HsSplice GhcPs) }
-        : TH_ID_SPLICE          {% ams (sL1 $1 $ mkUntypedSplice HasDollar
-                                        (sL1 $1 $ HsVar noExtField (sL1 $1 (mkUnqual varName
-                                                           (getTH_ID_SPLICE $1)))))
-                                       [mj AnnThIdSplice $1] }
-        | '$(' exp ')'          {% runECP_P $2 >>= \ $2 ->
-                                   ams (sLL $1 $> $ mkUntypedSplice HasParens $2)
-                                       [mj AnnOpenPE $1,mj AnnCloseP $3] }
+        : PREFIX_DOLLAR aexp2   {% runECP_P $2 >>= \ $2 ->
+                                   ams (sLL $1 $> $ mkUntypedSplice HasDollar $2)
+                                       [mj AnnDollar $1] }
 
 splice_typed :: { Located (HsSplice GhcPs) }
-        : TH_ID_TY_SPLICE       {% ams (sL1 $1 $ mkTypedSplice HasDollar
-                                        (sL1 $1 $ HsVar noExtField (sL1 $1 (mkUnqual varName
-                                                        (getTH_ID_TY_SPLICE $1)))))
-                                       [mj AnnThIdTySplice $1] }
-        | '$$(' exp ')'         {% runECP_P $2 >>= \ $2 ->
-                                    ams (sLL $1 $> $ mkTypedSplice HasParens $2)
-                                       [mj AnnOpenPTE $1,mj AnnCloseP $3] }
+        : PREFIX_DOLLAR_DOLLAR aexp2
+                                {% runECP_P $2 >>= \ $2 ->
+                                   ams (sLL $1 $> $ mkTypedSplice HasDollar $2)
+                                       [mj AnnDollarDollar $1] }
 
 cmdargs :: { [LHsCmdTop GhcPs] }
         : cmdargs acmd                  { $2 : $1 }
@@ -3787,8 +3778,6 @@ getPRIMINTEGER  (dL->L _ (ITprimint  _ x)) = x
 getPRIMWORD     (dL->L _ (ITprimword _ x)) = x
 getPRIMFLOAT    (dL->L _ (ITprimfloat x)) = x
 getPRIMDOUBLE   (dL->L _ (ITprimdouble x)) = x
-getTH_ID_SPLICE (dL->L _ (ITidEscape x)) = x
-getTH_ID_TY_SPLICE (dL->L _ (ITidTyEscape x)) = x
 getINLINE       (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl)
 getSPEC_INLINE  (dL->L _ (ITspec_inline_prag _ True))  = (Inline,  FunLike)
 getSPEC_INLINE  (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)