import Type ( liftedTypeKind, splitTyConApp, mkTyConApp,
liftedTypeKindTyCon, unliftedTypeKindTyCon,
openTypeKindTyCon, argTypeKindTyCon,
- ubxTupleKindTyCon,
- mkTyVarTys, ThetaType )
+ ubxTupleKindTyCon, ThetaType )
import TypeRep ( Type(..), PredType(..) )
-import TyCon ( TyCon, tyConName, SynTyConRhs(..),
- AlgTyConParent(..) )
+import TyCon ( TyCon, tyConName, SynTyConRhs(..), setTyConArgPoss )
import HscTypes ( ExternalPackageState(..),
TyThing(..), tyThingClass, tyThingTyCon,
ModIface(..), ModDetails(..), HomeModInfo(..),
- emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
+ emptyModDetails, lookupTypeEnv, lookupType,
+ typeEnvIds, mkDetailsFamInstCache )
import InstEnv ( Instance(..), mkImportedInstance )
import CoreSyn
import CoreUtils ( exprType, dataConRepFSInstPat )
vanillaIdInfo, newStrictnessInfo )
import Class ( Class )
import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
-import DataCon ( DataCon, dataConWorkId, dataConExTyVars, dataConInstArgTys )
+import DataCon ( DataCon, dataConWorkId )
import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
-import Var ( TyVar, mkTyVar, tyVarKind )
+import Var ( TyVar, mkTyVar )
import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
nameOccName, wiredInNameTyThing_maybe )
import NameEnv
import ErrUtils ( Message )
import Maybes ( MaybeErr(..) )
import SrcLoc ( noSrcLoc )
-import Util ( zipWithEqual, equalLength, splitAtList )
+import Util ( zipWithEqual, equalLength )
import DynFlags ( DynFlag(..), isOneShot )
-import Monad ( liftM )
+import List ( elemIndex)
+import Maybe ( catMaybes )
\end{code}
This module takes
; exports <- ifaceExportNames (mi_exports iface)
-- Finished
- ; return (ModDetails { md_types = type_env,
- md_insts = dfuns,
- md_rules = rules,
- md_exports = exports })
+ ; return $ ModDetails { md_types = type_env
+ , md_insts = dfuns
+ , md_fam_insts = mkDetailsFamInstCache type_env
+ , md_rules = rules
+ , md_exports = exports
+ }
}
\end{code}
ifCons = rdr_cons,
ifRec = is_rec,
ifGeneric = want_generic,
- ifFamily = mb_family })
+ ifFamInst = mb_family })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tycon <- fixM ( \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
+ ; famInst <-
+ case mb_family of
+ Nothing -> return Nothing
+ Just (IfaceFamInst { ifFamInstTyCon = fam
+ , ifFamInstTys = tys
+ }) ->
+ do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys)
+ }
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
- ; family <- case mb_family of
- Nothing -> return Nothing
- Just fam ->
- do { famTyCon <- tcIfaceTyCon fam
- ; return $ Just famTyCon
- }
; buildAlgTyCon tc_name tyvars stupid_theta
- cons is_rec want_generic gadt_syn family
+ 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
ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = field_lbls,
- ifConStricts = stricts, ifConInstTys = mb_insttys })
+ ifConStricts = stricts})
= bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
{ name <- lookupIfaceTop occ
-- the component types unless they are really needed
; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
; lbl_names <- mappM lookupIfaceTop field_lbls
- ; mb_insttys' <- case mb_insttys of
- Nothing -> return Nothing
- Just insttys -> liftM Just $
- mappM tcIfaceType insttys
; buildDataCon name is_infix {- Not infix -}
stricts lbl_names
univ_tyvars ex_tyvars
eq_spec theta
arg_tys tycon
- mb_insttys'
}
mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
projects / ghc-hetmet.git / blobdiff