Differentiate typed and untyped splices and brackets in the abstract syntax.

7 files changed, 35 insertions, 15 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index d35a327d41..5d5318598f 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -82,6 +82,7 @@ dsBracket brack splices
     do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }
     do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
     do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"
+    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
 
 {- -------------- Examples --------------------
 
@@ -901,7 +902,7 @@ repRole (L _ Nothing)                 = rep2 inferRName []
 repSplice :: HsSplice Name -> DsM (Core a)
 -- See Note [How brackets and nested splices are handled] in TcSplice
 -- We return a CoreExpr of any old type; the context should know
-repSplice (HsSplice n _)
+repSplice (HsSplice _ n _)
  = do { mb_val <- dsLookupMetaEnv n
        ; case mb_val of
            Just (Splice e) -> do { e' <- dsExpr e
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 27286ca928..b570d631c7 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -1318,6 +1318,7 @@ pprQuals quals = interpp'SP quals
 
 \begin{code}
 data HsSplice id  = HsSplice            --  $z  or $(f 4)
+                        Bool            -- True if typed, False if untyped
                         id              -- The id is just a unique name to
                         (LHsExpr id)    -- identify this splice point
   deriving (Data, Typeable)
@@ -1326,8 +1327,9 @@ instance OutputableBndr id => Outputable (HsSplice id) where
   ppr = pprSplice
 
 pprSplice :: OutputableBndr id => HsSplice id -> SDoc
-pprSplice (HsSplice n e)
-    = char '$' <> ifPprDebug (brackets (ppr n)) <> eDoc
+pprSplice (HsSplice isTyped n e)
+    = (if isTyped then ptext (sLit "$$") else char '$')
+      <> ifPprDebug (brackets (ppr n)) <> eDoc
     where
           -- We use pprLExpr to match pprParendExpr:
           --     Using pprLExpr makes sure that we go 'deeper'
@@ -1345,6 +1347,7 @@ data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]
                   | TypBr (LHsType id)   -- [t| type  |]
                   | VarBr Bool id        -- True: 'x, False: ''T
                                          -- (The Bool flag is used only in pprHsBracket)
+                  | TExpBr (LHsExpr id)  -- [||  expr  ||]
   deriving (Data, Typeable)
 
 instance OutputableBndr id => Outputable (HsBracket id) where
@@ -1359,10 +1362,14 @@ pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
 pprHsBracket (TypBr t)   = thBrackets (char 't') (ppr t)
 pprHsBracket (VarBr True n)  = char '\''         <> ppr n
 pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n
+pprHsBracket (TExpBr e)  = thTyBrackets (ppr e)
 
 thBrackets :: SDoc -> SDoc -> SDoc
 thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
                              pp_body <+> ptext (sLit "|]")
+
+thTyBrackets :: SDoc -> SDoc
+thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]")
 \end{code}
 
 %************************************************************************
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 398b97b917..67b3d0266f 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -54,7 +54,7 @@ module HsUtils(
   emptyRecStmt, mkRecStmt, 
 
   -- Template Haskell
-  unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote,
+  unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsTExpSplice, mkHsQuasiQuote, unqualQuasiQuote,
 
   -- Flags
   noRebindableInfo, 
@@ -247,7 +247,10 @@ mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
 mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 
 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
-mkHsSplice e = HsSplice unqualSplice e
+mkHsSplice e = HsSplice False unqualSplice e
+
+mkHsTExpSplice :: LHsExpr RdrName -> HsSplice RdrName
+mkHsTExpSplice e = HsSplice True unqualSplice e
 
 mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
 mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index c0eb7a61f0..eb7a4b2cdf 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1556,10 +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
+        | TH_ID_TY_SPLICE       { L1 $ HsSpliceE (mkHsTExpSplice
                                         (L1 $ HsVar (mkUnqual varName
                                                         (getTH_ID_TY_SPLICE $1)))) }
-        | '$$(' exp ')'         { LL $ HsSpliceE (mkHsSplice $2) }
+        | '$$(' exp ')'         { LL $ HsSpliceE (mkHsTExpSplice $2) }
 
 
         | SIMPLEQUOTE  qvar     { LL $ HsBracket (VarBr True  (unLoc $2)) }
@@ -1567,7 +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) }
+        | '[||' exp '||]'       { LL $ HsBracket (TExpBr $2) }
         | '[t|' ctype '|]'      { LL $ HsBracket (TypBr $2) }
         | '[p|' infixexp '|]'   {% checkPattern empty $2 >>= \p ->
                                         return (LL $ HsBracket (PatBr p)) }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 363d49fae0..2546cdecaa 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -222,9 +222,9 @@ mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 -- but if she wrote, say,
 --      f x            then behave as if she'd written $(f x)
 --                     ie a SpliceD
-mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq
-mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr       Explicit)
-mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr Implicit)
+mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))              = QuasiQuoteD qq
+mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ _ expr))) = SpliceD (SpliceDecl expr       Explicit)
+mkTopSpliceDecl other_expr                            = SpliceD (SpliceDecl other_expr Implicit)
 
 -- Ensure a type literal is used correctly; notably, we need the proper extension enabled,
 -- and if it's an integer literal, the literal must be >= 0. This can occur with
diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs
index 5440e58c88..5741f75925 100644
--- a/compiler/rename/RnSplice.lhs
+++ b/compiler/rename/RnSplice.lhs
@@ -52,7 +52,7 @@ type checker.  Not very satisfactory really.
 
 \begin{code}
 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
-rnSplice (HsSplice n expr)
+rnSplice (HsSplice isTyped n expr)
   = do  { checkTH expr "splice"
         ; loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (L loc n)
@@ -65,7 +65,7 @@ rnSplice (HsSplice n expr)
                                                     isLocalGRE gre]
               lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
 
-        ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
+        ; return (HsSplice isTyped n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
 \end{code}
 
 \begin{code}
@@ -159,4 +159,7 @@ rn_bracket (DecBrL decls)
         ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
 
 rn_bracket (DecBrG _) = panic "rn_bracket: unexpected DecBrG"
+
+rn_bracket (TExpBr e) = do { (e', fvs) <- rnLExpr e
+                           ; return (TExpBr e', fvs) }
 \end{code}
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 9f7ef4070c..9468de8290 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -424,6 +424,12 @@ tc_bracket _ (PatBr pat)
 tc_bracket _ (DecBrL _)
   = panic "tc_bracket: Unexpected DecBrL"
 
+tc_bracket _ (TExpBr expr)
+  = do  { any_ty <- newFlexiTyVarTy openTypeKind
+        ; _ <- tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
+        ; tcMetaTy expQTyConName }
+        -- Result type is ExpQ (= Q Exp)
+
 quotedNameStageErr :: HsBracket Name -> SDoc
 quotedNameStageErr br
   = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br
@@ -438,7 +444,7 @@ quotedNameStageErr br
 %************************************************************************
 
 \begin{code}
-tcSpliceExpr (HsSplice name expr) res_ty
+tcSpliceExpr (HsSplice _ name expr) res_ty
   = setSrcSpan (getLoc expr)    $ do
     { stage <- getStage
     ; case stage of {
@@ -538,7 +544,7 @@ We don't want the type checker to see these bogus unbound variables.
 Very like splicing an expression, but we don't yet share code.
 
 \begin{code}
-tcSpliceType (HsSplice name hs_expr) _
+tcSpliceType (HsSplice _ name hs_expr) _
   = setSrcSpan (getLoc hs_expr) $ do
     { stage <- getStage
     ; case stage of {