X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=20aaa9fca8db18a489bd37073339a6f92841b1d3;hb=17434e5beb213f1e8971d1ce8ffbf40a0848bb3a;hp=051ec04737a33c4e8c613e872f07b48b79ae9cdc;hpb=9621257fcd85a572a5c305b77995bda62689bb86;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 051ec04..20aaa9f 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -19,23 +19,25 @@ import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, newIfaceName, newIfaceNames, ifaceExportNames ) -import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, - mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) +import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, + buildClass, + mkAbstractTyConRhs, mkOpenDataTyConRhs, + mkOpenNewTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, liftedTypeKindTyCon, unliftedTypeKindTyCon, openTypeKindTyCon, argTypeKindTyCon, - ubxTupleKindTyCon, - mkTyVarTys, ThetaType ) + ubxTupleKindTyCon, ThetaType ) import TypeRep ( Type(..), PredType(..) ) -import TyCon ( TyCon, tyConName ) +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, dataConOccInstPat ) +import CoreUtils ( exprType, dataConRepFSInstPat ) import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) @@ -47,13 +49,14 @@ 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 -import OccName ( OccName, mkVarOccFS, mkTyVarOccoccNameSpace, pprNameSpace ) +import OccName ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace, + pprNameSpace, occNameFS ) import FastString ( FastString ) import Module ( Module, moduleName ) import UniqFM ( lookupUFM ) @@ -62,9 +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 List ( elemIndex) +import Maybe ( catMaybes ) \end{code} This module takes @@ -216,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} @@ -355,30 +362,44 @@ tcIfaceDecl (IfaceData {ifName = occ_name, 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 (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 ; 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) }} tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifSynRhs = rdr_rhs_ty}) + ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_ty <- tcIfaceType rdr_rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty)) + ; rhs_tyki <- tcIfaceType rdr_rhs_ty + ; let rhs = if isOpen then OpenSynTyCon rhs_tyki + else SynonymTyCon rhs_tyki + ; 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 @@ -387,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) @@ -404,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 @@ -412,6 +448,8 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon -> return mkAbstractTyConRhs + IfOpenDataTyCon -> return mkOpenDataTyConRhs + IfOpenNewTyCon -> return mkOpenNewTyConRhs IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con @@ -452,7 +490,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons tcIfaceEqSpec spec = mapM do_item spec where - do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ + do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ) ; ty <- tcIfaceType if_ty ; return (tv,ty) } \end{code} @@ -680,13 +718,14 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) tcIfaceDataAlt con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us - ; let (ex_tvs, co_tvs, arg_ids) = dataConOccInstPat uniqs arg_occs con inst_tys - all_tvs = ex_tvs ++ co_tvs + ; let (ex_tvs, co_tvs, arg_ids) + = dataConRepFSInstPat arg_strs uniqs con inst_tys + all_tvs = ex_tvs ++ co_tvs ; rhs' <- extendIfaceTyVarEnv all_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs - ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } + ; return (DataAlt con, all_tvs ++ arg_ids, rhs') } \end{code} @@ -967,7 +1006,5 @@ mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind ; return (mkTyVar name kind) } - -mk_iface_tyvar name kind = mkTyVar name kind \end{code}