tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings
-> IfaceDecl
-> IfL TyThing
-
-tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
- ifIdDetails = details, ifIdInfo = info})
+tcIfaceDecl = tc_iface_decl NoParentTyCon
+
+tc_iface_decl :: TyConParent -- For nested declarations
+ -> Bool -- True <=> discard IdInfo on IfaceId bindings
+ -> 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)) }
-tcIfaceDecl _ (IfaceData {ifName = occ_name,
+tc_iface_decl parent _ (IfaceData {ifName = occ_name,
ifTyVars = tv_bndrs,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
{ tc_name <- lookupIfaceTop occ_name
; tycon <- fixM ( \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
- ; mb_fam_inst <- tcFamInst mb_family
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
- ; buildAlgTyCon tc_name tyvars stupid_theta
- cons is_rec want_generic gadt_syn mb_fam_inst
+ ; mb_fam_inst <- tcFamInst mb_family
+ ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
+ want_generic gadt_syn parent mb_fam_inst
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
-tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
- ifSynRhs = mb_rhs_ty,
- ifSynKind = kind, ifFamInst = mb_family})
+tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
+ ifSynRhs = mb_rhs_ty,
+ ifSynKind = kind, ifFamInst = mb_family})
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
- { tc_name <- lookupIfaceTop occ_name
+ { tc_name <- lookupIfaceTop occ_name
; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop]
- ; ~(rhs, fam) <- forkM (mk_doc tc_name) $
- do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty
- ; fam <- tcFamInst mb_family
- ; return (rhs, fam) }
- ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
- ; return $ ATyCon tycon
+ ; rhs <- forkM (mk_doc tc_name) $
+ tc_syn_rhs mb_rhs_ty
+ ; fam_info <- tcFamInst mb_family
+ ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent fam_info
+ ; return (ATyCon tycon)
}
where
mk_doc n = ptext (sLit "Type syonym") <+> ppr n
- tc_syn_rhs kind Nothing = return (OpenSynTyCon kind Nothing)
- tc_syn_rhs _ (Just ty) = do { rhs_ty <- tcIfaceType ty
- ; return (SynonymTyCon rhs_ty) }
+ tc_syn_rhs Nothing = return SynFamilyTyCon
+ tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty
+ ; return (SynonymTyCon rhs_ty) }
-tcIfaceDecl ignore_prags
+tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
ifTyVars = tv_bndrs, ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
; ctxt <- tcIfaceCtxt rdr_ctxt
; sigs <- mapM tc_sig rdr_sigs
; fds <- mapM tc_fd rdr_fds
- ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats
- ; let ats = map (setAssocFamilyPermutation tyvars) ats'
- ; cls <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec
+ ; cls <- fixM $ \ cls -> do
+ { ats <- mapM (tc_iface_decl (AssocFamilyTyCon cls) ignore_prags) rdr_ats
+ ; buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec }
; return (AClass cls) }
where
tc_sig (IfaceClassOp occ dm rdr_ty)
; tvs2' <- mapM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
-tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
+tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0)) }
tcIfaceDataCons tycon_name tycon _ if_cons
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
- IfOpenDataTyCon -> return mkOpenDataTyConRhs
+ IfOpenDataTyCon -> 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
; tcIfaceDataAlt con inst_tys arg_strs rhs }
tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs)
- = ASSERT( isTupleTyCon tycon )
+ = ASSERT2( isTupleTyCon tycon, ppr tycon )
do { let [data_con] = tyConDataCons tycon
; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
\begin{code}
tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
-tcUnfolding name _ info (IfCoreUnfold if_expr)
+tcUnfolding name _ info (IfCoreUnfold stable if_expr)
= do { mb_expr <- tcPragExpr name if_expr
+ ; let unf_src = if stable then InlineStable else InlineRhs
; return (case mb_expr of
- Nothing -> NoUnfolding
- Just expr -> mkTopUnfolding is_bottoming expr) }
+ Nothing -> NoUnfolding
+ Just expr -> mkUnfolding unf_src
+ True {- Top level -}
+ is_bottoming expr) }
where
-- Strictness should occur before unfolding!
is_bottoming = case strictnessInfo info of
= do { mb_expr <- tcPragExpr name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
- Just expr -> mkCoreUnfolding True InlineRule expr arity
+ Just expr -> mkCoreUnfolding True InlineStable expr arity
(UnfWhen unsat_ok boring_ok))
}
= do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
; return (case mb_ops1 of
Nothing -> noUnfolding
- Just ops1 -> DFunUnfolding data_con ops1) }
+ Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
where
doc = text "Class ops for dfun" <+> ppr name
- (_, cls, _) = tcSplitDFunTy dfun_ty
- data_con = classDataCon cls
\end{code}
For unfoldings we try to do the job lazily, so that we never type check