X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=6a5595719d195d8776ed35d4d547c6e9e4642ae0;hb=388e3356f71daffa62f1d4157e1e07e4c68f218a;hp=af43f979b4db3e01470d75849dec8828dcde44a1;hpb=9ffadf219cbc4f8ec57264786df936a3cee88aec;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index af43f97..6a55957 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -19,7 +19,6 @@ import LoadIface import IfaceEnv import BuildTyCl import TcRnMonad -import TcType ( tcSplitSigmaTy ) import Type import TypeRep import HscTypes @@ -38,12 +37,12 @@ import Class import TyCon import DataCon import TysWiredIn +import TysPrim ( anyTyConOfKind ) import Var ( TyVar ) import qualified Var import VarEnv import Name import NameEnv -import OccName import Module import LazyUniqFM import UniqSupply @@ -58,7 +57,6 @@ import BasicTypes (Arity) import Control.Monad import Data.List -import Data.Maybe \end{code} This module takes @@ -418,7 +416,7 @@ tcIfaceDecl 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 + ; details <- tcIdDetails details ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkGlobalId details name ty info)) } @@ -429,36 +427,27 @@ tcIfaceDecl _ (IfaceData {ifName = occ_name, ifRec = is_rec, ifGeneric = want_generic, ifFamInst = mb_family }) - = do { tc_name <- lookupIfaceTop occ_name - ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do - - { tycon <- fixM ( \ tycon -> do + = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do + { tc_name <- lookupIfaceTop occ_name + ; tycon <- fixM ( \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt - ; famInst <- - case mb_family of - Nothing -> return Nothing - Just (fam, tys) -> - do { famTyCon <- tcIfaceTyCon fam - ; insttys <- mapM tcIfaceType tys - ; return $ Just (famTyCon, insttys) - } + ; 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 famInst + cons is_rec want_generic gadt_syn mb_fam_inst }) - ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) - ; return (ATyCon tycon) - }} + ; 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}) - = bindIfaceTyVars tv_bndrs $ \ tyvars -> do + = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { 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 <- tc_syn_fam mb_family + ; fam <- tcFamInst mb_family ; return (rhs, fam) } ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam ; return $ ATyCon tycon @@ -468,12 +457,6 @@ tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 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_fam Nothing - = return Nothing - tc_syn_fam (Just (fam, tys)) - = do { famTyCon <- tcIfaceTyCon fam - ; insttys <- mapM tcIfaceType tys - ; return $ Just (famTyCon, insttys) } tcIfaceDecl ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, @@ -511,6 +494,12 @@ tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0)) } +tcFamInst :: Maybe (IfaceTyCon, [IfaceType]) -> IfL (Maybe (TyCon, [Type])) +tcFamInst Nothing = return Nothing +tcFamInst (Just (fam, tys)) = do { famTyCon <- tcIfaceTyCon fam + ; insttys <- mapM tcIfaceType tys + ; return $ Just (famTyCon, insttys) } + tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs tcIfaceDataCons tycon_name tycon _ if_cons = case if_cons of @@ -975,16 +964,12 @@ do_one (IfaceRec pairs) thing_inside %************************************************************************ \begin{code} -tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails -tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails _ IfDFunId = return DFunId -tcIdDetails ty (IfRecSelId naughty) - = return (RecSelId { sel_tycon = tc, sel_naughty = naughty }) - where - (_, _, tau) = tcSplitSigmaTy ty - tc = tyConAppTyCon (funArgTy tau) - -- A bit fragile. Relies on the selector type looking like - -- forall abc. (stupid-context) => T a b c -> blah +tcIdDetails :: IfaceIdDetails -> IfL IdDetails +tcIdDetails IfVanillaId = return VanillaId +tcIdDetails IfDFunId = return DFunId +tcIdDetails (IfRecSelId tc naughty) + = do { tc' <- tcIfaceTyCon tc + ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo tcIdInfo ignore_prags name ty info @@ -1138,6 +1123,8 @@ tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) +tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind + ; tcWiredInTyCon (anyTyConOfKind tc_kind) } tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; return (check_tc (tyThingTyCon thing)) } where @@ -1200,6 +1187,7 @@ bindIfaceBndrs (b:bs) thing_inside bindIfaceBndrs bs $ \ bs' -> thing_inside (b':bs') + ----------------------- tcIfaceLetBndr :: IfaceLetBndr -> IfL Id tcIfaceLetBndr (IfLetBndr fs ty info) @@ -1247,5 +1235,20 @@ mk_iface_tyvar name ifKind return (Var.mkCoVar name kind) else return (Var.mkTyVar name kind) } -\end{code} + +bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +-- Used for type variable in nested associated data/type declarations +-- where some of the type variables are already in scope +-- class C a where { data T a b } +-- Here 'a' is in scope when we look at the 'data T' +bindIfaceTyVars_AT [] thing_inside + = thing_inside [] +bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside + = bindIfaceTyVars_AT bs $ \ bs' -> + do { mb_tv <- lookupIfaceTyVar tv_occ + ; case mb_tv of + Just b' -> thing_inside (b':bs') + Nothing -> bindIfaceTyVar b $ \ b' -> + thing_inside (b':bs') } +\end{code}