%
% (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, tcLookupDataFamInst,
tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendGhciEnv,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
getInLocalScope,
wrongThingErr, pprBinders,
tcExtendRecEnv,
tcExtendRules,
tcGetDefaultTys,
tcGetGlobalTyVars,
checkWellStaged, tcMetaTy, thLevel,
topIdLvl, thTopLevelId, thRnBrack, isBrackStage,
newLocalName, newDFunName, newFamInstTyConName,
mkStableIdFromString, mkStableIdFromName
) where
#include "HsVersions.h"
import HsSyn
import IfaceEnv
import TcRnMonad
import TcMType
import TcType
import TcIface
import PrelNames
import TysWiredIn
import Id
import Coercion
import Var
import VarSet
import RdrName
import InstEnv
import FamInstEnv
import DataCon
import TyCon
import TypeRep
import Class
import Name
import NameEnv
import HscTypes
import DynFlags
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
Just mod | mod == tcg_mod env
-> notFound name
| 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 (isFamilyTyCon tycon)
= return Nothing
| otherwise
= do { env <- getGblEnv
; eps <- getEps
; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ ppr instEnv)
; case lookupFamInstEnv instEnv tycon tys of
[] -> return Nothing
((fam_inst, rep_tys):_)
-> return $ Just (famInstTyCon fam_inst, rep_tys)
}
tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
tcLookupDataFamInst tycon tys
| not (isFamilyTyCon tycon)
= return (tycon, tys)
| otherwise
= ASSERT( isAlgTyCon tycon )
do { maybeFamInst <- tcLookupFamInst tycon tys
; case maybeFamInst of
Nothing -> famInstNotFound tycon tys
Just famInst -> return famInst }
famInstNotFound :: TyCon -> [Type] -> TcM a
famInstNotFound tycon tys
= failWithTc (ptext (sLit "No family instance for")
<+> quotes (pprTypeApp tycon tys))
\end{code}
Note [Looking up family instances for deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tcLookupFamInstExact is an auxiliary lookup wrapper which requires
that looked-up family instances exist. If called with a vanilla
tycon, the old type application is simply returned.
If we have
data instance F () = ... deriving Eq
data instance F () = ... deriving Eq
then tcLookupFamInstExact will be confused by the two matches;
but that can't happen because tcInstDecls1 doesn't call tcDeriving
if there are any overlaps.
There are two other things that might go wrong with the lookup.
First, we might see a standalone deriving clause
deriving Eq (F ())
when there is no data instance F () in scope.
Note that it's OK to have
data instance F [a] = ...
deriving Eq (F [(a,b)])
where the match is not exact; the same holds for ordinary data types
with standalone deriving declrations.
\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 <- getLclTypeEnv
case lookupNameEnv 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)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do { lcl_env <- getLclTypeEnv
; 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] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r
tcExtendKindEnvTvs bndrs thing_inside
= tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs)
(thing_inside 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' <- tcExtendGlobalTyVars 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 "env2" (ppr extra_env)
; gtvs' <- tcExtendGlobalTyVars (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 })
| (name,id) <- names_w_ids]
le' = extendNameEnvList (tcl_env env) extra_env
rdr_env' = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids]
tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
tcExtendGlobalTyVars gtv_var extra_global_tvs
= do { global_tvs <- readMutVar gtv_var
; newMutVar (global_tvs `unionVarSet` extra_global_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}
%************************************************************************
%* *
getDefaultTys
%* *
%************************************************************************
\begin{code}
tcGetDefaultTys :: Bool
-> TcM ([Type],
(Bool,
Bool))
tcGetDefaultTys interactive
= do { dflags <- getDOpts
; let ovl_strings = xopt Opt_OverloadedStrings dflags
extended_defaults = interactive
|| xopt Opt_ExtendedDefaultRules dflags
flags = (ovl_strings, extended_defaults)
; mb_defaults <- getDeclaredDefaultTys
; case mb_defaults of {
Just tys -> return (tys, flags) ;
Nothing -> do
{ integer_ty <- tcMetaTy integerTyConName
; checkWiredInTyCon doubleTyCon
; string_ty <- tcMetaTy stringTyConName
; let deflt_tys = opt_deflt extended_defaults unitTy
++ [integer_ty, doubleTy]
++ opt_deflt ovl_strings string_ty
; return (deflt_tys, flags) } } }
where
opt_deflt True ty = [ty]
opt_deflt False _ = []
\end{code}
Note [Default unitTy]
~~~~~~~~~~~~~~~~~~~~~
In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
try when defaulting. This has very little real impact, except in the following case.
Consider:
Text.Printf.printf "hello"
This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't
want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to
default the 'a' to (), rather than to Integer (which is what would otherwise happen;
and then GHCi doesn't attempt to print the (). So in interactive mode, we add
() to the list of defaulting types. See Trac #1200.
%************************************************************************
%* *
\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 = hang (ptext (sLit "instance"))
2 (sep [ ifPprDebug (pprForAll tvs)
, pprThetaArrow theta, ppr tau
, ptext (sLit "where")])
where
(tvs, theta, tau) = tcSplitSigmaTy (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 top-level 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 top-level 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
top-level 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 -> TcM TyThing
notFound name
= do { (gbl,lcl) <- getEnvs
; 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 gbl),
ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl)]
) }
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}