module TcIface (
tcLookupImported_maybe,
importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceVectInfo, tcIfaceAnnotations,
tcIfaceExpr,
tcIfaceGlobal
) where
#include "HsVersions.h"
import TcTypeNats(typeNatCoAxiomRules)
import IfaceSyn
import LoadIface
import IfaceEnv
import BuildTyCl
import TcRnMonad
import TcType
import Type
import Coercion hiding (substTy)
import TypeRep
import HscTypes
import Annotations
import InstEnv
import FamInstEnv
import CoreSyn
import CoreUtils
import CoreUnfold
import CoreLint
import MkCore
import Id
import MkId
import IdInfo
import Class
import TyCon
import CoAxiom
import ConLike
import DataCon
import PrelNames
import TysWiredIn
import TysPrim ( superKindTyConName )
import BasicTypes ( strongLoopBreaker )
import Literal
import qualified Var
import VarEnv
import VarSet
import Name
import NameEnv
import NameSet
import OccurAnal ( occurAnalyseExpr )
import Demand
import Module
import UniqFM
import UniqSupply
import Outputable
import Maybes
import SrcLoc
import DynFlags
import Util
import FastString
import Control.Monad
import qualified Data.Map as Map
#if __GLASGOW_HASKELL__ < 709
import Data.Traversable ( traverse )
#endif
typecheckIface :: ModIface
-> TcRnIf gbl lcl ModDetails
typecheckIface iface
= initIfaceTc iface $ \ tc_env_var -> do
{
ignore_prags <- goptM Opt_IgnoreInterfacePragmas
; names_w_things <- loadDecls ignore_prags (mi_decls iface)
; let type_env = mkNameEnv names_w_things
; writeMutVar tc_env_var type_env
; insts <- mapM tcIfaceInst (mi_insts iface)
; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules iface)
; anns <- tcIfaceAnnotations (mi_anns iface)
; vect_info <- tcIfaceVectInfo (mi_module iface) type_env (mi_vect_info iface)
; exports <- ifaceExportNames (mi_exports iface)
; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
text "Type envt:" <+> ppr type_env])
; return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_vect_info = vect_info
, md_exports = exports
}
}
tcHiBootIface :: HscSource -> Module -> TcRn ModDetails
tcHiBootIface hsc_src mod
| HsBootFile <- hsc_src
= return emptyModDetails
| otherwise
= do { traceIf (text "loadHiBootInterface" <+> ppr mod)
; mode <- getGhcMode
; if not (isOneShot mode)
then do { hpt <- getHpt
; case lookupUFM hpt (moduleName mod) of
Just info | mi_boot (hm_iface info)
-> return (hm_details info)
_ -> return emptyModDetails }
else do
{ read_result <- findAndReadIface
need mod
True
; case read_result of {
Succeeded (iface, _path) -> typecheckIface iface ;
Failed err ->
do { eps <- getEps
; case lookupUFM (eps_is_boot eps) (moduleName mod) of
Nothing -> return emptyModDetails
Just (_, False) -> failWithTc moduleLoop
Just (_mod, True) -> failWithTc (elaborate err)
}}}}
where
need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod
<+> ptext (sLit "to compare against the Real Thing")
moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod)
<+> ptext (sLit "depends on itself")
elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+>
quotes (ppr mod) <> colon) 4 err
tcIfaceDecl :: Bool
-> IfaceDecl
-> IfL TyThing
tcIfaceDecl = tc_iface_decl NoParentTyCon
tc_iface_decl :: TyConParent
-> Bool
-> IfaceDecl
-> IfL TyThing
tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
ifIdDetails = details, ifIdInfo = info})
= do { name <- lookupIfaceTop occ_name
; ty <- tcIfaceType iface_type
; details <- tcIdDetails ty details
; info <- tcIdInfo ignore_prags name ty info
; return (AnId (mkGlobalId details name ty info)) }
tc_iface_decl parent _ (IfaceData {ifName = occ_name,
ifCType = cType,
ifTyVars = tv_bndrs,
ifRoles = roles,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec, ifPromotable = is_prom,
ifParent = mb_parent })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; tycon <- fixM $ \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
; parent' <- tc_parent mb_parent
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta
cons is_rec is_prom gadt_syn parent') }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
where
tc_parent :: IfaceTyConParent -> IfL TyConParent
tc_parent IfNoParent = return parent
tc_parent (IfDataInstance ax_name _ arg_tys)
= ASSERT( isNoParent parent )
do { ax <- tcIfaceCoAxiom ax_name
; let fam_tc = coAxiomTyCon ax
ax_unbr = toUnbranchedAxiom ax
; lhs_tys <- tcIfaceTcArgs arg_tys
; return (FamInstTyCon ax_unbr fam_tc lhs_tys) }
tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs,
ifRoles = roles,
ifSynRhs = rhs_ty,
ifSynKind = kind })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; rhs_kind <- tcIfaceKind kind
; rhs <- forkM (mk_doc tc_name) $
tcIfaceType rhs_ty
; tycon <- buildSynonymTyCon tc_name tyvars roles rhs rhs_kind
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type synonym") <+> ppr n
tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
ifFamFlav = fam_flav,
ifFamKind = kind })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; rhs_kind <- tcIfaceKind kind
; rhs <- forkM (mk_doc tc_name) $
tc_fam_flav fam_flav
; tycon <- buildFamilyTyCon tc_name tyvars rhs rhs_kind parent
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type synonym") <+> ppr n
tc_fam_flav IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon
tc_fam_flav (IfaceClosedSynFamilyTyCon ax_name _)
= do { ax <- tcIfaceCoAxiom ax_name
; return (ClosedSynFamilyTyCon ax) }
tc_fam_flav IfaceAbstractClosedSynFamilyTyCon
= return AbstractClosedSynFamilyTyCon
tc_fam_flav IfaceBuiltInSynFamTyCon
= pprPanic "tc_iface_decl"
(text "IfaceBuiltInSynFamTyCon in interface file")
tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifMinDef = mindef_occ, ifRec = tc_isrec })
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop tc_occ
; traceIf (text "tc-iface-class1" <+> ppr tc_occ)
; ctxt <- mapM tc_sc rdr_ctxt
; traceIf (text "tc-iface-class2" <+> ppr tc_occ)
; sigs <- mapM tc_sig rdr_sigs
; fds <- mapM tc_fd rdr_fds
; traceIf (text "tc-iface-class3" <+> ppr tc_occ)
; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
; buildClass tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec }
; return (ATyCon (classTyCon cls)) }
where
tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
tc_sig (IfaceClassOp occ dm rdr_ty)
= do { op_name <- lookupIfaceTop occ
; op_ty <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty)
; return (op_name, dm, op_ty) }
tc_at cls (IfaceAT tc_decl if_def)
= do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
mb_def <- case if_def of
Nothing -> return Nothing
Just def -> forkM (mk_at_doc tc) $
extendIfaceTyVarEnv (tyConTyVars tc) $
do { tc_def <- tcIfaceType def
; return (Just tc_def) }
return (ATI tc mb_def)
mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred
mk_at_doc tc = ptext (sLit "Associated type") <+> ppr tc
mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
, ifAxBranches = branches, ifRole = role })
= do { tc_name <- lookupIfaceTop ax_occ
; tc_tycon <- tcIfaceTyCon tc
; tc_branches <- tc_ax_branches branches
; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
, co_ax_name = tc_name
, co_ax_tc = tc_tycon
, co_ax_role = role
, co_ax_branches = toBranchList tc_branches
, co_ax_implicit = False }
; return (ACoAxiom axiom) }
tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
, ifPatMatcher = if_matcher
, ifPatBuilder = if_builder
, ifPatIsInfix = is_infix
, ifPatUnivTvs = univ_tvs
, ifPatExTvs = ex_tvs
, ifPatProvCtxt = prov_ctxt
, ifPatReqCtxt = req_ctxt
, ifPatArgs = args
, ifPatTy = pat_ty })
= do { name <- lookupIfaceTop occ_name
; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
; matcher <- tc_pr if_matcher
; builder <- fmapMaybeM tc_pr if_builder
; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
{ bindIfaceTyVars ex_tvs $ \ex_tvs -> do
{ patsyn <- forkM (mk_doc name) $
do { prov_theta <- tcIfaceCtxt prov_ctxt
; req_theta <- tcIfaceCtxt req_ctxt
; pat_ty <- tcIfaceType pat_ty
; arg_tys <- mapM tcIfaceType args
; return $ buildPatSyn name is_infix matcher builder
(univ_tvs, req_theta) (ex_tvs, prov_theta)
arg_tys pat_ty }
; return $ AConLike . PatSynCon $ patsyn }}}
where
mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
; return (id, b) }
tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branch prev_branches
(IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs
, ifaxbRoles = roles, ifaxbIncomps = incomps })
= bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do
{ tc_lhs <- tcIfaceTcArgs lhs
; tc_rhs <- tcIfaceType rhs
; let br = CoAxBranch { cab_loc = noSrcSpan
, cab_tvs = tvs
, cab_lhs = tc_lhs
, cab_roles = roles
, cab_rhs = tc_rhs
, cab_incomps = map (prev_branches !!) incomps }
; return (prev_branches ++ [br]) }
tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
= case if_cons of
IfAbstractTyCon dis -> return (AbstractTyCon dis)
IfDataFamTyCon -> return DataFamilyTyCon
IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
; mkNewTyConRhs tycon_name tycon data_con }
where
tc_con_decl (IfCon { ifConInfix = is_infix,
ifConExTvs = ex_tvs,
ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = field_lbls,
ifConStricts = if_stricts})
=
bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
{ traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
; name <- lookupIfaceTop occ
; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc name) $
do { eq_spec <- tcIfaceEqSpec spec
; theta <- tcIfaceCtxt ctxt
; arg_tys <- mapM tcIfaceType args
; stricts <- mapM tc_strict if_stricts
; return (eq_spec, theta, arg_tys, stricts) }
; lbl_names <- mapM lookupIfaceTop field_lbls
; let orig_res_ty = mkFamilyTyConApp tycon
(substTyVars (mkTopTvSubst eq_spec) tc_tyvars)
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
name is_infix
stricts
lbl_names
tc_tyvars ex_tyvars
eq_spec theta
arg_tys orig_res_ty tycon
; traceIf (text "Done interface-file tc_con_decl" <+> ppr name)
; return con }
mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
tc_strict :: IfaceBang -> IfL HsImplBang
tc_strict IfNoBang = return HsNoBang
tc_strict IfStrict = return HsStrict
tc_strict IfUnpack = return (HsUnpack Nothing)
tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
; return (HsUnpack (Just co)) }
tcIfaceEqSpec :: IfaceEqSpec -> IfL [(TyVar, Type)]
tcIfaceEqSpec spec
= mapM do_item spec
where
do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
; ty <- tcIfaceType if_ty
; return (tv,ty) }
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
, ifInstCls = cls, ifInstTys = mb_tcs
, ifInstOrph = orph })
= do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
tcIfaceExtId dfun_occ
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
; return (mkImportedInstance cls mb_tcs' dfun oflag orph) }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
, ifFamInstAxiom = axiom_name } )
= do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
tcIfaceCoAxiom axiom_name
; let axiom'' = toUnbranchedAxiom axiom'
mb_tcs' = map (fmap ifaceTyConName) mb_tcs
; return (mkImportedFamInst fam mb_tcs' axiom'') }
tcIfaceRules :: Bool
-> [IfaceRule]
-> IfL [CoreRule]
tcIfaceRules ignore_prags if_rules
| ignore_prags = return []
| otherwise = mapM tcIfaceRule if_rules
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
ifRuleAuto = auto })
= do { ~(bndrs', args', rhs') <-
forkM (ptext (sLit "Rule") <+> ftext name) $
bindIfaceBndrs bndrs $ \ bndrs' ->
do { args' <- mapM tcIfaceExpr args
; rhs' <- tcIfaceExpr rhs
; return (bndrs', args', rhs') }
; let mb_tcs = map ifTopFreeName args
; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs', ru_args = args',
ru_rhs = occurAnalyseExpr rhs',
ru_rough = mb_tcs,
ru_auto = auto,
ru_local = False }) }
where
ifTopFreeName :: IfaceExpr -> Maybe Name
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
ifTopFreeName (IfaceApp f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
ifTopFreeName _ = Nothing
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
tcIfaceAnnotations = mapM tcIfaceAnnotation
tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
tcIfaceAnnotation (IfaceAnnotation target serialized) = do
target' <- tcIfaceAnnTarget target
return $ Annotation {
ann_target = target',
ann_value = serialized
}
tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
tcIfaceAnnTarget (NamedTarget occ) = do
name <- lookupIfaceTop occ
return $ NamedTarget name
tcIfaceAnnTarget (ModuleTarget mod) = do
return $ ModuleTarget mod
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceVectInfo mod typeEnv (IfaceVectInfo
{ ifaceVectInfoVar = vars
, ifaceVectInfoTyCon = tycons
, ifaceVectInfoTyConReuse = tyconsReuse
, ifaceVectInfoParallelVars = parallelVars
, ifaceVectInfoParallelTyCons = parallelTyCons
})
= do { let parallelTyConsSet = mkNameSet parallelTyCons
; vVars <- mapM vectVarMapping vars
; let varsSet = mkVarSet (map fst vVars)
; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons
; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
; vParallelVars <- mapM vectVar parallelVars
; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
; return $ VectInfo
{ vectInfoVar = mkVarEnv vVars `extendVarEnvList` concat vScSels
, vectInfoTyCon = mkNameEnv vTyCons
, vectInfoDataCon = mkNameEnv (concat vDataCons)
, vectInfoParallelVars = mkVarSet vParallelVars
, vectInfoParallelTyCons = parallelTyConsSet
}
}
where
vectVarMapping name
= do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectOcc name)
; var <- forkM (ptext (sLit "vect var") <+> ppr name) $
tcIfaceExtId name
; vVar <- forkM (ptext (sLit "vect vVar [mod =") <+>
ppr mod <> ptext (sLit "; nameModule =") <+>
ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $
tcIfaceExtId vName
; return (var, (var, vVar))
}
vectVar name
= forkM (ptext (sLit "vect scalar var") <+> ppr name) $
tcIfaceExtId name
vectTyConVectMapping vars name
= do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
; vectTyConMapping vars name vName
}
vectTyConReuseMapping vars name
= vectTyConMapping vars name name
vectTyConMapping vars name vName
= do { tycon <- lookupLocalOrExternalTyCon name
; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $
lookupLocalOrExternalTyCon vName
; let isAbstract | isClassTyCon tycon = False
| datacon:_ <- tyConDataCons tycon
= not $ dataConWrapId datacon `elemVarSet` vars
| otherwise = True
vDataCons | isAbstract = []
| otherwise = [ (dataConName datacon, (datacon, vDatacon))
| (datacon, vDatacon) <- zip (tyConDataCons tycon)
(tyConDataCons vTycon)
]
vScSels | Just cls <- tyConClass_maybe tycon
, Just vCls <- tyConClass_maybe vTycon
= [ (sel, (sel, vSel))
| (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
]
| otherwise
= []
; return ( (name, (tycon, vTycon))
, vDataCons
, vScSels
)
}
where
lookupLocalOrExternalTyCon name
= do { let mb_tycon = lookupTypeEnv typeEnv name
; case mb_tycon of
Just (ATyCon tycon) -> return tycon
Just _ -> notATyConErr
Nothing -> tcIfaceTyCon (IfaceTc name)
}
notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) }
tcIfaceType (IfaceFunTy t1 t2) = tcIfaceTypeFun t1 t2
tcIfaceType (IfaceDFunTy t1 t2) = tcIfaceTypeFun t1 t2
tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc
; tks' <- tcIfaceTcArgs tks
; return (mkTyConApp tc' tks') }
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
tcIfaceTypeFun :: IfaceType -> IfaceType -> IfL Type
tcIfaceTypeFun t1 t2 = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
tcIfaceKind :: IfaceKind -> IfL Type
tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') }
tcIfaceKind (IfaceFunTy t1 t2) = tcIfaceKindFun t1 t2
tcIfaceKind (IfaceDFunTy t1 t2) = tcIfaceKindFun t1 t2
tcIfaceKind (IfaceLitTy l) = pprPanic "tcIfaceKind" (ppr l)
tcIfaceKind k = tcIfaceType k
tcIfaceKindFun :: IfaceKind -> IfaceKind -> IfL Type
tcIfaceKindFun t1 t2 = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') }
tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type]
tcIfaceTcArgs args
= case args of
ITC_Type t ts ->
do { t' <- tcIfaceType t
; ts' <- tcIfaceTcArgs ts
; return (t':ts') }
ITC_Kind k ks ->
do { k' <- tcIfaceKind k
; ks' <- tcIfaceTcArgs ks
; return (k':ks') }
ITC_Nil -> return []
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
tcIfaceCtxt sts = mapM tcIfaceType sts
tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
tcIfaceCo :: IfaceCoercion -> IfL Coercion
tcIfaceCo (IfaceReflCo r t) = mkReflCo r <$> tcIfaceType t
tcIfaceCo (IfaceFunCo r c1 c2) = mkFunCo r <$> tcIfaceCo c1 <*> tcIfaceCo c2
tcIfaceCo (IfaceTyConAppCo r tc cs) = mkTyConAppCo r <$> tcIfaceTyCon tc
<*> mapM tcIfaceCo cs
tcIfaceCo (IfaceAppCo c1 c2) = mkAppCo <$> tcIfaceCo c1
<*> tcIfaceCo c2
tcIfaceCo (IfaceForAllCo tv c) = bindIfaceTyVar tv $ \ tv' ->
mkForAllCo tv' <$> tcIfaceCo c
tcIfaceCo (IfaceCoVarCo n) = mkCoVarCo <$> tcIfaceCoVar n
tcIfaceCo (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n
<*> pure i
<*> mapM tcIfaceCo cs
tcIfaceCo (IfaceUnivCo s r t1 t2) = UnivCo s r <$> tcIfaceType t1
<*> tcIfaceType t2
tcIfaceCo (IfaceSymCo c) = SymCo <$> tcIfaceCo c
tcIfaceCo (IfaceTransCo c1 c2) = TransCo <$> tcIfaceCo c1
<*> tcIfaceCo c2
tcIfaceCo (IfaceInstCo c1 t2) = InstCo <$> tcIfaceCo c1
<*> tcIfaceType t2
tcIfaceCo (IfaceNthCo d c) = NthCo d <$> tcIfaceCo c
tcIfaceCo (IfaceLRCo lr c) = LRCo lr <$> tcIfaceCo c
tcIfaceCo (IfaceSubCo c) = SubCo <$> tcIfaceCo c
tcIfaceCo (IfaceAxiomRuleCo ax tys cos) = AxiomRuleCo
<$> tcIfaceCoAxiomRule ax
<*> mapM tcIfaceType tys
<*> mapM tcIfaceCo cos
tcIfaceCoVar :: FastString -> IfL CoVar
tcIfaceCoVar = tcIfaceLclId
tcIfaceCoAxiomRule :: FastString -> IfL CoAxiomRule
tcIfaceCoAxiomRule n =
case Map.lookup n typeNatCoAxiomRules of
Just ax -> return ax
_ -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
tcIfaceExpr (IfaceType ty)
= Type <$> tcIfaceType ty
tcIfaceExpr (IfaceCo co)
= Coercion <$> tcIfaceCo co
tcIfaceExpr (IfaceCast expr co)
= Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
tcIfaceExpr (IfaceLcl name)
= Var <$> tcIfaceLclId name
tcIfaceExpr (IfaceExt gbl)
= Var <$> tcIfaceExtId gbl
tcIfaceExpr (IfaceLit lit)
= do lit' <- tcIfaceLit lit
return (Lit lit')
tcIfaceExpr (IfaceFCall cc ty) = do
ty' <- tcIfaceType ty
u <- newUnique
dflags <- getDynFlags
return (Var (mkFCallId dflags u cc ty'))
tcIfaceExpr (IfaceTuple boxity args) = do
args' <- mapM tcIfaceExpr args
let con_args = map (Type . exprType) args' ++ args'
return (mkApps (Var con_id) con_args)
where
arity = length args
con_id = dataConWorkId (tupleCon boxity arity)
tcIfaceExpr (IfaceLam (bndr, os) body)
= bindIfaceBndr bndr $ \bndr' ->
Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body
where
tcIfaceOneShot IfaceOneShot b = setOneShotLambda b
tcIfaceOneShot _ b = b
tcIfaceExpr (IfaceApp fun arg)
= tcIfaceApps fun arg
tcIfaceExpr (IfaceECase scrut ty)
= do { scrut' <- tcIfaceExpr scrut
; ty' <- tcIfaceType ty
; return (castBottomExpr scrut' ty') }
tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
scrut' <- tcIfaceExpr scrut
case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
let
scrut_ty = exprType scrut'
case_bndr' = mkLocalId case_bndr_name scrut_ty
tc_app = splitTyConApp scrut_ty
extendIfaceIdEnv [case_bndr'] $ do
alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
return (Case scrut' case_bndr' (coreAltsType alts') alts')
tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
; id_info <- tcIdInfo False
name ty' info
; let id = mkLocalIdWithInfo name ty' id_info
; rhs' <- tcIfaceExpr rhs
; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
; return (Let (NonRec id rhs') body') }
tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
= do { ids <- mapM tc_rec_bndr (map fst pairs)
; extendIfaceIdEnv ids $ do
{ pairs' <- zipWithM tc_pair pairs ids
; body' <- tcIfaceExpr body
; return (Let (Rec pairs') body') } }
where
tc_rec_bndr (IfLetBndr fs ty _)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
; return (mkLocalId name ty') }
tc_pair (IfLetBndr _ _ info, rhs) id
= do { rhs' <- tcIfaceExpr rhs
; id_info <- tcIdInfo False
(idName id) (idType id) info
; return (setIdInfo id id_info, rhs') }
tcIfaceExpr (IfaceTick tickish expr) = do
expr' <- tcIfaceExpr expr
dbgFlag <- fmap (gopt Opt_Debug) getDynFlags
case tickish of
IfaceSource{} | not dbgFlag
-> return expr'
_otherwise -> do
tickish' <- tcIfaceTickish tickish
return (Tick tickish' expr')
tcIfaceApps :: IfaceExpr -> IfaceExpr -> IfL CoreExpr
tcIfaceApps fun arg
= go_down fun [arg]
where
go_down (IfaceApp fun arg) args = go_down fun (arg:args)
go_down fun args = do { fun' <- tcIfaceExpr fun
; go_up fun' (exprType fun') args }
go_up :: CoreExpr -> Type -> [IfaceExpr] -> IfL CoreExpr
go_up fun _ [] = return fun
go_up fun fun_ty (IfaceType t : args)
| Just (tv,body_ty) <- splitForAllTy_maybe fun_ty
= do { t' <- if isKindVar tv
then tcIfaceKind t
else tcIfaceType t
; let fun_ty' = substTyWith [tv] [t'] body_ty
; go_up (App fun (Type t')) fun_ty' args }
go_up fun fun_ty (arg : args)
| Just (_, fun_ty') <- splitFunTy_maybe fun_ty
= do { arg' <- tcIfaceExpr arg
; go_up (App fun arg') fun_ty' args }
go_up fun fun_ty args = pprPanic "tcIfaceApps" (ppr fun $$ ppr fun_ty $$ ppr args)
tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
tcIfaceLit :: Literal -> IfL Literal
tcIfaceLit (LitInteger i _)
= do t <- tcIfaceTyCon (IfaceTc integerTyConName)
return (mkLitInteger i (mkTyConTy t))
tcIfaceLit lit = return lit
tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
-> (IfaceConAlt, [FastString], IfaceExpr)
-> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceAlt _ _ (IfaceDefault, names, rhs)
= ASSERT( null names ) do
rhs' <- tcIfaceExpr rhs
return (DEFAULT, [], rhs')
tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
= ASSERT( null names ) do
lit' <- tcIfaceLit lit
rhs' <- tcIfaceExpr rhs
return (LitAlt lit', [], rhs')
tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
= do { con <- tcIfaceDataCon data_occ
; when (debugIsOn && not (con `elem` tyConDataCons tycon))
(failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
; tcIfaceDataAlt con inst_tys arg_strs rhs }
tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
-> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceDataAlt con inst_tys arg_strs rhs
= do { us <- newUniqueSupply
; let uniqs = uniqsFromSupply us
; let (ex_tvs, arg_ids)
= dataConRepFSInstPat arg_strs uniqs con inst_tys
; rhs' <- extendIfaceTyVarEnv ex_tvs $
extendIfaceIdEnv arg_ids $
tcIfaceExpr rhs
; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails _ IfVanillaId = return VanillaId
tcIdDetails ty (IfDFunId ns)
= return (DFunId ns (isNewTyCon (classTyCon cls)))
where
(_, _, cls, _) = tcSplitDFunTy ty
tcIdDetails _ (IfRecSelId tc naughty)
= do { tc' <- tcIfaceTyCon tc
; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo ignore_prags name ty info
| ignore_prags = return vanillaIdInfo
| otherwise = case info of
NoInfo -> return vanillaIdInfo
HasInfo info -> foldlM tcPrag init_info info
where
init_info = vanillaIdInfo
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag)
tcPrag info (HsUnfold lb if_unf)
= do { unf <- tcUnfolding name ty info if_unf
; let info1 | lb = info `setOccInfo` strongLoopBreaker
| otherwise = info
; return (info1 `setUnfoldingInfoLazily` unf) }
tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding name _ info (IfCoreUnfold stable if_expr)
= do { dflags <- getDynFlags
; mb_expr <- tcPragExpr name if_expr
; let unf_src | stable = InlineStable
| otherwise = InlineRhs
; return $ case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkUnfolding dflags unf_src
True
(isBottomingSig strict_sig)
expr
}
where
strict_sig = strictnessInfo info
tcUnfolding name _ _ (IfCompulsory if_expr)
= do { mb_expr <- tcPragExpr name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCompulsoryUnfolding expr) }
tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
= do { mb_expr <- tcPragExpr name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
where
guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
= bindIfaceBndrs bs $ \ bs' ->
do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
; return (case mb_ops1 of
Nothing -> noUnfolding
Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
where
doc = text "Class ops for dfun" <+> ppr name
(_, _, cls, _) = tcSplitDFunTy dfun_ty
tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr name expr
= forkM_maybe doc $ do
core_expr' <- tcIfaceExpr expr
whenGOptM Opt_DoCoreLinting $ do
in_scope <- get_in_scope
case lintUnfolding noSrcLoc in_scope core_expr' of
Nothing -> return ()
Just fail_msg -> do { mod <- getIfModule
; pprPanic "Iface Lint failure"
(vcat [ ptext (sLit "In interface for") <+> ppr mod
, hang doc 2 fail_msg
, ppr name <+> equals <+> ppr core_expr'
, ptext (sLit "Iface expr =") <+> ppr expr ]) }
return core_expr'
where
doc = text "Unfolding of" <+> ppr name
get_in_scope :: IfL [Var]
get_in_scope
= do { (gbl_env, lcl_env) <- getEnvs
; rec_ids <- case if_rec_types gbl_env of
Nothing -> return []
Just (_, get_env) -> do
{ type_env <- setLclEnv () get_env
; return (typeEnvIds type_env) }
; return (varEnvElts (if_tv_env lcl_env) ++
varEnvElts (if_id_env lcl_env) ++
rec_ids) }
tcIfaceGlobal :: Name -> IfL TyThing
tcIfaceGlobal name
| Just thing <- wiredInNameTyThing_maybe name
= do { ifCheckWiredInThing thing; return thing }
| otherwise
= do { env <- getGblEnv
; case if_rec_types env of {
Just (mod, get_type_env)
| nameIsLocalOrFrom mod name
-> do
{ type_env <- setLclEnv () get_type_env
; case lookupNameEnv type_env name of
Just thing -> return thing
Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
(ppr name $$ ppr type_env) }
; _ -> do
{ hsc_env <- getTopEnv
; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
; case mb_thing of {
Just thing -> return thing ;
Nothing -> do
{ mb_thing <- importDecl name
; case mb_thing of
Failed err -> failIfM err
Succeeded thing -> return thing
}}}}}
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon itc
= do {
; thing <- tcIfaceGlobal (ifaceTyConName itc)
; case itc of
IfaceTc _ -> return $ tyThingTyCon thing
IfacePromotedDataCon _ -> return $ promoteDataCon $ tyThingDataCon thing
IfacePromotedTyCon name ->
let ktycon tc
| isSuperKind (tyConKind tc) = return tc
| Just prom_tc <- promotableTyCon_maybe tc = return prom_tc
| otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing)
in ktycon (tyThingTyCon thing)
}
tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
; return (tyThingCoAxiom thing) }
tcIfaceDataCon :: Name -> IfL DataCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
; case thing of
AConLike (RealDataCon dc) -> return dc
_ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
tcIfaceExtId :: Name -> IfL Id
tcIfaceExtId name = do { thing <- tcIfaceGlobal name
; case thing of
AnId id -> return id
_ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
; let id = mkLocalId name ty'
; extendIfaceIdEnv [id] (thing_inside id) }
bindIfaceBndr (IfaceTvBndr bndr) thing_inside
= bindIfaceTyVar bndr thing_inside
bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
bindIfaceBndrs [] thing_inside = thing_inside []
bindIfaceBndrs (b:bs) thing_inside
= bindIfaceBndr b $ \ b' ->
bindIfaceBndrs bs $ \ bs' ->
thing_inside (b':bs')
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
= do { name <- newIfaceName (mkTyVarOccFS occ)
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars bndrs thing_inside
= do { names <- newIfaceNames (map mkTyVarOccFS occs)
; let (kis_kind, tys_kind) = span isSuperIfaceKind kinds
(kis_name, tys_name) = splitAt (length kis_kind) names
; kvs <- zipWithM mk_iface_tyvar kis_name kis_kind
; extendIfaceTyVarEnv kvs $ do
{ tvs <- zipWithM mk_iface_tyvar tys_name tys_kind
; extendIfaceTyVarEnv tvs (thing_inside (kvs ++ tvs)) } }
where
(occs,kinds) = unzip bndrs
isSuperIfaceKind :: IfaceKind -> Bool
isSuperIfaceKind (IfaceTyConApp tc ITC_Nil) = ifaceTyConName tc == superKindTyConName
isSuperIfaceKind _ = False
mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
mk_iface_tyvar name ifKind
= do { kind <- tcIfaceKind ifKind
; return (Var.mkTyVar name kind) }
bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars_AT [] thing_inside
= thing_inside []
bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
= do { mb_tv <- lookupIfaceTyVar tv_occ
; let bind_b :: (TyVar -> IfL a) -> IfL a
bind_b = case mb_tv of
Just b' -> \k -> k b'
Nothing -> bindIfaceTyVar b
; bind_b $ \b' ->
bindIfaceTyVars_AT bs $ \bs' ->
thing_inside (b':bs') }