[commit: ghc] master: Typecheck typed TH splices properly (fix Trac #8577) (8b642de)
git at git.haskell.org
git at git.haskell.org
Thu Dec 5 08:31:26 UTC 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/8b642debfabe00377f47d461d31d70636bf0fce3/ghc
>---------------------------------------------------------------
commit 8b642debfabe00377f47d461d31d70636bf0fce3
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Dec 4 18:04:08 2013 +0000
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.
>---------------------------------------------------------------
8b642debfabe00377f47d461d31d70636bf0fce3
compiler/hsSyn/HsExpr.lhs | 3 +++
compiler/typecheck/TcExpr.lhs | 5 ++++-
compiler/typecheck/TcSplice.lhs | 41 ++++++++++++----------------------
compiler/typecheck/TcSplice.lhs-boot | 4 +---
4 files changed, 22 insertions(+), 31 deletions(-)
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 61c41da..bb91790 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 ccd1196..a26c269 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 2277871..100ed34 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 b96cf18..c496aed 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
More information about the ghc-commits
mailing list