module GHC.Tc.Utils.Env(
TyThing(..), TcTyThing(..), TcId,
InstInfo(..), iDFunId, pprInstInfoDetails,
simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
InstBindings(..),
tcExtendGlobalEnv, tcExtendTyConEnv,
tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
tcExtendGlobalValEnv,
tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
tcLookupTyCon, tcLookupClass,
tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupAxiom,
lookupGlobal, ioLookupDataCon,
addTypecheckedBinds,
tcExtendKindEnv, tcExtendKindEnvList,
tcExtendTyVarEnv, tcExtendNameTyVarEnv,
tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcExtendBinderStack, tcExtendLocalTypeEnv,
isTypeClosedLetBndr,
tcCheckUsage,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
tcLookupTcTyCon,
tcLookupLcl_maybe,
getInLocalScope,
wrongThingErr, pprBinders,
tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
getTypeSigNames,
tcExtendRecEnv,
tcInitTidyEnv, tcInitOpenTidyEnv,
tcLookupInstance, tcGetInstEnvs,
tcExtendRules,
tcGetDefaultTys,
checkWellStaged, tcMetaTy, thLevel,
topIdLvl, isBrackStage,
newDFunName, newFamInstTyConName,
newFamInstAxiomName,
mkStableIdFromString, mkStableIdFromName,
mkWrapperName
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Hs
import GHC.Iface.Env
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Core.UsageEnv
import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper)
import GHC.Tc.Utils.Unify ( tcSubMult )
import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) )
import GHC.Iface.Load
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Types.Id
import GHC.Types.Var
import GHC.Types.Name.Reader
import GHC.Core.InstEnv
import GHC.Core.DataCon ( DataCon )
import GHC.Core.PatSyn ( PatSyn )
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion.Axiom
import GHC.Core.Class
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.Var.Env
import GHC.Driver.Types
import GHC.Driver.Session
import GHC.Types.SrcLoc
import GHC.Types.Basic hiding( SuccessFlag(..) )
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Utils.Encoding
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Data.List.SetOps
import GHC.Utils.Error
import GHC.Data.Maybe( MaybeErr(..), orElse )
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.Misc ( HasDebugCallStack )
import Data.IORef
import Data.List (intercalate)
import Control.Monad
lookupGlobal :: HscEnv -> Name -> IO TyThing
lookupGlobal hsc_env name
= do {
mb_thing <- lookupGlobal_maybe hsc_env name
; case mb_thing of
Succeeded thing -> return thing
Failed msg -> pprPanic "lookupGlobal" msg
}
lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
lookupGlobal_maybe hsc_env name
= do {
let mod = icInteractiveModule (hsc_IC hsc_env)
dflags = hsc_dflags hsc_env
tcg_semantic_mod = canonicalizeModuleIfHome dflags mod
; if nameIsLocalOrFrom tcg_semantic_mod name
then (return
(Failed (text "Can't find local name: " <+> ppr name)))
else
lookupImported_maybe hsc_env name
}
lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
lookupImported_maybe hsc_env name
= do { mb_thing <- lookupTypeHscEnv hsc_env name
; case mb_thing of
Just thing -> return (Succeeded thing)
Nothing -> importDecl_maybe hsc_env name
}
importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
importDecl_maybe hsc_env name
| Just thing <- wiredInNameTyThing_maybe name
= do { when (needWiredInHomeIface thing)
(initIfaceLoad hsc_env (loadWiredInHomeIface name))
; return (Succeeded thing) }
| otherwise
= initIfaceLoad hsc_env (importDecl name)
ioLookupDataCon :: HscEnv -> Name -> IO DataCon
ioLookupDataCon hsc_env name = do
mb_thing <- ioLookupDataCon_maybe hsc_env name
case mb_thing of
Succeeded thing -> return thing
Failed msg -> pprPanic "lookupDataConIO" msg
ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)
ioLookupDataCon_maybe hsc_env name = do
thing <- lookupGlobal hsc_env name
return $ case thing of
AConLike (RealDataCon con) -> Succeeded con
_ -> Failed $
pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
text "used as a data constructor"
addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
addTypecheckedBinds tcg_env binds
| isHsBootOrSig (tcg_src tcg_env) = tcg_env
| otherwise = tcg_env { tcg_binds = foldr unionBags
(tcg_binds tcg_env)
binds }
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 ->
if nameIsLocalOrFrom (tcg_semantic_mod env) name
then notFound name
else
do { mb_thing <- tcLookupImported_maybe name
; case mb_thing of
Succeeded thing -> return thing
Failed msg -> failWithTc msg
}}}
tcLookupGlobalOnly :: Name -> TcM TyThing
tcLookupGlobalOnly name
= do { env <- getGblEnv
; return $ case lookupNameEnv (tcg_type_env env) name of
Just thing -> thing
Nothing -> pprPanic "tcLookupGlobalOnly" (ppr name) }
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon name = do
thing <- tcLookupGlobal name
case thing of
AConLike (RealDataCon con) -> return con
_ -> wrongThingErr "data constructor" (AGlobal thing) name
tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn name = do
thing <- tcLookupGlobal name
case thing of
AConLike (PatSynCon ps) -> return ps
_ -> wrongThingErr "pattern synonym" (AGlobal thing) name
tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike name = do
thing <- tcLookupGlobal name
case thing of
AConLike cl -> return cl
_ -> wrongThingErr "constructor-like thing" (AGlobal thing) name
tcLookupClass :: Name -> TcM Class
tcLookupClass name = do
thing <- tcLookupGlobal name
case thing of
ATyCon tc | Just cls <- tyConClass_maybe tc -> 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
tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom name = do
thing <- tcLookupGlobal name
case thing of
ACoAxiom ax -> return ax
_ -> wrongThingErr "axiom" (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
tcLookupInstance :: Class -> [Type] -> TcM ClsInst
tcLookupInstance cls tys
= do { instEnv <- tcGetInstEnvs
; case lookupUniqueInstEnv instEnv cls tys of
Left err -> failWithTc $ text "Couldn't match instance:" <+> err
Right (inst, tys)
| uniqueTyVars tys -> return inst
| otherwise -> failWithTc errNotExact
}
where
errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
uniqueTyVars tys = all isTyVarTy tys
&& hasNoDups (map (getTyVar "tcLookupInstance") tys)
tcGetInstEnvs :: TcM InstEnvs
tcGetInstEnvs = do { eps <- getEps
; env <- getGblEnv
; return (InstEnvs { ie_global = eps_inst_env eps
, ie_local = tcg_inst_env env
, ie_visible = tcVisibleOrphanMods env }) }
instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
lookupThing = tcLookupGlobal
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 }) }
tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit 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 }
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv things thing_inside
= do { env <- getGblEnv
; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
; setGblEnv env' $
tcExtendGlobalEnvImplicit things thing_inside
}
tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv tycons thing_inside
= do { env <- getGblEnv
; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
; setGblEnv env' $
tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
}
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv ids thing_inside
= tcExtendGlobalEnvImplicit [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' = tcg_env { tcg_type_env = ge' }
; setGblEnv tcg_env' thing_inside }
tcLookupLocated :: Located Name -> TcM TcTyThing
tcLookupLocated = addLocM tcLookup
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe name
= do { local_env <- getLclTypeEnv
; return (lookupNameEnv local_env name) }
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 _ tv -> return tv
_ -> pprPanic "tcLookupTyVar" (ppr name) }
tcLookupId :: Name -> TcM Id
tcLookupId name = do
thing <- tcLookupIdMaybe name
case thing of
Just id -> return id
_ -> pprPanic "tcLookupId" (ppr name)
tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe name
= do { thing <- tcLookup name
; case thing of
ATcId { tct_id = id} -> return $ Just id
AGlobal (AnId id) -> return $ Just id
_ -> return Nothing }
tcLookupLocalIds :: [Name] -> TcM [TcId]
tcLookupLocalIds ns
= do { env <- getLclEnv
; return (map (lookup (tcl_env env)) ns) }
where
lookup lenv name
= case lookupNameEnv lenv name of
Just (ATcId { tct_id = id }) -> id
_ -> pprPanic "tcLookupLocalIds" (ppr name)
tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon
tcLookupTcTyCon name = do
thing <- tcLookup name
case thing of
ATcTyCon tc -> return tc
_ -> pprPanic "tcLookupTcTyCon" (ppr name)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do { lcl_env <- getLclTypeEnv
; return (`elemNameEnv` lcl_env) }
tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList things thing_inside
= do { traceTc "tcExtendKindEnvList" (ppr things)
; updLclEnv upd_env thing_inside }
where
upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
tcExtendKindEnv extra_env thing_inside
= do { traceTc "tcExtendKindEnv" (ppr extra_env)
; updLclEnv upd_env thing_inside }
where
upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
= tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside
tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv binds thing_inside
= do { tc_extend_local_env NotTopLevel
[(name, ATyVar name tv) | (name, tv) <- binds] $
tcExtendBinderStack tv_binds $
thing_inside }
where
tv_binds :: [TcBinder]
tv_binds = [TcTvBndr name tv | (name,tv) <- binds]
isTypeClosedLetBndr :: Id -> Bool
isTypeClosedLetBndr = noFreeVarsOfType . idType
tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
tcExtendRecIds pairs thing_inside
= tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = let_id
, tct_info = NonClosedLet emptyNameSet False })
| (name, let_id) <- pairs ] $
thing_inside
tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
tcExtendSigIds top_lvl sig_ids thing_inside
= tc_extend_local_env top_lvl
[ (idName id, ATcId { tct_id = id
, tct_info = info })
| id <- sig_ids
, let closed = isTypeClosedLetBndr id
info = NonClosedLet emptyNameSet closed ]
thing_inside
tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
-> [TcId] -> TcM a -> TcM a
tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
ids thing_inside
= tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $
tc_extend_local_env top_lvl
[ (idName id, ATcId { tct_id = id
, tct_info = mk_tct_info id })
| id <- ids ]
thing_inside
where
mk_tct_info id
| type_closed && isEmptyNameSet rhs_fvs = ClosedLet
| otherwise = NonClosedLet rhs_fvs type_closed
where
name = idName id
rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet
type_closed = isTypeClosedLetBndr id &&
(fv_type_closed || hasCompleteSig sig_fn name)
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
= tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
| (_,mono_id) <- names_w_ids ] $
tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = id
, tct_info = NotLetBound })
| (name,id) <- names_w_ids]
thing_inside
tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env top_lvl extra_env thing_inside
= do { traceTc "tc_extend_local_env" (ppr extra_env)
; stage <- getStage
; env0@(TcLclEnv { tcl_rdr = rdr_env
, tcl_th_bndrs = th_bndrs
, tcl_env = lcl_type_env }) <- getLclEnv
; let thlvl = (top_lvl, thLevel stage)
env1 = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env
[ n | (n, _) <- extra_env, isInternalName n ]
, tcl_th_bndrs = extendNameEnvList th_bndrs
[(n, thlvl) | (n, ATcId {}) <- extra_env]
, tcl_env = extendNameEnvList lcl_type_env extra_env }
; setLclEnv env1 thing_inside }
tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
= lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things }
tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper)
tcCheckUsage name id_mult thing_inside
= do { (local_usage, result) <- tcCollectingUsage thing_inside
; wrapper <- check_then_add_usage local_usage
; return (result, wrapper) }
where
check_then_add_usage :: UsageEnv -> TcM HsWrapper
check_then_add_usage uenv
= do { let actual_u = lookupUE uenv name
; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u)
; wrapper <- case actual_u of
Bottom -> return idHsWrapper
Zero -> tcSubMult (UsageEnvironmentOf name) Many id_mult
MUsage m -> tcSubMult (UsageEnvironmentOf name) m id_mult
; tcEmitBindingUsage (deleteUE uenv name)
; return wrapper }
tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack bndrs thing_inside
= do { traceTc "tcExtendBinderStack" (ppr bndrs)
; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
thing_inside }
tcInitTidyEnv :: TcM TidyEnv
tcInitTidyEnv
= do { lcl_env <- getLclEnv
; go emptyTidyEnv (tcl_bndrs lcl_env) }
where
go (env, subst) []
= return (env, subst)
go (env, subst) (b : bs)
| TcTvBndr name tyvar <- b
= do { let (env', occ') = tidyOccName env (nameOccName name)
name' = tidyNameOcc name occ'
tyvar1 = setTyVarName tyvar name'
; tyvar2 <- zonkTcTyVarToTyVar tyvar1
; go (env', extendVarEnv subst tyvar tyvar2) bs }
| otherwise
= go (env, subst) bs
tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
tcInitOpenTidyEnv tvs
= do { env1 <- tcInitTidyEnv
; let env2 = tidyFreeTyCoVars env1 tvs
; return env2 }
tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
tcAddDataFamConPlaceholders inst_decls thing_inside
= tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)
| lid <- inst_decls, con <- get_cons lid ]
thing_inside
where
get_cons :: LInstDecl GhcRn -> [Name]
get_cons (L _ (TyFamInstD {})) = []
get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
= concatMap (get_fi_cons . unLoc) fids
get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
= map unLoc $ concatMap (getConNames . unLoc) cons
tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
tcAddPatSynPlaceholders pat_syns thing_inside
= tcExtendKindEnvList [ (name, APromotionErr PatSynPE)
| PSB{ psb_id = L _ name } <- pat_syns ]
thing_inside
getTypeSigNames :: [LSig GhcRn] -> NameSet
getTypeSigNames sigs
= foldr get_type_sig emptyNameSet sigs
where
get_type_sig :: LSig GhcRn -> NameSet -> NameSet
get_type_sig sig ns =
case sig of
L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names)
L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names)
_ -> ns
tcExtendRules :: [LRuleDecl GhcTc] -> 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 }
checkWellStaged :: SDoc
-> ThLevel
-> ThLevel
-> TcM ()
checkWellStaged pp_thing bind_lvl use_lvl
| use_lvl >= bind_lvl
= return ()
| bind_lvl == outerLevel
= stageRestrictionError pp_thing
| otherwise
= failWithTc $
text "Stage error:" <+> pp_thing <+>
hsep [text "is bound at stage" <+> ppr bind_lvl,
text "but used at stage" <+> ppr use_lvl]
stageRestrictionError :: SDoc -> TcM a
stageRestrictionError pp_thing
= failWithTc $
sep [ text "GHC stage restriction:"
, nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
, text "and must be imported, not defined locally"])]
topIdLvl :: Id -> ThLevel
topIdLvl id | isLocalId id = outerLevel
| otherwise = impLevel
tcMetaTy :: Name -> TcM Type
tcMetaTy tc_name = do
t <- tcLookupTyCon tc_name
return (mkTyConTy t)
isBrackStage :: ThStage -> Bool
isBrackStage (Brack {}) = True
isBrackStage _other = False
tcGetDefaultTys :: TcM ([Type],
(Bool,
Bool))
tcGetDefaultTys
= do { dflags <- getDynFlags
; let ovl_strings = xopt LangExt.OverloadedStrings dflags
extended_defaults = xopt LangExt.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
; list_ty <- tcMetaTy listTyConName
; checkWiredInTyCon doubleTyCon
; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
++ [integer_ty, doubleTy]
++ opt_deflt ovl_strings [stringTy]
; return (deflt_tys, flags) } } }
where
opt_deflt True xs = xs
opt_deflt False _ = []
data InstInfo a
= InstInfo
{ iSpec :: ClsInst
, iBinds :: InstBindings a
}
iDFunId :: InstInfo a -> DFunId
iDFunId info = instanceDFunId (iSpec info)
data InstBindings a
= InstBindings
{ ib_tyvars :: [Name]
, ib_binds :: LHsBinds a
, ib_pragmas :: [LSig a]
, ib_extensions :: [LangExt.Extension]
, ib_derived :: Bool
}
instance (OutputableBndrId a)
=> Outputable (InstInfo (GhcPass a)) where
ppr = pprInstInfoDetails
pprInstInfoDetails :: (OutputableBndrId a)
=> InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails info
= hang (pprInstanceHdr (iSpec info) <+> text "where")
2 (details (iBinds info))
where
details (InstBindings { ib_pragmas = p, ib_binds = b }) =
pprDeclList (pprLHsBindsForUser b p)
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)
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
newDFunName clas tys loc
= do { is_boot <- tcIsHsBootOrSig
; 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 }
newFamInstTyConName :: Located Name -> [Type] -> TcM Name
newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name
newFamInstAxiomName (L loc name) branches
= mk_fam_inst_name mkInstTyCoOcc loc name branches
mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name adaptOcc loc tc_name tyss
= do { mod <- getModule
; let info_string = occNameString (getOccName tc_name) ++
intercalate "|" ty_strings
; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
; newGlobalBinder mod (adaptOcc occ) loc }
where
ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
mkStableIdFromString str sig_ty loc occ_wrapper = do
uniq <- newUnique
mod <- getModule
name <- mkWrapperName "stable" str
let occ = mkVarOccFS name :: OccName
gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
id = mkExportedVanillaId gnm sig_ty :: Id
return id
mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
=> String -> String -> m FastString
mkWrapperName what nameBase
= do dflags <- getDynFlags
thisMod <- getModule
let
wrapperRef = nextWrapperNum dflags
pkg = unitString (moduleUnit thisMod)
mod = moduleNameString (moduleName thisMod)
wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
mod_env' = extendModuleEnv mod_env thisMod (num+1)
in (mod_env', num)
let components = [what, show wrapperNum, pkg, mod, nameBase]
return $ mkFastString $ zEncodeString $ intercalate ":" components
pprBinders :: [Name] -> SDoc
pprBinders [bndr] = quotes (ppr bndr)
pprBinders bndrs = pprWithCommas ppr bndrs
notFound :: Name -> TcM TyThing
notFound name
= do { lcl_env <- getLclEnv
; let stage = tcl_th_ctxt lcl_env
; case stage of
Splice {}
| isUnboundName name -> failM
| otherwise -> stageRestrictionError (quotes (ppr name))
_ -> failWithTc $
vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
text "is not in scope during type checking, but it passed the renamer",
text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
}
wrongThingErr :: String -> TcTyThing -> Name -> TcM a
wrongThingErr expected thing name
= failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
text "used as a" <+> text expected)