Add syntactic support for typed expression brackets and splices.

Right now the syntax for typed expression brackets and splices maps to
conventional brackets and splices, i.e., they are not typed.

2 files changed, 40 insertions, 17 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 79ba0271ca..9d4fe1c1c9 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -315,14 +315,18 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 }
 
 <0> {
-  "[|"      / { ifExtension thEnabled } { token ITopenExpQuote }
-  "[e|"     / { ifExtension thEnabled } { token ITopenExpQuote }
-  "[p|"     / { ifExtension thEnabled } { token ITopenPatQuote }
-  "[d|"     / { ifExtension thEnabled } { layout_token ITopenDecQuote }
-  "[t|"     / { ifExtension thEnabled } { token ITopenTypQuote }
-  "|]"      / { ifExtension thEnabled } { token ITcloseQuote }
-  \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
-  "$("      / { ifExtension thEnabled } { token ITparenEscape }
+  "[|"        / { ifExtension thEnabled } { token ITopenExpQuote }
+  "[||"       / { ifExtension thEnabled } { token ITopenTExpQuote }
+  "[e|"       / { ifExtension thEnabled } { token ITopenExpQuote }
+  "[p|"       / { ifExtension thEnabled } { token ITopenPatQuote }
+  "[d|"       / { ifExtension thEnabled } { layout_token ITopenDecQuote }
+  "[t|"       / { ifExtension thEnabled } { token ITopenTypQuote }
+  "|]"        / { ifExtension thEnabled } { token ITcloseQuote }
+  "||]"       / { ifExtension thEnabled } { token ITcloseTExpQuote }
+  \$ @varid   / { ifExtension thEnabled } { skip_one_varid ITidEscape }
+  "$$" @varid / { ifExtension thEnabled } { skip_two_varid ITidTyEscape }
+  "$("        / { ifExtension thEnabled } { token ITparenEscape }
+  "$$("       / { ifExtension thEnabled } { token ITparenTyEscape }
 
 -- For backward compatibility, accept the old dollar syntax
   "[$" @varid "|"  / { ifExtension qqEnabled }
@@ -580,8 +584,12 @@ data Token
   | ITopenDecQuote              --  [d|
   | ITopenTypQuote              --  [t|
   | ITcloseQuote                --  |]
+  | ITopenTExpQuote             --  [||
+  | ITcloseTExpQuote            --  ||]
   | ITidEscape   FastString     --  $x
   | ITparenEscape               --  $(
+  | ITidTyEscape   FastString   --  $$x
+  | ITparenTyEscape             --  $$(
   | ITtyQuote                   --  ''
   | ITquasiQuote (FastString,FastString,RealSrcSpan)
     -- ITquasiQuote(quoter, quote, loc)
@@ -766,6 +774,10 @@ skip_one_varid :: (FastString -> Token) -> Action
 skip_one_varid f span buf len
   = return (L span $! f (lexemeToFastString (stepOn buf) (len-1)))
 
+skip_two_varid :: (FastString -> Token) -> Action
+skip_two_varid f span buf len
+  = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2)))
+
 strtoken :: (String -> Token) -> Action
 strtoken f span buf len =
   return (L span $! (f $! lexemeToString buf len))
@@ -2290,16 +2302,17 @@ transitionalAlternativeLayoutWarning msg
    $$ text msg
 
 isALRopen :: Token -> Bool
-isALRopen ITcase        = True
-isALRopen ITif          = True
-isALRopen ITthen        = True
-isALRopen IToparen      = True
-isALRopen ITobrack      = True
-isALRopen ITocurly      = True
+isALRopen ITcase          = True
+isALRopen ITif            = True
+isALRopen ITthen          = True
+isALRopen IToparen        = True
+isALRopen ITobrack        = True
+isALRopen ITocurly        = True
 -- GHC Extensions:
-isALRopen IToubxparen   = True
-isALRopen ITparenEscape = True
-isALRopen _             = False
+isALRopen IToubxparen     = True
+isALRopen ITparenEscape   = True
+isALRopen ITparenTyEscape = True
+isALRopen _               = False
 
 isALRclose :: Token -> Bool
 isALRclose ITof     = True
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index c2ddf452cc..c0eb7a61f0 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -348,8 +348,12 @@ incorrect.
 '[t|'           { L _ ITopenTypQuote  }
 '[d|'           { L _ ITopenDecQuote  }
 '|]'            { 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 )
 TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T
 TH_QUASIQUOTE   { L _ (ITquasiQuote _) }
 TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
@@ -1552,6 +1556,10 @@ aexp2   :: { LHsExpr RdrName }
                                         (L1 $ HsVar (mkUnqual varName
                                                         (getTH_ID_SPLICE $1)))) }
         | '$(' exp ')'          { LL $ HsSpliceE (mkHsSplice $2) }
+        | TH_ID_TY_SPLICE       { L1 $ HsSpliceE (mkHsSplice
+                                        (L1 $ HsVar (mkUnqual varName
+                                                        (getTH_ID_TY_SPLICE $1)))) }
+        | '$$(' exp ')'         { LL $ HsSpliceE (mkHsSplice $2) }
 
 
         | SIMPLEQUOTE  qvar     { LL $ HsBracket (VarBr True  (unLoc $2)) }
@@ -1559,6 +1567,7 @@ aexp2   :: { LHsExpr RdrName }
         | TH_TY_QUOTE tyvar     { LL $ HsBracket (VarBr False (unLoc $2)) }
         | TH_TY_QUOTE gtycon    { LL $ HsBracket (VarBr False (unLoc $2)) }
         | '[|' exp '|]'         { LL $ HsBracket (ExpBr $2) }
+        | '[||' exp '||]'       { LL $ HsBracket (ExpBr $2) }
         | '[t|' ctype '|]'      { LL $ HsBracket (TypBr $2) }
         | '[p|' infixexp '|]'   {% checkPattern empty $2 >>= \p ->
                                         return (LL $ HsBracket (PatBr p)) }
@@ -2214,6 +2223,7 @@ getPRIMWORD     (L _ (ITprimword x)) = x
 getPRIMFLOAT    (L _ (ITprimfloat  x)) = x
 getPRIMDOUBLE   (L _ (ITprimdouble x)) = x
 getTH_ID_SPLICE (L _ (ITidEscape x)) = x
+getTH_ID_TY_SPLICE (L _ (ITidTyEscape x)) = x
 getINLINE       (L _ (ITinline_prag inl conl)) = (inl,conl)
 getSPEC_INLINE  (L _ (ITspec_inline_prag True))  = (Inline,  FunLike)
 getSPEC_INLINE  (L _ (ITspec_inline_prag False)) = (NoInline,FunLike)