Typecheck typed TH splices properly (fix Trac #8577)

This was an egregious error.  If e :: T (Q ty1)
then when we have the splice

     $e :: ty2

we must ensure that ty1~ty2 before we even think about
running the splice!

I took the opportunity to remove the dead-code tcSpliceDecls
altogether.

4 files changed, 22 insertions, 31 deletions

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 61c41da6f0..bb91790bbb 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -1382,6 +1382,9 @@ instance OutputableBndr id => Outputable (HsSplice id) where
 pprUntypedSplice :: OutputableBndr id => HsSplice id -> SDoc
 pprUntypedSplice = pprSplice False
 
+pprTypedSplice :: OutputableBndr id => HsSplice id -> SDoc
+pprTypedSplice = pprSplice True
+
 pprSplice :: OutputableBndr id => Bool -> HsSplice id -> SDoc
 pprSplice is_typed (HsSplice n e)
     = (if is_typed then ptext (sLit "$$") else char '$')
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index ccd11967d2..a26c2697a7 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -797,7 +797,10 @@ tcExpr (PArrSeq _ _) _
 %************************************************************************
 
 \begin{code}
-tcExpr (HsSpliceE is_ty splice)  res_ty = tcSpliceExpr is_ty splice res_ty
+tcExpr (HsSpliceE is_ty splice)  res_ty
+  = ASSERT( is_ty )   -- Untyped splices are expanced by the renamer
+   tcSpliceExpr splice res_ty
+
 tcExpr (HsBracket brack)         res_ty = tcTypedBracket   brack res_ty
 tcExpr (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty
 \end{code}
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 2277871daf..100ed341be 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -12,7 +12,7 @@ TcSplice: Template Haskell splices
 module TcSplice(
      -- These functions are defined in stage1 and stage2
      -- The raise civilised errors in stage1
-     tcSpliceExpr, tcSpliceDecls, tcTypedBracket, tcUntypedBracket,
+     tcSpliceExpr, tcTypedBracket, tcUntypedBracket,
      runQuasiQuoteExpr, runQuasiQuotePat,
      runQuasiQuoteDecl, runQuasiQuoteType,
      runAnnotation,
@@ -116,8 +116,7 @@ import GHC.Exts         ( unsafeCoerce# )
 \begin{code}
 tcTypedBracket   :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
 tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> TcRhoType -> TcM (HsExpr TcId)
-tcSpliceDecls    :: HsSplice Name -> TcM [LHsDecl RdrName]
-tcSpliceExpr     :: Bool -> HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
+tcSpliceExpr     :: HsSplice Name  -> TcRhoType -> TcM (HsExpr TcId)
         -- None of these functions add constraints to the LIE
 
 runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
@@ -130,8 +129,7 @@ runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
 #ifndef GHCI
 tcTypedBracket   x _   = failTH x "Template Haskell bracket"
 tcUntypedBracket x _ _ = failTH x "Template Haskell bracket"
-tcSpliceExpr  _ e _ = failTH e "Template Haskell splice"
-tcSpliceDecls x     = failTH x "Template Haskell declaration splice"
+tcSpliceExpr  e _      = failTH e "Template Haskell splice"
 
 runQuasiQuoteExpr q = failTH q "quasiquote"
 runQuasiQuotePat  q = failTH q "pattern quasiquote"
@@ -417,9 +415,8 @@ tcTExpTy tau = do
 %************************************************************************
 
 \begin{code}
-tcSpliceExpr is_typed splice@(HsSplice name expr) res_ty
-  = ASSERT2( is_typed, ppr splice ) 
-    addErrCtxt (spliceCtxtDoc splice) $
+tcSpliceExpr splice@(HsSplice name expr) res_ty
+  = addErrCtxt (spliceCtxtDoc splice) $
     setSrcSpan (getLoc expr)    $ do
     { stage <- getStage
     ; case stage of
@@ -449,20 +446,21 @@ tcNestedSplice _ _ splice_name _ _
 
 tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
 tcTopSplice expr res_ty
-  = do { any_ty <- newFlexiTyVarTy openTypeKind
-       ; meta_exp_ty <- tcTExpTy any_ty
-
-        -- Typecheck the expression
+  = do { -- Typecheck the expression,
+         -- making sure it has type Q (T res_ty)
+         meta_exp_ty <- tcTExpTy res_ty
        ; zonked_q_expr <- tcTopSpliceExpr True $
                           tcMonoExpr expr meta_exp_ty
 
-        -- Run the expression
+         -- Run the expression
        ; expr2 <- runMetaE zonked_q_expr
        ; showSplice "expression" expr (ppr expr2)
 
+         -- Rename and typecheck the spliced-in expression,
+         -- making sure it has type res_ty
+         -- These steps should never fail; this is a *typed* splice
        ; addErrCtxt (spliceResultDoc expr) $ do
-       { (exp3, _fvs) <- checkNoErrs $ rnLExpr expr2
-                         -- checkNoErrs: see Note [Renamer errors]
+       { (exp3, _fvs) <- rnLExpr expr2
        ; exp4 <- tcMonoExpr exp3 res_ty
        ; return (unLoc exp4) } }
 \end{code}
@@ -470,17 +468,6 @@ tcTopSplice expr res_ty
 
 %************************************************************************
 %*                                                                      *
-\subsection{Splicing a pattern}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-tcSpliceDecls splice
-  = pprPanic "tcSpliceDecls: encountered a typed type splice" (ppr splice)
-\end{code}
-
-%************************************************************************
-%*                                                                      *
 \subsection{Error messages}
 %*                                                                      *
 %************************************************************************
@@ -494,7 +481,7 @@ quotationCtxtDoc br_body
 spliceCtxtDoc :: HsSplice Name -> SDoc
 spliceCtxtDoc splice
   = hang (ptext (sLit "In the Template Haskell splice"))
-         2 (ppr splice)
+         2 (pprTypedSplice splice)
 
 spliceResultDoc :: LHsExpr Name -> SDoc
 spliceResultDoc expr
diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot
index b96cf18311..c496aed798 100644
--- a/compiler/typecheck/TcSplice.lhs-boot
+++ b/compiler/typecheck/TcSplice.lhs-boot
@@ -14,12 +14,10 @@ import Annotations ( Annotation, CoreAnnTarget )
 import qualified Language.Haskell.TH as TH
 #endif
 
-tcSpliceExpr :: Bool -> HsSplice Name
+tcSpliceExpr :: HsSplice Name
              -> TcRhoType
              -> TcM (HsExpr TcId)
 
-tcSpliceDecls :: HsSplice Name -> TcM [LHsDecl RdrName]
-
 tcUntypedBracket :: HsBracket Name
                  -> [PendingRnSplice]
                  -> TcRhoType