ubxTupleKindTyCon,
mkTyVarTys, ThetaType )
import TypeRep ( Type(..), PredType(..) )
-import TyCon ( TyCon, tyConName, SynTyConRhs(..) )
+import TyCon ( TyCon, tyConName, SynTyConRhs(..),
+ AlgTyConParent(..), setTyConArgPoss )
import HscTypes ( ExternalPackageState(..),
TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), HomeModInfo(..),
import Util ( zipWithEqual, equalLength, splitAtList )
import DynFlags ( DynFlag(..), isOneShot )
+import List ( elemIndex)
+import Maybe ( catMaybes )
+import Monad ( liftM )
\end{code}
This module takes
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec,
- ifGeneric = want_generic })
+ ifGeneric = want_generic,
+ ifFamInst = mb_family })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tycon <- fixM ( \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
- ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
+ ; famInst <-
+ case mb_family of
+ Nothing -> return Nothing
+ Just (fam, tys) ->
+ do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys)
+ }
+ ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; buildAlgTyCon tc_name tyvars stupid_theta
- cons is_rec want_generic gadt_syn
+ cons is_rec want_generic gadt_syn famInst
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon)
; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
}
-tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
- ifFDs = rdr_fds, ifSigs = rdr_sigs,
+tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
+ ifTyVars = tv_bndrs, ifFDs = rdr_fds,
+ ifATs = rdr_ats, ifSigs = rdr_sigs,
ifRec = tc_isrec })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
-- as we do abstract tycons
; ctxt <- tcIfaceCtxt rdr_ctxt
; sigs <- mappM tc_sig rdr_sigs
; fds <- mappM tc_fd rdr_fds
- ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec
+ ; ats' <- mappM tcIfaceDecl rdr_ats
+ ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats)
+ ; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec
; return (AClass cls) }
where
tc_sig (IfaceClassOp occ dm rdr_ty)
; tvs2' <- mappM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
+ -- For each AT argument compute the position of the corresponding class
+ -- parameter in the class head. This will later serve as a permutation
+ -- vector when checking the validity of instance declarations.
+ setTyThingPoss (ATyCon tycon) atTyVars =
+ let classTyVars = map fst tv_bndrs
+ poss = catMaybes
+ . map ((`elemIndex` classTyVars) . fst)
+ $ atTyVars
+ -- There will be no Nothing, as we already passed renaming
+ in
+ ATyCon (setTyConArgPoss tycon poss)
+ setTyThingPoss _ _ = panic "TcIface.setTyThingPoss"
+
tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name