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)
......
This diff is collapsed.
......@@ -337,7 +337,9 @@ getInLocalScope = do { lcl_env <- getLclTypeEnv
\begin{code}
tcExtendTcTyThingEnv :: [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendTcTyThingEnv things thing_inside
= updLclEnv (extend_local_env things) thing_inside
= do { stage <- getStage
; updLclEnv (extend_local_env (thLevel stage) things) thing_inside
}
tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
tcExtendKindEnv name_kind_prs
......@@ -351,10 +353,11 @@ tcExtendTyVarEnv tvs thing_inside
tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r
tcExtendTyVarEnv2 binds thing_inside
= tc_extend_local_env [(name, ATyVar name tv) | (name, tv) <- binds] $
do { env <- getLclEnv
; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) }
; setLclEnv env' thing_inside }
= do { stage <- getStage
; tc_extend_local_env (thLevel stage) [(name, ATyVar name tv) | (name, tv) <- binds] $
do { env <- getLclEnv
; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) }
; setLclEnv env' thing_inside }}
where
add_tidy_tvs env = foldl add env binds
......@@ -380,7 +383,8 @@ getScopedTyVarBinds
tcExtendLetEnv :: TopLevelFlag -> TopLevelFlag -> [TcId] -> TcM a -> TcM a
tcExtendLetEnv top_lvl closed ids thing_inside
= do { stage <- getStage
; tc_extend_local_env [ (idName id, ATcId { tct_id = id
; tc_extend_local_env (thLevel stage)
[ (idName id, ATcId { tct_id = id
, tct_closed = closed
, tct_level = thLevel stage })
| id <- ids] $
......@@ -404,7 +408,8 @@ tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
tcExtendIdEnv2 names_w_ids thing_inside
= do { stage <- getStage
; tc_extend_local_env [ (name, ATcId { tct_id = id
; tc_extend_local_env (thLevel stage)
[ (name, ATcId { tct_id = id
, tct_closed = NotTopLevel
, tct_level = thLevel stage })
| (name,id) <- names_w_ids] $
......@@ -422,7 +427,8 @@ tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
-- * Closedness flag is TopLevel. The thing's type is closed
tcExtendGhciEnv ids thing_inside
= tc_extend_local_env [ (idName id, ATcId { tct_id = id
= tc_extend_local_env impLevel
[ (idName id, ATcId { tct_id = id
, tct_closed = is_top id
, tct_level = impLevel })
| id <- ids]
......@@ -432,7 +438,7 @@ tcExtendGhciEnv ids thing_inside
| otherwise = NotTopLevel
tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env :: ThLevel -> [(Name, TcTyThing)] -> TcM a -> TcM a
-- This is the guy who does the work
-- Invariant: the TcIds are fully zonked. Reasons:
-- (a) The kinds of the forall'd type variables are defaulted
......@@ -441,10 +447,10 @@ tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a
-- in the types, because instantiation does not look through such things
-- (c) The call to tyVarsOfTypes is ok without looking through refs
tc_extend_local_env extra_env thing_inside
tc_extend_local_env thlvl extra_env thing_inside
= do { traceTc "env2" (ppr extra_env)
; env1 <- getLclEnv
; let env2 = extend_local_env extra_env env1
; let env2 = extend_local_env thlvl extra_env env1
; env3 <- extend_gtvs env2
; setLclEnv env3 thing_inside }
where
......@@ -479,10 +485,10 @@ tc_extend_local_env extra_env thing_inside
--
-- Nor must we generalise g over any kind variables free in r's kind
extend_local_env :: [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
extend_local_env :: ThLevel -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
-- Extend the local TcTypeEnv *and* the local LocalRdrEnv simultaneously
extend_local_env pairs env@(TcLclEnv { tcl_rdr = rdr_env, tcl_env = type_env })
= env { tcl_rdr = extendLocalRdrEnvList rdr_env (map fst pairs)
extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env, tcl_env = type_env })
= env { tcl_rdr = extendLocalRdrEnvList rdr_env thlvl (map fst pairs)
, tcl_env = extendNameEnvList type_env pairs }
tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
......
......@@ -799,8 +799,10 @@ tcExpr (PArrSeq _ _) _
\begin{code}
#ifdef GHCI /* Only if bootstrapped */
-- Rename excludes these cases otherwise
tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
tcExpr (HsBracket brack) res_ty = tcBracket brack res_ty
tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
tcExpr (HsRnBracketOut brack ps) res_ty = tcBracket brack ps res_ty
tcExpr e@(HsBracketOut _ _) _ =
pprPanic "Should never see HsBracketOut in type checker" (ppr e)
tcExpr e@(HsQuasiQuoteE _) _ =
pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
#endif /* GHCI */
......@@ -1334,7 +1336,7 @@ checkCrossStageLifting id _ (Brack _ _ ps_var lie_var)
-- Update the pending splices
; ps <- readMutVar ps_var
; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps)
; writeMutVar ps_var (PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id)) : ps)
; return () }
#endif /* GHCI */
......
......@@ -553,12 +553,25 @@ zonkExpr env (HsApp e1 e2)
new_e2 <- zonkLExpr env e2
return (HsApp new_e1 new_e2)
zonkExpr _ e@(HsRnBracketOut _ _)
= pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
zonkExpr env (HsBracketOut body bs)
= do bs' <- mapM zonk_b bs
return (HsBracketOut body bs')
where
zonk_b (n,e) = do e' <- zonkLExpr env e
return (n,e')
zonk_b (PendingRnExpSplice _ e)
= pprPanic "zonkExpr: PendingRnExpSplice" (ppr e)
zonk_b (PendingRnCrossStageSplice n)
= pprPanic "zonkExpr: PendingRnCrossStageSplice" (ppr n)
zonk_b (PendingRnTypeSplice _ e)
= pprPanic "zonkExpr: PendingRnTypeSplice" (ppr e)
zonk_b (PendingTcSplice n e)
= do e' <- zonkLExpr env e
return (PendingTcSplice n e')
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
return (HsSpliceE s)
......
This diff is collapsed.
......@@ -2,6 +2,8 @@
module TcSplice where
import HsSyn ( HsSplice, HsBracket, HsQuasiQuote,
HsExpr, LHsType, LHsExpr, LPat, LHsDecl )
import HsExpr ( PendingSplice )
import Id ( Id )
import Name ( Name )
import NameSet ( FreeVars )
import RdrName ( RdrName )
......@@ -16,11 +18,14 @@ tcSpliceExpr :: HsSplice Name
tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind)
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcBracket :: HsBracket Name
-> [PendingSplice]
-> TcRhoType
-> TcM (HsExpr TcId)
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id)
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
......@@ -29,4 +34,8 @@ runQuasiQuoteExpr :: HsQuasiQuote RdrName -> TcM (LHsExpr RdrName)
runQuasiQuoteType :: HsQuasiQuote RdrName -> TcM (LHsType RdrName)
runQuasiQuotePat :: HsQuasiQuote RdrName -> TcM (LPat RdrName)
runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
runMetaE :: LHsExpr Id -> TcM (LHsExpr RdrName)
runMetaT :: LHsExpr Id -> TcM (LHsType RdrName)
runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName]
\end{code}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment