%
% (c) The University of Glasgow 2006
%
\begin{code}
module TcEnv(
TyThing(..), TcTyThing(..), TcId,
InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
InstBindings(..),
tcExtendGlobalEnv, setGlobalTypeEnv,
tcExtendGlobalValEnv,
tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupFamInst,
tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendGhciEnv,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
lclEnvElts, getInLocalScope, findGlobals,
wrongThingErr, pprBinders,
tcExtendRecEnv,
tcExtendRules,
tcGetGlobalTyVars,
checkWellStaged, tcMetaTy, thLevel,
topIdLvl, thTopLevelId, thRnBrack, isBrackStage,
newLocalName, newDFunName, newFamInstTyConName,
mkStableIdFromString, mkStableIdFromName
) where
#include "HsVersions.h"
import HsSyn
import TcIface
import IfaceEnv
import TcRnMonad
import TcMType
import TcType
import qualified Type
import Id
import Coercion
import Var
import VarSet
import VarEnv
import RdrName
import InstEnv
import FamInstEnv
import DataCon
import TyCon
import TypeRep
import Class
import Name
import NameEnv
import HscTypes
import SrcLoc
import Outputable
import Unique
import FastString
\end{code}
%************************************************************************
%* *
%* tcLookupGlobal *
%* *
%************************************************************************
Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
unless you know that the SrcSpan in the monad is already set to the
span of the Name.
\begin{code}
tcLookupLocatedGlobal :: Located Name -> TcM TyThing
tcLookupLocatedGlobal name
= addLocM tcLookupGlobal name
tcLookupGlobal :: Name -> TcM TyThing
tcLookupGlobal name
= do { env <- getGblEnv
; case lookupNameEnv (tcg_type_env env) name of {
Just thing -> return thing ;
Nothing -> do
{ hsc_env <- getTopEnv
; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
; case mb_thing of {
Just thing -> return thing ;
Nothing -> do
{ case nameModule_maybe name of
Nothing -> notFound name env
Just mod | mod == tcg_mod env
-> notFound name env
| otherwise
-> tcImportDecl name
}}}}}
tcLookupField :: Name -> TcM Id
tcLookupField name
= tcLookupId name
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon name = do
thing <- tcLookupGlobal name
case thing of
ADataCon con -> return con
_ -> wrongThingErr "data constructor" (AGlobal thing) name
tcLookupClass :: Name -> TcM Class
tcLookupClass name = do
thing <- tcLookupGlobal name
case thing of
AClass cls -> return cls
_ -> wrongThingErr "class" (AGlobal thing) name
tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon name = do
thing <- tcLookupGlobal name
case thing of
ATyCon tc -> return tc
_ -> wrongThingErr "type constructor" (AGlobal thing) name
tcLookupLocatedGlobalId :: Located Name -> TcM Id
tcLookupLocatedGlobalId = addLocM tcLookupId
tcLookupLocatedClass :: Located Name -> TcM Class
tcLookupLocatedClass = addLocM tcLookupClass
tcLookupLocatedTyCon :: Located Name -> TcM TyCon
tcLookupLocatedTyCon = addLocM tcLookupTyCon
tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type]))
tcLookupFamInst tycon tys
| not (isOpenTyCon tycon)
= return Nothing
| otherwise
= do { env <- getGblEnv
; eps <- getEps
; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
; case lookupFamInstEnv instEnv tycon tys of
[] -> return Nothing
((fam_inst, rep_tys):_)
-> return $ Just (famInstTyCon fam_inst, rep_tys)
}
\end{code}
\begin{code}
instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
lookupThing = tcLookupGlobal
\end{code}
%************************************************************************
%* *
Extending the global environment
%* *
%************************************************************************
\begin{code}
setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv tcg_env new_type_env
= do {
writeMutVar (tcg_type_env_var tcg_env) new_type_env
; return (tcg_env { tcg_type_env = new_type_env }) }
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv things thing_inside
= do { tcg_env <- getGblEnv
; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things
; tcg_env' <- setGlobalTypeEnv tcg_env ge'
; setGblEnv tcg_env' thing_inside }
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv ids thing_inside
= tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
tcExtendRecEnv gbl_stuff thing_inside
= do { tcg_env <- getGblEnv
; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
; tcg_env' <- setGlobalTypeEnv tcg_env ge'
; setGblEnv tcg_env' thing_inside }
\end{code}
%************************************************************************
%* *
\subsection{The local environment}
%* *
%************************************************************************
\begin{code}
tcLookupLocated :: Located Name -> TcM TcTyThing
tcLookupLocated = addLocM tcLookup
tcLookup :: Name -> TcM TcTyThing
tcLookup name = do
local_env <- getLclEnv
case lookupNameEnv (tcl_env local_env) name of
Just thing -> return thing
Nothing -> AGlobal <$> tcLookupGlobal name
tcLookupTyVar :: Name -> TcM TcTyVar
tcLookupTyVar name = do
thing <- tcLookup name
case thing of
ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
_ -> pprPanic "tcLookupTyVar" (ppr name)
tcLookupId :: Name -> TcM Id
tcLookupId name = do
thing <- tcLookup name
case thing of
ATcId { tct_id = id} -> return id
AGlobal (AnId id) -> return id
_ -> pprPanic "tcLookupId" (ppr name)
tcLookupLocalIds :: [Name] -> TcM [TcId]
tcLookupLocalIds ns = do
env <- getLclEnv
return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
where
lookup lenv lvl name
= case lookupNameEnv lenv name of
Just (ATcId { tct_id = id, tct_level = lvl1 })
-> ASSERT( lvl == lvl1 ) id
_ -> pprPanic "tcLookupLocalIds" (ppr name)
lclEnvElts :: TcLclEnv -> [TcTyThing]
lclEnvElts env = nameEnvElts (tcl_env env)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do
env <- getLclEnv
let lcl_env = tcl_env env
return (`elemNameEnv` lcl_env)
\end{code}
\begin{code}
tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
tcExtendKindEnv things thing_inside
= updLclEnv upd thing_inside
where
upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
tcExtendKindEnvTvs bndrs thing_inside
= updLclEnv upd thing_inside
where
upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
extend env = extendNameEnvList env pairs
pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
= tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
tcExtendTyVarEnv2 binds thing_inside = do
env@(TcLclEnv {tcl_env = le,
tcl_tyvars = gtvs,
tcl_rdr = rdr_env}) <- getLclEnv
let
rdr_env' = extendLocalRdrEnvList rdr_env (map fst binds)
new_tv_set = tcTyVarsOfTypes (map snd binds)
le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
gtvs' <- tc_extend_gtvs gtvs new_tv_set
setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
getScopedTyVarBinds :: TcM [(Name, TcType)]
getScopedTyVarBinds
= do { lcl_env <- getLclEnv
; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
\end{code}
\begin{code}
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
tcExtendIdEnv2 names_w_ids thing_inside
= do { env <- getLclEnv
; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside }
tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
tcExtendGhciEnv ids thing_inside
= do { env <- getLclEnv
; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside }
tc_extend_local_id_env
:: TcLclEnv
-> ThLevel
-> [(Name,TcId)]
-> TcM a -> TcM a
tc_extend_local_id_env env th_lvl names_w_ids thing_inside
= do { traceTc (text "env2")
; traceTc (text "env3" <+> ppr extra_env)
; gtvs' <- tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars
; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}
; setLclEnv env' thing_inside }
where
extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
extra_env = [ (name, ATcId { tct_id = id,
tct_level = th_lvl,
tct_type = id_ty,
tct_co = case isRefineableTy id_ty of
(True,_) -> Unrefineable
(_,True) -> Rigid idHsWrapper
_ -> Wobbly})
| (name,id) <- names_w_ids, let id_ty = idType id]
le' = extendNameEnvList (tcl_env env) extra_env
rdr_env' = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids]
\end{code}
\begin{code}
findGlobals :: TcTyVarSet
-> TidyEnv
-> TcM (TidyEnv, [SDoc])
findGlobals tvs tidy_env = do
lcl_env <- getLclEnv
go tidy_env [] (lclEnvElts lcl_env)
where
go tidy_env acc [] = return (tidy_env, acc)
go tidy_env acc (thing : things) = do
(tidy_env1, maybe_doc) <- find_thing ignore_it tidy_env thing
case maybe_doc of
Just d -> go tidy_env1 (d:acc) things
Nothing -> go tidy_env1 acc things
ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
find_thing :: (TcType -> Bool) -> TidyEnv -> TcTyThing
-> TcM (TidyEnv, Maybe SDoc)
find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do
id_ty <- zonkTcType (idType id)
if ignore_it id_ty then
return (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
return (tidy_env', Just msg)
find_thing ignore_it tidy_env (ATyVar tv ty) = do
tv_ty <- zonkTcType ty
if ignore_it tv_ty then
return (tidy_env, Nothing)
else let
(tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
msg = sep [ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
getOccName tv == getOccName tv' = empty
| otherwise = equals <+> ppr tidy_ty
bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
in
return (tidy_env1, Just msg)
find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
\end{code}
%************************************************************************
%* *
\subsection{The global tyvars}
%* *
%************************************************************************
\begin{code}
tc_extend_gtvs :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
tc_extend_gtvs gtvs extra_global_tvs = do
global_tvs <- readMutVar gtvs
newMutVar (global_tvs `unionVarSet` extra_global_tvs)
\end{code}
@tcGetGlobalTyVars@ returns a fullyzonked set of tyvars free in the environment.
To improve subsequent calls to the same function it writes the zonked set back into
the environment.
\begin{code}
tcGetGlobalTyVars :: TcM TcTyVarSet
tcGetGlobalTyVars = do
(TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
gbl_tvs <- readMutVar gtv_var
gbl_tvs' <- zonkTcTyVarsAndFV (varSetElems gbl_tvs)
writeMutVar gtv_var gbl_tvs'
return gbl_tvs'
\end{code}
%************************************************************************
%* *
\subsection{Rules}
%* *
%************************************************************************
\begin{code}
tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
tcExtendRules lcl_rules thing_inside
= do { env <- getGblEnv
; let
env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
; setGblEnv env' thing_inside }
\end{code}
%************************************************************************
%* *
Meta level
%* *
%************************************************************************
\begin{code}
checkWellStaged :: SDoc
-> ThLevel
-> ThLevel
-> TcM ()
checkWellStaged pp_thing bind_lvl use_lvl
| use_lvl >= bind_lvl
= return ()
| bind_lvl == outerLevel
= failWithTc $
sep [ptext (sLit "GHC stage restriction:") <+> pp_thing,
nest 2 (vcat [ ptext (sLit "is used in a top-level splice or annotation,")
, ptext (sLit "and must be imported, not defined locally")])]
| otherwise
= 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]
topIdLvl :: Id -> ThLevel
topIdLvl id | isLocalId id = outerLevel
| otherwise = impLevel
tcMetaTy :: Name -> TcM Type
tcMetaTy tc_name = do
t <- tcLookupTyCon tc_name
return (mkTyConApp t [])
thRnBrack :: ThStage
thRnBrack = Brack (panic "thRnBrack1") (panic "thRnBrack2") (panic "thRnBrack3")
isBrackStage :: ThStage -> Bool
isBrackStage (Brack {}) = True
isBrackStage _other = False
thTopLevelId :: Id -> Bool
thTopLevelId id = isGlobalId id || isExternalName (idName id)
\end{code}
%************************************************************************
%* *
\subsection{The InstInfo type}
%* *
%************************************************************************
The InstInfo type summarises the information in an instance declaration
instance c => k (t tvs) where b
It is used just for *local* instance decls (not ones from interface files).
But local instance decls includes
derived ones
generic ones
as well as explicit user written ones.
\begin{code}
data InstInfo a
= InstInfo {
iSpec :: Instance,
iBinds :: InstBindings a
}
iDFunId :: InstInfo a -> DFunId
iDFunId info = instanceDFunId (iSpec info)
data InstBindings a
= VanillaInst
(LHsBinds a)
[LSig a]
Bool
| NewTypeDerived
CoercionI
TyCon
pprInstInfo :: InstInfo a -> SDoc
pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))]
pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
where
details (VanillaInst b _ _) = pprLHsBinds b
details (NewTypeDerived {}) = text "Derived from the representation type"
simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
(_, _, cls, [ty]) -> (cls, ty)
_ -> panic "simpleInstInfoClsTy"
simpleInstInfoTy :: InstInfo a -> Type
simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
simpleInstInfoTyCon :: InstInfo a -> TyCon
simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
\end{code}
Make a name for the dict fun for an instance decl. It's an *external*
name, like otber toplevel names, and hence must be made with newGlobalBinder.
\begin{code}
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
newDFunName clas tys loc
= do { is_boot <- tcIsHsBoot
; mod <- getModule
; let info_string = occNameString (getOccName clas) ++
concatMap (occNameString.getDFunTyKey) tys
; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
; newGlobalBinder mod dfun_occ loc }
\end{code}
Make a name for the representation tycon of a family instance. It's an
*external* name, like otber toplevel names, and hence must be made with
newGlobalBinder.
\begin{code}
newFamInstTyConName :: Name -> [Type] -> SrcSpan -> TcM Name
newFamInstTyConName tc_name tys loc
= do { mod <- getModule
; let info_string = occNameString (getOccName tc_name) ++
concatMap (occNameString.getDFunTyKey) tys
; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
; newGlobalBinder mod occ loc }
\end{code}
Stable names used for foreign exports and annotations.
For stable names, the name must be unique (see #1533). If the
same thing has several stable Ids based on it, the
toplevel bindings generated must not have the same name.
Hence we create an External name (doesn't change), and we
append a Unique to the string right here.
\begin{code}
mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
mkStableIdFromString str sig_ty loc occ_wrapper = do
uniq <- newUnique
mod <- getModule
let uniq_str = showSDoc (pprUnique uniq) :: String
occ = mkVarOcc (str ++ '_' : uniq_str) :: OccName
gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
id = mkExportedLocalId gnm sig_ty :: Id
return id
mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
\end{code}
%************************************************************************
%* *
\subsection{Errors}
%* *
%************************************************************************
\begin{code}
pprBinders :: [Name] -> SDoc
pprBinders [bndr] = quotes (ppr bndr)
pprBinders bndrs = pprWithCommas ppr bndrs
notFound :: Name -> TcGblEnv -> TcM TyThing
notFound name env
= failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+>
ptext (sLit "is not in scope during type checking, but it passed the renamer"),
ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env env)]
)
wrongThingErr :: String -> TcTyThing -> Name -> TcM a
wrongThingErr expected thing name
= failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
ptext (sLit "used as a") <+> text expected)
\end{code}