tcGetInstEnv, tcSetInstEnv,
InstInfo(..), pprInstInfo, pprInstInfoDetails,
simpleInstInfoTy, simpleInstInfoTyCon,
+ InstBindings(..),
-- Global environment
tcExtendGlobalEnv,
tcExtendLocalValEnv, tcExtendLocalValEnv2,
tcLookup, tcLookupLocalIds, tcLookup_maybe,
tcLookupId, tcLookupIdLvl,
- getLclEnvElts, getInLocalScope,
+ lclEnvElts, getInLocalScope, findGlobals,
-- Instance environment
tcExtendLocalInstEnv, tcExtendInstEnv,
-- Global type variables
tcGetGlobalTyVars,
- -- Random useful things
- RecTcGblEnv, tcLookupRecId_maybe,
-
-- Template Haskell stuff
- wellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
+ checkWellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
+ topIdLvl,
-- New Ids
newLocalName, newDFunName,
import RnHsSyn ( RenamedMonoBinds, RenamedSig )
import HsSyn ( RuleDecl(..), ifaceRuleDeclName )
import TcRnMonad
-import TcMType ( zonkTcTyVarsAndFV )
+import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
- tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
- getDFunTyKey, tcTyConAppTyCon,
+ tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
+ getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo,
+ tidyOpenType, tidyOpenTyVar
)
+import qualified Type ( getTyVar_maybe )
import Rules ( extendRuleBase )
-import Id ( idName, isDataConWrapId_maybe )
+import Id ( idName, isLocalId, isDataConWrapId_maybe )
import Var ( TyVar, Id, idType )
import VarSet
+import VarEnv
import CoreSyn ( IdCoreRule )
import DataCon ( DataCon )
import TyCon ( TyCon, DataConDetails )
)
import NameEnv
import OccName ( mkDFunOcc, occNameString )
-import HscTypes ( DFunId, TypeEnv, extendTypeEnvList,
+import HscTypes ( DFunId, TypeEnv, extendTypeEnvList, lookupType,
TyThing(..), ExternalPackageState(..) )
import Rules ( RuleBase )
import BasicTypes ( EP )
metaLevel (Splice l) = l
metaLevel (Brack l _ _) = l
-wellStaged :: Level -- Binding level
- -> Level -- Use level
- -> Bool
-wellStaged bind_stage use_stage
- = bind_stage <= use_stage
+
+checkWellStaged :: SDoc -- What the stage check is for
+ -> Level -- Binding level
+ -> Stage -- Use stage
+ -> TcM () -- Fail if badly staged, adding an error
+checkWellStaged pp_thing bind_lvl use_stage
+ | bind_lvl <= use_lvl -- OK!
+ = returnM ()
+
+ | bind_lvl == topLevel -- GHC restriction on top level splices
+ = failWithTc $
+ sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
+ nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
+
+ | otherwise -- Badly staged
+ = failWithTc $
+ ptext SLIT("Stage error:") <+> pp_thing <+>
+ hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
+ ptext SLIT("but used at stage") <+> ppr use_lvl]
+ where
+ use_lvl = metaLevel use_stage
+
+
+topIdLvl :: Id -> Level
+-- Globals may either be imported, or may be from an earlier "chunk"
+-- (separated by declaration splices) of this module. The former
+-- *can* be used inside a top-level splice, but the latter cannot.
+-- Hence we give the former impLevel, but the latter topLevel
+-- E.g. this is bad:
+-- x = [| foo |]
+-- $( f x )
+-- By the time we are prcessing the $(f x), the binding for "x"
+-- will be in the global env, not the local one.
+topIdLvl id | isLocalId id = topLevel
+ | otherwise = impLevel
-- Indicates the legal transitions on bracket( [| |] ).
bracketOK :: Stage -> Maybe Level
%************************************************************************
%* *
-\subsection{Basic lookups}
-%* *
-%************************************************************************
-
-\begin{code}
-type RecTcGblEnv = TcGblEnv
--- This environment is used for getting the 'right' IdInfo
--- on imported things and for looking up Ids in unfoldings
--- The environment doesn't have any local Ids in it
-
-tcLookupRecId_maybe :: RecTcGblEnv -> Name -> Maybe Id
-tcLookupRecId_maybe env name = case lookup_global env name of
- Just (AnId id) -> Just id
- other -> Nothing
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Making new Ids}
%* *
%************************************************************************
returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
\end{code}
-Make a name for the dict fun for an instance decl.
-It's a *local* name for the moment. The CoreTidy pass
-will externalise it.
+Make a name for the dict fun for an instance decl. It's a *local*
+name for the moment. The CoreTidy pass will externalise it. Even in
+--make and ghci stuff, we rebuild the instance environment each time,
+so the dfun id is internal to begin with, and external when compiling
+other modules
\begin{code}
newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
(lcl_things, pkg_things) = partition (isLocalThing mod) things
ge' = extendTypeEnvList (tcg_type_env env) lcl_things
eps' = eps { eps_PTE = extendTypeEnvList (eps_PTE eps) pkg_things }
- ist' = mkImpTypeEnv eps' hpt
; setEps eps'
- ; setGblEnv (env {tcg_type_env = ge', tcg_ist = ist'}) thing_inside }
+ ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
-- Same deal as tcExtendGlobalEnv, but for Ids
\begin{code}
-lookup_global :: TcGblEnv -> Name -> Maybe TyThing
- -- Try the global envt and then the global symbol table
-lookup_global env name
- = lookupNameEnv (tcg_type_env env) name
- `seqMaybe`
- tcg_ist env name
-
tcLookupGlobal_maybe :: Name -> TcRn m (Maybe TyThing)
+-- This is a rather heavily-used function, so I've inlined a few things (e.g. getEps)
+-- Notice that for imported things we read the current version from the EPS
+-- mutable variable. This is important in situations like
+-- ...$(e1)...$(e2)...
+-- where the code that e1 expands to might import some defns that
+-- also turn out to be needed by the code that e2 expands to.
tcLookupGlobal_maybe name
- = getGblEnv `thenM` \ env ->
- returnM (lookup_global env name)
+ = do { env <- getGblEnv
+ ; if nameIsLocalOrFrom (tcg_mod env) name then
+ -- Defined in this module
+ return (lookupNameEnv (tcg_type_env env) name)
+ else
+ do { env <- getTopEnv
+ ; eps <- readMutVar (top_eps env)
+ ; return (lookupType (top_hpt env) (eps_PTE eps) name) }}
\end{code}
A variety of global lookups, when we know what we are looking for.
getInGlobalScope :: TcRn m (Name -> Bool)
-getInGlobalScope = do { gbl_env <- getGblEnv ;
- return (\n -> isJust (lookup_global gbl_env n)) }
+-- Get all things in the global environment; used for deciding what
+-- rules to suck in. Anything defined in this module (nameIsLocalOrFrom)
+-- is certainly in the envt, so we don't bother to look.
+getInGlobalScope
+ = do { mod <- getModule
+ ; eps <- getEps
+ ; hpt <- getHpt
+ ; return (\n -> nameIsLocalOrFrom mod n ||
+ isJust (lookupType hpt (eps_PTE eps) n)) }
\end{code}
= tcLookup name `thenM` \ thing ->
case thing of
ATcId tc_id lvl -> returnM (tc_id, lvl)
- AGlobal (AnId id) -> returnM (id, impLevel)
+ AGlobal (AnId id) -> returnM (id, topIdLvl id)
other -> pprPanic "tcLookupIdLvl" (ppr name)
tcLookupLocalIds :: [Name] -> TcM [TcId]
Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
other -> pprPanic "tcLookupLocalIds" (ppr name)
-getLclEnvElts :: TcM [TcTyThing]
-getLclEnvElts = getLclEnv `thenM` \ env ->
- return (nameEnvElts (tcl_env env))
+lclEnvElts :: TcLclEnv -> [TcTyThing]
+lclEnvElts env = nameEnvElts (tcl_env env)
getInLocalScope :: TcM (Name -> Bool)
-- Ids only
\end{code}
+\begin{code}
+-----------------------
+-- findGlobals looks at the value environment and finds values
+-- whose types mention the offending type variable. It has to be
+-- careful to zonk the Id's type first, so it has to be in the monad.
+-- We must be careful to pass it a zonked type variable, too.
+
+findGlobals :: TcTyVarSet
+ -> TidyEnv
+ -> TcM (TidyEnv, [SDoc])
+
+findGlobals tvs tidy_env
+ = getLclEnv `thenM` \ lcl_env ->
+ go tidy_env [] (lclEnvElts lcl_env)
+ where
+ go tidy_env acc [] = returnM (tidy_env, acc)
+ go tidy_env acc (thing : things)
+ = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
+ case maybe_doc of
+ Just d -> go tidy_env1 (d:acc) things
+ Nothing -> go tidy_env1 acc things
+
+ ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
+
+-----------------------
+find_thing ignore_it tidy_env (ATcId id _)
+ = zonkTcType (idType id) `thenM` \ id_ty ->
+ if ignore_it id_ty then
+ returnM (tidy_env, Nothing)
+ else let
+ (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
+ msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
+ nest 2 (parens (ptext SLIT("bound at") <+>
+ ppr (getSrcLoc id)))]
+ in
+ returnM (tidy_env', Just msg)
+
+find_thing ignore_it tidy_env (ATyVar tv)
+ = zonkTcTyVar tv `thenM` \ tv_ty ->
+ if ignore_it tv_ty then
+ returnM (tidy_env, Nothing)
+ else let
+ (tidy_env1, tv1) = tidyOpenTyVar tidy_env tv
+ (tidy_env2, tidy_ty) = tidyOpenType tidy_env1 tv_ty
+ msg = sep [ppr tv1 <+> eq_stuff, nest 2 bound_at]
+
+ eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, tv == tv' = empty
+ | otherwise = equals <+> ppr tv_ty
+ -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
+
+ bound_at = tyVarBindingInfo tv
+ in
+ returnM (tidy_env2, Just msg)
+\end{code}
+
+
%************************************************************************
%* *
\subsection{The global tyvars}
%* *
%************************************************************************
+The TcGblEnv holds a mutable variable containing the current full, instance environment.
+The ExtendInstEnv functions extend this environment by side effect, in case we are
+sucking in new instance declarations deep in the body of a TH splice, which are needed
+in another TH splice. The tcg_insts field of the TcGblEnv contains just the dfuns
+from this module
+
\begin{code}
tcGetInstEnv :: TcM InstEnv
tcGetInstEnv = getGblEnv `thenM` \ env ->
- returnM (tcg_inst_env env)
+ readMutVar (tcg_inst_env env)
tcSetInstEnv :: InstEnv -> TcM a -> TcM a
+-- Horribly imperative;
+-- but used only when temporarily enhancing the instance
+-- envt during 'deriving' context inference
tcSetInstEnv ie thing_inside
= getGblEnv `thenM` \ env ->
- setGblEnv (env {tcg_inst_env = ie}) thing_inside
+ let
+ ie_var = tcg_inst_env env
+ in
+ readMutVar ie_var `thenM` \ old_ie ->
+ writeMutVar ie_var ie `thenM_`
+ thing_inside `thenM` \ result ->
+ writeMutVar ie_var old_ie `thenM_`
+ returnM result
tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a
-- Add instances from local or imported
= do { dflags <- getDOpts
; eps <- getEps
; env <- getGblEnv
+ ; let ie_var = tcg_inst_env env
+ ; inst_env <- readMutVar ie_var
; let
-- Extend the total inst-env with the new dfuns
- (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
+ (inst_env', errs) = extendInstEnv dflags inst_env dfuns
-- Sort the ones from this module from the others
(lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns
(eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns
eps' = eps { eps_inst_env = eps_inst_env' }
- env' = env { tcg_inst_env = inst_env',
- tcg_insts = lcl_dfuns ++ tcg_insts env }
+ env' = env { tcg_insts = lcl_dfuns ++ tcg_insts env }
; traceDFuns dfuns
; addErrs errs
+ ; writeMutVar ie_var inst_env'
; setEps eps'
; setGblEnv env' thing_inside }
tcExtendLocalInstEnv infos thing_inside
= do { dflags <- getDOpts
; env <- getGblEnv
+ ; let ie_var = tcg_inst_env env
+ ; inst_env <- readMutVar ie_var
; let
dfuns = map iDFunId infos
- (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
- env' = env { tcg_inst_env = inst_env',
- tcg_insts = dfuns ++ tcg_insts env }
+ (inst_env', errs) = extendInstEnv dflags inst_env dfuns
+ env' = env { tcg_insts = dfuns ++ tcg_insts env }
; traceDFuns dfuns
; addErrs errs
+ ; writeMutVar ie_var inst_env'
; setGblEnv env' thing_inside }
traceDFuns dfuns
data InstInfo
= InstInfo {
iDFunId :: DFunId, -- The dfun id
- iBinds :: RenamedMonoBinds, -- Bindings, b
- iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
+ iBinds :: InstBindings
}
- | NewTypeDerived { -- Used for deriving instances of newtypes, where the
- -- witness dictionary is identical to the argument dictionary
- -- Hence no bindings.
- iDFunId :: DFunId -- The dfun id
- }
+data InstBindings
+ = VanillaInst -- The normal case
+ RenamedMonoBinds -- Bindings
+ [RenamedSig] -- User pragmas recorded for generating
+ -- specialised instances
+
+ | NewTypeDerived -- Used for deriving instances of newtypes, where the
+ [Type] -- witness dictionary is identical to the argument
+ -- dictionary. Hence no bindings, no pragmas
+ -- The [Type] are the representation types
+ -- See notes in TcDeriv
pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
-pprInstInfoDetails (InstInfo { iBinds = b }) = ppr b
-pprInstInfoDetails (NewTypeDerived _) = text "Derived from the represenation type"
+
+pprInstInfoDetails (InstInfo { iBinds = VanillaInst b _ }) = ppr b
+pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the representation type"
simpleInstInfoTy :: InstInfo -> Type
simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
projects / ghc-hetmet.git / blobdiff