It's subtle, because, it'd work fine if we typechecked the constructor args
eagerly -- they don't need the extended type envt. They just get the extended
type envt by accident, because they look at it later.
What this means is that the implicitTyThings MUST NOT DEPEND on any of
the forkM stuff.
\begin{code}
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,
ifAxiom = mb_axiom_name })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; tycon <- fixM $ \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
; parent' <- tc_parent tyvars mb_axiom_name
; 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 :: [TyVar] -> Maybe Name -> IfL TyConParent
tc_parent _ Nothing = return parent
tc_parent tyvars (Just ax_name)
= ASSERT( isNoParent parent )
do { ax <- tcIfaceCoAxiom ax_name
; let fam_tc = coAxiomTyCon ax
ax_unbr = toUnbranchedAxiom ax
branch = coAxiomSingleBranch ax_unbr
ax_tvs = coAxBranchTyVars branch
ax_lhs = coAxBranchLHS branch
tycon_tys = mkTyVarTys tyvars
subst = mkTopTvSubst (ax_tvs `zip` tycon_tys)
lhs_tys = substTys subst ax_lhs `chkAppend`
dropList ax_tvs tycon_tys
; return (FamInstTyCon ax_unbr fam_tc lhs_tys) }
tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
ifRoles = roles,
ifSynRhs = mb_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) $
tc_syn_rhs mb_rhs_ty
; tycon <- buildSynTyCon tc_name tyvars roles rhs rhs_kind parent
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type syonym") <+> ppr n
tc_syn_rhs IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon
tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name)
= do { ax <- tcIfaceCoAxiom ax_name
; return (ClosedSynFamilyTyCon ax) }
tc_syn_rhs IfaceAbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon
tc_syn_rhs (IfaceSynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty
; return (SynonymTyCon rhs_ty) }
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 mindef_occ
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
; buildClass ignore_prags 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 defs_decls)
= do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
defs <- forkM (mk_at_doc tc) (tc_ax_branches tc defs_decls)
return (tc, defs)
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 _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind)) }
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 tc_tycon branches
; let axiom = computeAxiomIncomps $
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
, ifPatHasWrapper = has_wrapper
, 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)
; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
{ bindIfaceTyVars ex_tvs $ \ex_tvs -> do
{ bindIfaceIdVars args $ \args -> do
{ ~(prov_theta, req_theta, pat_ty) <- forkM (mk_doc name) $
do { prov_theta <- tcIfaceCtxt prov_ctxt
; req_theta <- tcIfaceCtxt req_ctxt
; pat_ty <- tcIfaceType pat_ty
; return (prov_theta, req_theta, pat_ty) }
; bindIfaceTyVar (fsLit "r", toIfaceKind liftedTypeKind) $ \tv -> do
{ patsyn <- buildPatSyn name is_infix has_wrapper args univ_tvs ex_tvs prov_theta req_theta pat_ty tv
; return (AConLike (PatSynCon patsyn)) }}}}}
where
mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
tc_ax_branches :: TyCon -> [IfaceAxBranch] -> IfL [CoAxBranch]
tc_ax_branches tc if_branches = foldlM (tc_ax_branch (tyConKind tc)) [] if_branches
tc_ax_branch :: Kind -> [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branch tc_kind prev_branches
(IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs
, ifaxbRoles = roles, ifaxbIncomps = incomps })
= bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do
{ tc_lhs <- tcIfaceTcArgs tc_kind 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 _ 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,
ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = field_lbls,
ifConStricts = if_stricts})
= bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
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) univ_tyvars)
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
name is_infix
stricts lbl_names
univ_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 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 :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
tcIfaceEqSpec spec
= mapM do_item spec
where
do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
; ty <- tcIfaceType if_ty
; return (tv,ty) }
\end{code}
Note [Synonym kind loop]
~~~~~~~~~~~~~~~~~~~~~~~~
Notice that we eagerly grab the *kind* from the interface file, but
build a forkM thunk for the *rhs* (and family stuff). To see why,
consider this (Trac #2412)
M.hs: module M where { import X; data T = MkT S }
X.hs: module X where { import {-# SOURCE #-} M; type S = T }
M.hs-boot: module M where { data T }
When kind-checking M.hs we need S's kind. But we do not want to
find S's kind from (typeKind S-rhs), because we don't want to look at
S-rhs yet! Since S is imported from X.hi, S gets just one chance to
be defined, and we must not do that until we've finished with M.T.
Solution: record S's kind in the interface file; now we can safely
look at it.
%************************************************************************
%* *
Instances
%* *
%************************************************************************
\begin{code}
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
, ifInstCls = cls, ifInstTys = mb_tcs })
= 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) }
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'') }
\end{code}
%************************************************************************
%* *
Rules
%* *
%************************************************************************
We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
are in the type environment. However, remember that typechecking a Rule may
(as a side effect) augment the type envt, and so we may need to iterate the process.
\begin{code}
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
\end{code}
%************************************************************************
%* *
Annotations
%* *
%************************************************************************
\begin{code}
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
\end{code}
%************************************************************************
%* *
Vectorisation information
%* *
%************************************************************************
\begin{code}
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)
\end{code}
%************************************************************************
%* *
Types
%* *
%************************************************************************
\begin{code}
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) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc
; tks' <- tcIfaceTcArgs (tyConKind tc') tks
; return (mkTyConApp tc' tks') }
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
tcIfaceTypes :: [IfaceType] -> IfL [Type]
tcIfaceTypes tys = mapM tcIfaceType tys
tcIfaceTcArgs :: Kind -> [IfaceType] -> IfL [Type]
tcIfaceTcArgs _ []
= return []
tcIfaceTcArgs kind (tk:tks)
= case splitForAllTy_maybe kind of
Nothing -> tcIfaceTypes (tk:tks)
Just (_, kind') -> do { k' <- tcIfaceKind tk
; tks' <- tcIfaceTcArgs kind' tks
; return (k':tks') }
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)
tcIfaceKind :: IfaceKind -> IfL Kind
tcIfaceKind (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') }
tcIfaceKind (IfaceFunTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') }
tcIfaceKind (IfaceTyConApp tc ts) = do { tc' <- tcIfaceKindCon tc; ts' <- tcIfaceKinds ts; return (mkTyConApp tc' ts') }
tcIfaceKind (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceKind t; return (ForAllTy tv' t') }
tcIfaceKind t = pprPanic "tcIfaceKind" (ppr t)
tcIfaceKinds :: [IfaceKind] -> IfL [Kind]
tcIfaceKinds tys = mapM tcIfaceKind tys
\end{code}
Note [Checking IfaceTypes vs IfaceKinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to know whether we are checking a *type* or a *kind*.
Consider module M where
Proxy :: forall k. k -> *
data T = T
and consider the two IfaceTypes
M.Proxy * M.T{tc}
M.Proxy 'M.T{tc} 'M.T(d}
The first is conventional, but in the latter we use the promoted
type constructor (as a kind) and data constructor (as a type). However,
the Name of the promoted type constructor is just M.T; it's the *same name*
as the ordinary type constructor.
We could add a "promoted" flag to an IfaceTyCon, but that's a bit heavy.
Instead we use context to distinguish, as in the source language.
- When checking a kind, we look up M.T{tc} and promote it
- When checking a type, we look up M.T{tc} and don't promote it
and M.T{d} and promote it
See tcIfaceKindCon and tcIfaceKTyCon respectively
This context business is why we need tcIfaceTcArgs, and tcIfaceApps
%************************************************************************
%* *
Coercions
%* *
%************************************************************************
\begin{code}
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 r t1 t2) = UnivCo 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)
\end{code}
%************************************************************************
%* *
Core
%* *
%************************************************************************
\begin{code}
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 body)
= bindIfaceBndr bndr $ \bndr' ->
Lam bndr' <$> tcIfaceExpr body
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
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)
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') }
\end{code}
\begin{code}
tcExtCoreBindings :: [IfaceBinding] -> IfL CoreProgram
tcExtCoreBindings [] = return []
tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
do_one (IfaceNonRec bndr rhs) thing_inside
= do { rhs' <- tcIfaceExpr rhs
; bndr' <- newExtCoreBndr bndr
; extendIfaceIdEnv [bndr'] $ do
{ core_binds <- thing_inside
; return (NonRec bndr' rhs' : core_binds) }}
do_one (IfaceRec pairs) thing_inside
= do { bndrs' <- mapM newExtCoreBndr bndrs
; extendIfaceIdEnv bndrs' $ do
{ rhss' <- mapM tcIfaceExpr rhss
; core_binds <- thing_inside
; return (Rec (bndrs' `zip` rhss') : core_binds) }}
where
(bndrs,rhss) = unzip pairs
\end{code}
%************************************************************************
%* *
IdInfo
%* *
%************************************************************************
\begin{code}
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) }
\end{code}
\begin{code}
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 arity
(UnfWhen unsat_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
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
\begin{code}
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) }
\end{code}
%************************************************************************
%* *
Getting from Names to TyThings
%* *
%************************************************************************
\begin{code}
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 (IfaceTc name)
= do { thing <- tcIfaceGlobal name
; case thing of
ATyCon tc -> return tc
AConLike (RealDataCon dc) -> return (promoteDataCon dc)
_ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) }
tcIfaceKindCon :: IfaceTyCon -> IfL TyCon
tcIfaceKindCon (IfaceTc name)
= do { thing <- tcIfaceGlobal name
; case thing of
ATyCon tc
| isSuperKind (tyConKind tc)
-> return tc
| Just prom_tc <- promotableTyCon_maybe tc
-> return prom_tc
_ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr 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) }
\end{code}
%************************************************************************
%* *
Bindings
%* *
%************************************************************************
\begin{code}
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')
newExtCoreBndr :: IfaceLetBndr -> IfL Id
newExtCoreBndr (IfLetBndr var ty _)
= do { mod <- getIfModule
; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan
; ty' <- tcIfaceType ty
; return (mkLocalId name ty') }
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
bindIfaceIdVar :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
bindIfaceIdVar (occ, ty) thing_inside
= do { name <- newIfaceName (mkVarOccFS occ)
; ty' <- tcIfaceType ty
; let id = mkLocalId name ty'
; extendIfaceIdEnv [id] (thing_inside id) }
bindIfaceIdVars :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
bindIfaceIdVars [] thing_inside = thing_inside []
bindIfaceIdVars (v:vs) thing_inside
= bindIfaceIdVar v $ \ v' ->
bindIfaceIdVars vs $ \ vs' ->
thing_inside (v':vs')
isSuperIfaceKind :: IfaceKind -> Bool
isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == 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') }
\end{code}