Commit e036ddc0 authored by gmainland's avatar gmainland

Track TH stage in the renamer.

parent d0d47ba7
......@@ -39,7 +39,8 @@ module RdrName (
-- * Local mapping of 'RdrName' to 'Name.Name'
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, inLocalRdrEnvScope,
lookupLocalRdrEnv, lookupLocalRdrThLvl, lookupLocalRdrOcc,
elemLocalRdrEnv, inLocalRdrEnvScope,
localRdrEnvElts, delLocalRdrEnvList,
-- * Global mapping of 'RdrName' to 'GlobalRdrElt's
......@@ -328,40 +329,51 @@ instance Ord RdrName where
-- It is keyed by OccName, because we never use it for qualified names
-- We keep the current mapping, *and* the set of all Names in scope
-- Reason: see Note [Splicing Exact Names] in RnEnv
type LocalRdrEnv = (OccEnv Name, NameSet)
type ThLevel = Int
type LocalRdrEnv = (OccEnv Name, OccEnv ThLevel, NameSet)
emptyLocalRdrEnv :: LocalRdrEnv
emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet)
extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
extendLocalRdrEnv (env, ns) name
= (extendOccEnv env (nameOccName name) name, addOneToNameSet ns name)
extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList (env, ns) names
= (extendOccEnvList env [(nameOccName n, n) | n <- names], addListToNameSet ns names)
emptyLocalRdrEnv = (emptyOccEnv, emptyOccEnv, emptyNameSet)
extendLocalRdrEnv :: LocalRdrEnv -> ThLevel -> Name -> LocalRdrEnv
extendLocalRdrEnv (env, thenv, ns) thlvl name
= ( extendOccEnv env (nameOccName name) name
, extendOccEnv thenv (nameOccName name) thlvl
, addOneToNameSet ns name
)
extendLocalRdrEnvList :: LocalRdrEnv -> ThLevel -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList (env, thenv, ns) thlvl names
= ( extendOccEnvList env [(nameOccName n, n) | n <- names]
, extendOccEnvList thenv [(nameOccName n, thlvl) | n <- names]
, addListToNameSet ns names
)
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ
lookupLocalRdrEnv _ _ = Nothing
lookupLocalRdrEnv (env, _, _) (Unqual occ) = lookupOccEnv env occ
lookupLocalRdrEnv _ _ = Nothing
lookupLocalRdrThLvl :: LocalRdrEnv -> RdrName -> Maybe ThLevel
lookupLocalRdrThLvl (_, thenv, _) (Unqual occ) = lookupOccEnv thenv occ
lookupLocalRdrThLvl _ _ = Nothing
lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name
lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ
lookupLocalRdrOcc (env, _, _) occ = lookupOccEnv env occ
elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
elemLocalRdrEnv rdr_name (env, _)
elemLocalRdrEnv rdr_name (env, _, _)
| isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env
| otherwise = False
localRdrEnvElts :: LocalRdrEnv -> [Name]
localRdrEnvElts (env, _) = occEnvElts env
localRdrEnvElts (env, _, _) = occEnvElts env
inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool
-- This is the point of the NameSet
inLocalRdrEnvScope name (_, ns) = name `elemNameSet` ns
inLocalRdrEnvScope name (_, _, ns) = name `elemNameSet` ns
delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv
delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns)
delLocalRdrEnvList (env, thenv, ns) occs = (delListFromOccEnv env occs, delListFromOccEnv thenv occs, ns)
\end{code}
%************************************************************************
......
......@@ -556,6 +556,7 @@ Here is where we desugar the Template Haskell brackets and escapes
\begin{code}
-- Template Haskell stuff
dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
#ifdef GHCI
dsExpr (HsBracketOut x ps) = dsBracket x ps
#else
......
......@@ -74,7 +74,7 @@ dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
dsBracket brack splices
= dsExtendMetaEnv new_bit (do_brack brack)
where
new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
new_bit = mkNameEnv [(n, Splice (unLoc e)) | PendingTcSplice n e <- splices]
do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
......
......@@ -246,6 +246,13 @@ data HsExpr id
| HsBracket (HsBracket id)
-- See Note [Pending Renamer Splices]
| HsRnBracketOut (HsBracket Name) -- Output of the renamer is
-- the *original*
[PendingSplice] -- renamed expression, plus
-- _renamed_ splices to be
-- type checked
| HsBracketOut (HsBracket Name) -- Output of the type checker is
-- the *original*
[PendingSplice] -- renamed expression, plus
......@@ -338,12 +345,50 @@ tupArgPresent :: HsTupArg id -> Bool
tupArgPresent (Present {}) = True
tupArgPresent (Missing {}) = False
-- | Typechecked splices, waiting to be
-- pasted back in by the desugarer
type PendingSplice = (Name, LHsExpr Id)
-- See Note [Pending Splices]
data PendingSplice
= PendingRnExpSplice Name (LHsExpr Name)
| PendingRnTypeSplice Name (LHsExpr Name)
| PendingRnCrossStageSplice Name
| PendingTcSplice Name (LHsExpr Id)
deriving (Data, Typeable)
\end{code}
Note [Pending Splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Now that untyped brackets are not type checked, we need a mechanism to ensure
that splices contained in untyped brackets *are* type checked. Therefore the
renamer now renames every HsBracket into a HsRnBracketOut, which contains the
splices that need to be type checked. There are three varieties of pending
splices generated by the renamer:
* Pending expression splices (PendingRnExpSplice), e.g.,
[|$(f x) + 2|]
* Pending type splices (PendingRnTypeSplice), e.g.,
[|f :: $(g x)|]
* Pending cross-stage splices (PendingRnCrossStageSplice), e.g.,
\x -> [| x |]
There is a fourth variety of pending splice, which is generated by the type
checker:
* Pending *typed* expression splices, (PendingTcSplice), e.g.,
[||1 + $$(f 2)||]
It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the
output of the renamer. However, when pretty printing the output of the renamer,
e.g., in a type error message, we *do not* want to print out the pending
splices. In contrast, when pretty printing the output of the type checker, we
*do* want to print the pending splices. So splitting them up seems to make
sense, although I hate to add another constructor to HsExpr.
Note [Parens in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~
HsPar (and ParPat in patterns, HsParTy in types) is used as follows
......@@ -548,11 +593,12 @@ ppr_expr (HsSCC lbl expr)
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
ppr_expr (HsType id) = ppr id
ppr_expr (HsSpliceE s) = pprSplice s
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsBracketOut e []) = ppr e
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps
ppr_expr (HsQuasiQuoteE qq) = ppr qq
ppr_expr (HsSpliceE s) = pprSplice s
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsRnBracketOut e _) = ppr e
ppr_expr (HsBracketOut e []) = ppr e
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps
ppr_expr (HsQuasiQuoteE qq) = ppr qq
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
......@@ -634,6 +680,7 @@ hsExprNeedsParens (ExplicitList {}) = False
hsExprNeedsParens (ExplicitPArr {}) = False
hsExprNeedsParens (HsPar {}) = False
hsExprNeedsParens (HsBracket {}) = False
hsExprNeedsParens (HsRnBracketOut {}) = False
hsExprNeedsParens (HsBracketOut _ []) = False
hsExprNeedsParens (HsDo sc _ _)
| isListCompExpr sc = False
......@@ -1374,6 +1421,12 @@ thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
thTyBrackets :: SDoc -> SDoc
thTyBrackets pp_body = ptext (sLit "[||") <+> pp_body <+> ptext (sLit "||]")
instance Outputable PendingSplice where
ppr (PendingRnExpSplice name expr) = ppr (name, expr)
ppr (PendingRnTypeSplice name expr) = ppr (name, expr)
ppr (PendingRnCrossStageSplice name) = ppr name
ppr (PendingTcSplice name expr) = ppr (name, expr)
\end{code}
%************************************************************************
......
......@@ -9,6 +9,7 @@ module RnEnv (
lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
lookupLocalOccRn_maybe,
lookupLocalOccThLvl_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
reportUnboundName,
......@@ -541,6 +542,12 @@ lookupLocalOccRn_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; return (lookupLocalRdrEnv local_env rdr_name) }
lookupLocalOccThLvl_maybe :: RdrName -> RnM (Maybe ThLevel)
-- Just look in the local environment
lookupLocalOccThLvl_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; return (lookupLocalRdrThLvl local_env rdr_name) }
-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name
......@@ -1264,13 +1271,15 @@ bindLocatedLocalsRn rdr_names_w_loc enclosed_scope
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
= do { name_env <- getLocalRdrEnv
; setLocalRdrEnv (extendLocalRdrEnvList name_env names)
; stage <- getStage
; setLocalRdrEnv (extendLocalRdrEnvList name_env (thLevel stage) names)
enclosed_scope }
bindLocalName :: Name -> RnM a -> RnM a
bindLocalName name enclosed_scope
= do { name_env <- getLocalRdrEnv
; setLocalRdrEnv (extendLocalRdrEnv name_env name)
; stage <- getStage
; setLocalRdrEnv (extendLocalRdrEnv name_env (thLevel stage) name)
enclosed_scope }
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
......
......@@ -110,7 +110,14 @@ rnExpr (HsVar v)
-- OverloadedLists works correctly
-> rnExpr (ExplicitList placeHolderType Nothing [])
| otherwise
-> finishHsVar name } }
-> do { mb_bind_lvl <- lookupLocalOccThLvl_maybe v
; case mb_bind_lvl of
{ Nothing -> return ()
; Just bind_lvl
| isExternalName name -> return ()
| otherwise -> checkThLocalName name bind_lvl
}
; finishHsVar name }}}
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
......
\begin{code}
module RnSplice (
rnSpliceType, rnSpliceExpr,
rnBracket, checkTH
rnBracket, checkTH,
checkThLocalName
) where
import Control.Monad ( unless, when )
import DynFlags
import FastString
import Name
import NameSet
import HsSyn
import LoadIface ( loadInterfaceForName )
import Module
import Outputable
import RdrName
import TcRnMonad
#ifdef GHCI
import Control.Monad ( unless, when )
import DynFlags
import DsMeta ( expQTyConName, typeQTyConName )
import LoadIface ( loadInterfaceForName )
import Module
import RnEnv
import RnPat
import RnSource ( rnSrcDecls, findSplice )
import RnTypes
import SrcLoc
import TcEnv ( tcLookup, thTopLevelId )
import TcRnMonad
import TcEnv ( checkWellStaged, tcLookup, tcMetaTy, thTopLevelId )
import {-# SOURCE #-} RnExpr( rnLExpr )
import {-# SOURCE #-} RnExpr ( rnLExpr )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcSplice ( runMetaE, runMetaT, tcTopSpliceExpr )
#endif
\end{code}
\begin{code}
#ifndef GHCI
rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
rnBracket e _ = failTH e "bracket"
rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
rnSpliceType e _ = failTH e "splice"
rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceExpr e = failTH e "splice"
failTH :: Outputable a => a -> String -> RnM b
failTH e what -- Raise an error in a stage-1 compiler
= failWithTc (vcat [ptext (sLit "Template Haskell") <+> text what <+>
ptext (sLit "requires GHC with interpreter support"),
ptext (sLit "Perhaps you are using a stage-1 compiler?"),
nest 2 (ppr e)])
#else
\end{code}
%*********************************************************
......@@ -58,89 +85,128 @@ rnSplice (HsSplice isTyped n expr)
; n' <- newLocalBndrRn (L loc n)
; (expr', fvs) <- rnLExpr expr
-- Ugh! See Note [Splices] above
; lcl_rdr <- getLocalRdrEnv
; gbl_rdr <- getGlobalRdrEnv
; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
isLocalGRE gre]
lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
; if isTyped
then do
{ -- Ugh! See Note [Splices] above
lcl_rdr <- getLocalRdrEnv
; gbl_rdr <- getGlobalRdrEnv
; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
isLocalGRE gre]
lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
; return (HsSplice isTyped n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
; return (HsSplice isTyped n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names)
}
else return (HsSplice isTyped n' expr', fvs)
}
\end{code}
\begin{code}
rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
rnSpliceType splice@(HsSplice _ _ hs_expr) k
= setSrcSpan (getLoc hs_expr) $ do
rnSpliceType splice@(HsSplice isTypedSplice _ expr) k
= setSrcSpan (getLoc expr) $ do
{ stage <- getStage
; case stage of {
Splice {} -> rnTopSpliceType splice k ;
Comp -> rnTopSpliceType splice k ;
Brack _ pop_level _ _ -> do
-- See Note [How brackets and nested splices are handled]
-- A splice inside brackets
{ (splice', fvs) <- setStage pop_level $
rnSplice splice -- ToDo: deal with fvs
; return (HsSpliceTy splice' fvs k, fvs)
}}}
rnTopSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars)
rnTopSpliceType splice@(HsSplice _ _ hs_expr) k
= do { (splice', fvs) <- addErrCtxt (spliceResultDoc hs_expr) $
rnSplice splice -- ToDo: deal with fvs
; return (HsSpliceTy splice' fvs k, fvs)
; case stage of
{ Brack isTypedBrack pop_stage ps_var _ ->
do { when (isTypedBrack && not isTypedSplice) $
failWithTc illegalUntypedSplice
; when (not isTypedBrack && isTypedSplice) $
failWithTc illegalTypedSplice
-- ToDo: deal with fvs
; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $
rnSplice splice
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingRnTypeSplice name expr' : ps)
; return (HsSpliceTy splice' fvs k, fvs)
}
; _ ->
do { -- ToDo: deal with fvs
(splice', fvs) <- addErrCtxt (spliceResultDoc expr) $
setStage (Splice isTypedSplice) $
rnSplice splice
; maybeExpandTopSplice splice' fvs
}
}
}
where
maybeExpandTopSplice :: HsSplice Name -> FreeVars -> RnM (HsType Name, FreeVars)
maybeExpandTopSplice splice@(HsSplice True _ _) fvs
= return (HsSpliceTy splice fvs k, fvs)
maybeExpandTopSplice (HsSplice False _ expr) _
= do { -- The splice must have type TypeQ
; meta_exp_ty <- tcMetaTy typeQTyConName
-- Typecheck the expression
; zonked_q_expr <- tcTopSpliceExpr False $
tcMonoExpr expr meta_exp_ty
-- Run the expression
; hs_ty2 <- runMetaT zonked_q_expr
; showSplice "type" expr (ppr hs_ty2)
; (hs_ty3, fvs) <- addErrCtxt (spliceResultDoc expr) $
do { let doc = SpliceTypeCtx hs_ty2
; checkNoErrs $ rnLHsType doc hs_ty2
-- checkNoErrs: see Note [Renamer errors]
}
; return (unLoc hs_ty3, fvs)
}
\end{code}
\begin{code}
rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceExpr splice@(HsSplice isTypedSplice _ expr)
= setSrcSpan (getLoc expr) $ do
= addErrCtxt (exprCtxt (HsSpliceE splice)) $
setSrcSpan (getLoc expr) $ do
{ stage <- getStage
; case stage of {
Splice {} -> rnTopSplice ;
Comp -> rnTopSplice ;
Brack isTypedBrack pop_stage _ _ -> do
-- See Note [How brackets and nested splices are handled]
-- A splice inside brackets
-- NB: ignore res_ty, apart from zapping it to a mono-type
-- e.g. [| reverse $(h 4) |]
-- Here (h 4) :: Q Exp
-- but $(h 4) :: forall a.a i.e. anything!
{ when (isTypedBrack && not isTypedSplice) $
failWithTc illegalUntypedSplice
; when (not isTypedBrack && isTypedSplice) $
failWithTc illegalTypedSplice
; (splice', fvs) <- setStage pop_stage $
rnSplice splice
; return (HsSpliceE splice', fvs)
}}}
; case stage of
{ Brack isTypedBrack pop_stage ps_var _ ->
do { when (isTypedBrack && not isTypedSplice) $
failWithTc illegalUntypedSplice
; when (not isTypedBrack && isTypedSplice) $
failWithTc illegalTypedSplice
; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $
rnSplice splice
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingRnExpSplice name expr' : ps)
; return (HsSpliceE splice', fvs)
}
; _ ->
do { (splice', fvs) <- addErrCtxt (spliceResultDoc expr) $
setStage (Splice isTypedSplice) $
rnSplice splice
; maybeExpandTopSplice splice' fvs
}
}
}
where
rnTopSplice :: RnM (HsExpr Name, FreeVars)
rnTopSplice
= do { (splice', fvs) <- addErrCtxt (spliceResultDoc expr) $
setStage (Splice isTypedSplice) $
rnSplice splice
; return (HsSpliceE splice', fvs)
}
\end{code}
\begin{code}
checkTH :: Outputable a => a -> String -> RnM ()
#ifdef GHCI
checkTH _ _ = return () -- OK
#else
checkTH e what -- Raise an error in a stage-1 compiler
= addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>
ptext (sLit "requires GHC with interpreter support"),
ptext (sLit "Perhaps you are using a stage-1 compiler?"),
nest 2 (ppr e)])
#endif
maybeExpandTopSplice :: HsSplice Name -> FreeVars -> RnM (HsExpr Name, FreeVars)
maybeExpandTopSplice splice@(HsSplice True _ _) fvs
= return (HsSpliceE splice, fvs)
maybeExpandTopSplice (HsSplice False _ expr) _
= do { -- The splice must have type ExpQ
; meta_exp_ty <- tcMetaTy expQTyConName
-- Typecheck the expression
; zonked_q_expr <- tcTopSpliceExpr False $
tcMonoExpr expr meta_exp_ty
-- Run the expression
; expr2 <- runMetaE zonked_q_expr
; showSplice "expression" expr (ppr expr2)
; (lexpr3, fvs) <- addErrCtxt (spliceResultDoc expr) $
checkNoErrs $
rnLExpr expr2
; return (unLoc lexpr3, fvs)
}
\end{code}
%************************************************************************
......@@ -173,11 +239,14 @@ rnBracket e br_body
-- Brackets are desugared to code that mentions the TH package
; recordThUse
; let brack_stage = Brack (isTypedBracket br_body) cur_stage (error "rnBracket1") (error "rnBracket2")
; pending_splices <- newMutVar []
; let brack_stage = Brack (isTypedBracket br_body) cur_stage pending_splices (error "rnBracket: don't neet lie")
; (body', fvs_e) <- setStage brack_stage $
rn_bracket cur_stage br_body
; return (HsBracket body', fvs_e)
; pendings <- readMutVar pending_splices
; return (HsRnBracketOut body' pendings, fvs_e)
}
rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
......@@ -185,26 +254,42 @@ rn_bracket outer_stage br@(VarBr flg n)
= do { name <- lookupOccRn n
; this_mod <- getModule
-- Reason: deprecation checking assumes
-- the home interface is loaded, and
-- this is the only way that is going
-- to happen
; unless (nameIsLocalOrFrom this_mod name) $
do { _ <- loadInterfaceForName msg name
; thing <- tcLookup name
; case thing of
{ AGlobal {} -> return ()
; ATyVar {} -> return ()
; ATcId { tct_level = bind_lvl, tct_id = id }
| thTopLevelId id -- C.f TcExpr.checkCrossStageLifting
-> keepAliveTc id
| otherwise
-> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr br) }
; _ -> pprPanic "rh_bracket" (ppr name $$ ppr thing)
}
}
; case flg of
{ -- Type variables can be quoted in TH. See #5721.
False -> return ()
; True | nameIsLocalOrFrom this_mod name ->
do { mb_bind_lvl <- lookupLocalOccThLvl_maybe n
; case mb_bind_lvl of
{ Nothing -> return ()
; Just bind_lvl
| isExternalName name -> return ()
-- Local non-external things can still be
-- top-level in GHCi, so check for that here.
| bind_lvl == impLevel -> return ()
| otherwise -> checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr br)
}
}
; True | otherwise ->
-- Reason: deprecation checking assumes
-- the home interface is loaded, and
-- this is the only way that is going
-- to happen
do { _ <- loadInterfaceForName msg name
; thing <- tcLookup name
; case thing of
{ AGlobal {} -> return ()
; ATyVar {} -> return ()
; ATcId { tct_level = bind_lvl, tct_id = id }
| thTopLevelId id -- C.f TcExpr.checkCrossStageLifting
-> keepAliveTc id
| otherwise
-> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr br) }
; _ -> pprPanic "rh_bracket" (ppr name $$ ppr thing)
}
}
}
; return (VarBr flg name, unitFV name) }
where
msg = ptext (sLit "Need interface for Template Haskell quoted Name")
......@@ -247,6 +332,23 @@ rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
\end{code}
\begin{code}
exprCtxt :: HsExpr RdrName -> SDoc
exprCtxt expr
= hang (ptext (sLit "In the expression:")) 2 (ppr expr)
showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
-- Note that 'before' is *renamed* but not *typechecked*
-- Reason (a) less typechecking crap
-- (b) data constructors after type checking have been
-- changed to their *wrappers*, and that makes them
-- print always fully qualified
showSplice what before after
= do { loc <- getSrcSpanM
; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
nest 2 (sep [nest 2 (ppr before),
text "======>",
nest 2 after])]) }
illegalBracket :: SDoc
illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
......@@ -267,7 +369,84 @@ quotedNameStageErr br
= sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br
, ptext (sLit "must be used at the same stage at which is is bound")]
spliceResultDoc :: LHsExpr RdrName -> SDoc
spliceResultDoc :: OutputableBndr id => LHsExpr id -> SDoc
spliceResultDoc expr
= hang (ptext (sLit "In the splice:")) 2 (char '$' <> pprParendExpr expr)
= sep [ ptext (sLit "In the result of the splice:")
, nest 2 (char '$' <> pprParendExpr expr)
, ptext (sLit "To see what the splice expanded to, use -ddump-splices")]
#endif
\end{code}
\begin{code}
checkTH :: Outputable a => a -> String -> RnM ()
#ifdef GHCI
checkTH _ _ = return () -- OK
#else
checkTH e what -- Raise an error in a stage-1 compiler
= addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+>
ptext (sLit "requires GHC with interpreter support"),
ptext (sLit "Perhaps you are using a stage-1 compiler?"),
nest 2 (ppr e)])
#endif
\end{code}
\begin{code}
checkThLocalName :: Name -> ThLevel -> RnM ()
#ifndef GHCI /* GHCI and TH is off */
--------------------------------------
-- Check for cross-stage lifting
checkThLocalName _name _bind_lvl
= return ()
#else /* GHCI and TH is on */
checkThLocalName name bind_lvl
= do { use_stage <- getStage -- TH case
; let use_lvl = thLevel use_stage
; traceRn (text "checkThLocalName" <+> ppr name)
; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
; traceTc "thLocalId" (ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
; when (use_lvl > bind_lvl) $
checkCrossStageLifting name bind_lvl use_stage }
--------------------------------------