X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=20aaa9fca8db18a489bd37073339a6f92841b1d3;hb=17434e5beb213f1e8971d1ce8ffbf40a0848bb3a;hp=388d0402163cdc4cabe4f75fa21d6a231c646ab9;hpb=80c89b80c355b2aaebcd53330e6c6170c3f05aca;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 388d040..20aaa9f 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -27,15 +27,14 @@ import TcRnMonad 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 ) @@ -50,9 +49,9 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), 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 @@ -66,10 +65,11 @@ import Outputable 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 @@ -221,10 +221,12 @@ typecheckIface iface ; 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} @@ -361,21 +363,25 @@ tcIfaceDecl (IfaceData {ifName = occ_name, 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) @@ -391,8 +397,9 @@ tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ; 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 @@ -401,7 +408,9 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd ; 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) @@ -418,6 +427,19 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd ; 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 @@ -437,7 +459,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons 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 @@ -456,17 +478,12 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons -- 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