diff options
Diffstat (limited to 'compiler/iface')
| -rw-r--r-- | compiler/iface/BinIface.hs | 45 | ||||
| -rw-r--r-- | compiler/iface/BuildTyCl.lhs | 75 | ||||
| -rw-r--r-- | compiler/iface/FlagChecker.hs | 4 | ||||
| -rw-r--r-- | compiler/iface/IfaceSyn.lhs | 147 | ||||
| -rw-r--r-- | compiler/iface/LoadIface.lhs | 6 | ||||
| -rw-r--r-- | compiler/iface/MkIface.lhs | 137 | ||||
| -rw-r--r-- | compiler/iface/TcIface.lhs | 74 | ||||
| -rw-r--r-- | compiler/iface/TcIface.lhs-boot | 6 |
8 files changed, 249 insertions, 245 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 15434f0473..5cb7cd1e4d 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1408,13 +1408,12 @@ instance Binary IfaceDecl where put_ bh a6 put_ bh a7 - put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do + put_ bh (IfaceSyn a1 a2 a3 a4) = do putByte bh 3 put_ bh (occNameFS a1) put_ bh a2 put_ bh a3 put_ bh a4 - put_ bh a5 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do putByte bh 4 @@ -1425,6 +1424,13 @@ instance Binary IfaceDecl where put_ bh a5 put_ bh a6 put_ bh a7 + + put_ bh (IfaceAxiom a1 a2 a3 a4) = do + putByte bh 5 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 get bh = do h <- getByte bh @@ -1449,10 +1455,9 @@ instance Binary IfaceDecl where a2 <- get bh a3 <- get bh a4 <- get bh - a5 <- get bh occ <- return $! mkOccNameFS tcName a1 - return (IfaceSyn occ a2 a3 a4 a5) - _ -> do a1 <- get bh + return (IfaceSyn occ a2 a3 a4) + 4 -> do a1 <- get bh a2 <- get bh a3 <- get bh a4 <- get bh @@ -1461,9 +1466,15 @@ instance Binary IfaceDecl where a7 <- get bh occ <- return $! mkOccNameFS clsName a2 return (IfaceClass a1 occ a3 a4 a5 a6 a7) + _ -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfaceAxiom occ a2 a3 a4) -instance Binary IfaceInst where - put_ bh (IfaceInst cls tys dfun flag orph) = do +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph) = do put_ bh cls put_ bh tys put_ bh dfun @@ -1475,18 +1486,20 @@ instance Binary IfaceInst where dfun <- get bh flag <- get bh orph <- get bh - return (IfaceInst cls tys dfun flag orph) + return (IfaceClsInst cls tys dfun flag orph) instance Binary IfaceFamInst where - put_ bh (IfaceFamInst fam tys tycon) = do + put_ bh (IfaceFamInst fam tys name orph) = do put_ bh fam put_ bh tys - put_ bh tycon + put_ bh name + put_ bh orph get bh = do - fam <- get bh - tys <- get bh - tycon <- get bh - return (IfaceFamInst fam tys tycon) + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) instance Binary OverlapFlag where put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b @@ -1503,14 +1516,14 @@ instance Binary OverlapFlag where instance Binary IfaceConDecls where put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d - put_ bh IfOpenDataTyCon = putByte bh 1 + put_ bh IfDataFamTyCon = putByte bh 1 put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c get bh = do h <- getByte bh case h of 0 -> get bh >>= (return . IfAbstractTyCon) - 1 -> return IfOpenDataTyCon + 1 -> return IfDataFamTyCon 2 -> get bh >>= (return . IfDataTyCon) _ -> get bh >>= (return . IfNewTyCon) diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 612b098c2f..1ffabb4f73 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -12,13 +12,13 @@ -- for details module BuildTyCl ( - buildSynTyCon, + buildSynTyCon, buildAlgTyCon, buildDataCon, buildPromotedDataTyCon, TcMethInfo, buildClass, - distinctAbstractTyConRhs, totallyAbstractTyConRhs, - mkNewTyConRhs, mkDataTyConRhs, + distinctAbstractTyConRhs, totallyAbstractTyConRhs, + mkNewTyConRhs, mkDataTyConRhs, newImplicitBinder ) where @@ -49,69 +49,28 @@ import Unique ( getUnique ) ------------------------------------------------------ buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs - -> Kind -- ^ Kind of the RHS - -> TyConParent - -> Maybe (TyCon, [Type]) -- ^ family instance if applicable + -> Kind -- ^ Kind of the RHS + -> TyConParent -> TcRnIf m n TyCon -buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family - | Just fam_inst_info <- mb_family - = ASSERT( isNoParent parent ) - fixM $ \ tycon_rec -> do - { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec - ; return (mkSynTyCon tc_name kind tvs rhs fam_parent) } - - | otherwise +buildSynTyCon tc_name tvs rhs rhs_kind parent = return (mkSynTyCon tc_name kind tvs rhs parent) where kind = mkPiKinds tvs rhs_kind ------------------------------------------------------ -buildAlgTyCon :: Name -> [TyVar] -- ^ Kind variables adn type variables - -> ThetaType -- ^ Stupid theta +buildAlgTyCon :: Name + -> [TyVar] -- ^ Kind variables and type variables + -> ThetaType -- ^ Stupid theta -> AlgTyConRhs -> RecFlag - -> Bool -- ^ True <=> was declared in GADT syntax + -> Bool -- ^ True <=> was declared in GADT syntax -> TyConParent - -> Maybe (TyCon, [Type]) -- ^ family instance if applicable - -> TcRnIf m n TyCon - -buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn - parent mb_family - | Just fam_inst_info <- mb_family - = -- We need to tie a knot as the coercion of a data instance depends - -- on the instance representation tycon and vice versa. - ASSERT( isNoParent parent ) - fixM $ \ tycon_rec -> do - { fam_parent <- mkFamInstParentInfo tc_name ktvs fam_inst_info tycon_rec - ; return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs - fam_parent is_rec gadt_syn) } - - | otherwise - = return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs - parent is_rec gadt_syn) - where kind = mkPiKinds ktvs liftedTypeKind - --- | If a family tycon with instance types is given, the current tycon is an --- instance of that family and we need to --- --- (1) create a coercion that identifies the family instance type and the --- representation type from Step (1); ie, it is of the form --- `Co tvs :: F ts ~ R tvs', where `Co' is the name of the coercion, --- `F' the family tycon and `R' the (derived) representation tycon, --- and --- (2) produce a `TyConParent' value containing the parent and coercion --- information. --- -mkFamInstParentInfo :: Name -> [TyVar] - -> (TyCon, [Type]) - -> TyCon - -> TcRnIf m n TyConParent -mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon - = do { -- Create the coercion - ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc - ; let co_tycon = mkFamInstCo co_tycon_name tvs - family instTys rep_tycon - ; return $ FamInstTyCon family instTys co_tycon } - + -> TyCon + +buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn parent + = mkAlgTyCon tc_name kind ktvs stupid_theta rhs parent is_rec gadt_syn + where + kind = mkPiKinds ktvs liftedTypeKind + ------------------------------------------------------ distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs distinctAbstractTyConRhs = AbstractTyCon True diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs index 611228e567..5e4a7092bf 100644 --- a/compiler/iface/FlagChecker.hs +++ b/compiler/iface/FlagChecker.hs @@ -41,7 +41,9 @@ fingerprintDynFlags DynFlags{..} nameio = -- -i, -osuf, -hcsuf, -hisuf, -odir, -hidir, -stubdir, -o, -ohi paths = (map normalise importPaths, [ objectSuf, hcSuf, hiSuf ], - [ objectDir, hiDir, stubDir, outputFile, outputHi ]) + [ objectDir, hiDir, stubDir, outputHi ]) + -- NB. not outputFile, we don't want "ghc --make M -o <file>" + -- to force recompilation when <file> changes. -- -fprof-auto etc. prof = if opt_SccProfilingOn then fromEnum profAuto else 0 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 541f041589..f01c3b63b3 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -20,13 +20,13 @@ module IfaceSyn ( IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, - IfaceInst(..), IfaceFamInst(..), IfaceTickish(..), + IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), -- Misc - ifaceDeclSubBndrs, visibleIfConDecls, + ifaceDeclImplicitBndrs, visibleIfConDecls, -- Free Names - freeNamesIfDecl, freeNamesIfRule, + freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, -- Pretty printing pprIfaceExpr, pprIfaceDeclHead @@ -70,26 +70,19 @@ data IfaceDecl | IfaceData { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifCtxt :: IfaceContext, -- The "stupid theta" - ifCons :: IfaceConDecls, -- Includes new/data info + ifCons :: IfaceConDecls, -- Includes new/data/data family info ifRec :: RecFlag, -- Recursive or not? ifGadtSyntax :: Bool, -- True <=> declared using -- GADT syntax - ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) - -- Just <=> instance of family - -- Invariant: - -- ifCons /= IfOpenDataTyCon - -- for family instances + ifAxiom :: Maybe IfExtName -- The axiom, for a newtype, + -- or data/newtype family instance } | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) - ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn - -- Nothing for an open family - ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) - -- Just <=> instance of family - -- Invariant: ifOpenSyn == False - -- for family instances + ifSynRhs :: Maybe IfaceType -- Just rhs for an ordinary synonyn + -- Nothing for an type family declaration } | IfaceClass { ifCtxt :: IfaceContext, -- Context... @@ -102,6 +95,11 @@ data IfaceDecl -- with the class recursive? } + | IfaceAxiom { ifName :: OccName -- Axiom name + , ifTyVars :: [IfaceTvBndr] -- Axiom tyvars + , ifLHS :: IfaceType -- Axiom LHS + , ifRHS :: IfaceType } -- and RHS + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move -- beyond .NET ifExtName :: Maybe FastString } @@ -123,13 +121,13 @@ data IfaceATDefault = IfaceATD [IfaceTvBndr] [IfaceType] IfaceType data IfaceConDecls = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon - | IfOpenDataTyCon -- Open data family - | IfDataTyCon [IfaceConDecl] -- data type decls - | IfNewTyCon IfaceConDecl -- newtype decls + | IfDataFamTyCon -- Data family + | IfDataTyCon [IfaceConDecl] -- Data type decls + | IfNewTyCon IfaceConDecl -- Newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls (IfAbstractTyCon {}) = [] -visibleIfConDecls IfOpenDataTyCon = [] +visibleIfConDecls IfDataFamTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] @@ -147,12 +145,12 @@ data IfaceConDecl ifConStricts :: [HsBang]} -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys -data IfaceInst - = IfaceInst { ifInstCls :: IfExtName, -- See comments with - ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance - ifDFun :: IfExtName, -- The dfun - ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: Maybe OccName } -- See Note [Orphans] +data IfaceClsInst + = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: Maybe OccName } -- See Note [Orphans] -- There's always a separate IfaceDecl for the DFun, which gives -- its IdInfo with its full type and version number. -- The instance declarations taken together have a version number, @@ -161,9 +159,10 @@ data IfaceInst -- and if the head does not change it won't be used if it wasn't before data IfaceFamInst - = IfaceFamInst { ifFamInstFam :: IfExtName -- Family tycon + = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types - , ifFamInstTyCon :: IfaceTyCon -- Instance decl + , ifFamInstAxiom :: IfExtName -- The axiom + , ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst } data IfaceRule @@ -175,7 +174,7 @@ data IfaceRule ifRuleArgs :: [IfaceExpr], -- Args of LHS ifRuleRhs :: IfaceExpr, ifRuleAuto :: Bool, - ifRuleOrph :: Maybe OccName -- Just like IfaceInst + ifRuleOrph :: Maybe OccName -- Just like IfaceClsInst } data IfaceAnnotation @@ -375,38 +374,34 @@ See [http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationA -- ----------------------------------------------------------------------------- -- Utils on IfaceSyn -ifaceDeclSubBndrs :: IfaceDecl -> [OccName] +ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] -- *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon +-- See Note [Implicit TyThings] in HscTypes -- N.B. the set of names returned here *must* match the set of -- TyThings returned by HscTypes.implicitTyThings, in the sense that -- TyThing.getOccName should define a bijection between the two lists. -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) -- The order of the list does not matter. -ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon {}} = [] +ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = [] -- Newtype -ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, +ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, ifCons = IfNewTyCon ( - IfCon { ifConOcc = con_occ }), - ifFamInst = famInst}) - = -- implicit coerion and (possibly) family instance coercion - (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++ + IfCon { ifConOcc = con_occ })}) + = -- implicit newtype coercion + (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit -- data constructor and worker (newtypes don't have a wrapper) [con_occ, mkDataConWorkerOcc con_occ] -ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, - ifCons = IfDataTyCon cons, - ifFamInst = famInst}) - = -- (possibly) family instance coercion; - -- there is no implicit coercion for non-newtypes - famInstCo famInst tc_occ - -- for each data constructor in order, - -- data constructor, worker, and (possibly) wrapper - ++ concatMap dc_occs cons +ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ, + ifCons = IfDataTyCon cons }) + = -- for each data constructor in order, + -- data constructor, worker, and (possibly) wrapper + concatMap dc_occs cons where dc_occs con_decl | has_wrapper = [con_occ, work_occ, wrap_occ] @@ -418,7 +413,7 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, has_wrapper = ifConWrapper con_decl -- This is the reason for -- having the ifConWrapper field! -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, +ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, ifSigs = sigs, ifATs = ats }) = -- (possibly) newtype coercion co_occs ++ @@ -441,16 +436,7 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, dc_occ = mkClassDataConOcc cls_tc_occ is_newtype = n_sigs + n_ctxt == 1 -- Sigh -ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ, - ifFamInst = famInst}) - = famInstCo famInst tc_occ - -ifaceDeclSubBndrs _ = [] - --- coercion for data/newtype family instances -famInstCo :: Maybe (IfaceTyCon, [IfaceType]) -> OccName -> [OccName] -famInstCo Nothing _ = [] -famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc] +ifaceDeclImplicitBndrs _ = [] ----------------------------- Printing IfaceDecl ------------------------------ @@ -468,10 +454,9 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Just mono_ty, - ifFamInst = mbFamInst}) + ifSynRhs = Just mono_ty}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) - 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst]) + 4 (vcat [equals <+> ppr mono_ty]) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = Nothing, ifSynKind = kind }) @@ -480,14 +465,14 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, - ifRec = isrec, ifFamInst = mbFamInst}) + ifRec = isrec, ifAxiom = mbAxiom}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 4 (vcat [pprRec isrec, pp_condecls tycon condecls, - pprFamily mbFamInst]) + pprAxiom mbAxiom]) where pp_nd = case condecls of IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis) - IfOpenDataTyCon -> ptext (sLit "data family") + IfDataFamTyCon -> ptext (sLit "data family") IfDataTyCon _ -> ptext (sLit "data") IfNewTyCon _ -> ptext (sLit "newtype") @@ -499,12 +484,17 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, sep (map ppr ats), sep (map ppr sigs)]) +pprIfaceDecl (IfaceAxiom {ifName = name, ifTyVars = tyvars, + ifLHS = lhs, ifRHS = rhs}) + = hang (ptext (sLit "axiom") <+> ppr name <+> ppr tyvars) + 2 (dcolon <+> ppr lhs <+> text "~#" <+> ppr rhs) + pprRec :: RecFlag -> SDoc pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec -pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc -pprFamily Nothing = ptext (sLit "FamilyInstance: none") -pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst +pprAxiom :: Maybe Name -> SDoc +pprAxiom Nothing = ptext (sLit "FamilyInstance: none") +pprAxiom (Just ax) = ptext (sLit "FamilyInstance:") <+> ppr ax instance Outputable IfaceClassOp where ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty @@ -522,7 +512,7 @@ pprIfaceDeclHead context thing tyvars pp_condecls :: OccName -> IfaceConDecls -> SDoc pp_condecls _ (IfAbstractTyCon {}) = empty -pp_condecls _ IfOpenDataTyCon = empty +pp_condecls _ IfDataFamTyCon = empty pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) (map (pprIfaceConDecl tc) cs)) @@ -571,8 +561,8 @@ instance Outputable IfaceRule where ptext (sLit "=") <+> ppr rhs]) ] -instance Outputable IfaceInst where - ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, +instance Outputable IfaceClsInst where + ppr (IfaceClsInst {ifDFun = dfun_id, ifOFlag = flag, ifInstCls = cls, ifInstTys = mb_tcs}) = hang (ptext (sLit "instance") <+> ppr flag <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) @@ -580,10 +570,10 @@ instance Outputable IfaceInst where instance Outputable IfaceFamInst where ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, - ifFamInstTyCon = tycon_id}) + ifFamInstAxiom = tycon_ax}) = hang (ptext (sLit "family instance") <+> ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) - 2 (equals <+> ppr tycon_id) + 2 (equals <+> ppr tycon_ax) ppr_rough :: Maybe IfaceTyCon -> SDoc ppr_rough Nothing = dot @@ -741,13 +731,12 @@ freeNamesIfDecl IfaceForeign{} = emptyNameSet freeNamesIfDecl d@IfaceData{} = freeNamesIfTvBndrs (ifTyVars d) &&& - freeNamesIfTcFam (ifFamInst d) &&& + maybe emptyNameSet unitNameSet (ifAxiom d) &&& freeNamesIfContext (ifCtxt d) &&& freeNamesIfConDecls (ifCons d) freeNamesIfDecl d@IfaceSyn{} = freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfSynRhs (ifSynRhs d) &&& - freeNamesIfTcFam (ifFamInst d) &&& freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we -- return names in the kind signature freeNamesIfDecl d@IfaceClass{} = @@ -755,6 +744,10 @@ freeNamesIfDecl d@IfaceClass{} = freeNamesIfContext (ifCtxt d) &&& fnList freeNamesIfAT (ifATs d) &&& fnList freeNamesIfClsSig (ifSigs d) +freeNamesIfDecl d@IfaceAxiom{} = + freeNamesIfTvBndrs (ifTyVars d) &&& + freeNamesIfType (ifLHS d) &&& + freeNamesIfType (ifRHS d) freeNamesIfIdDetails :: IfaceIdDetails -> NameSet freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc @@ -765,12 +758,6 @@ freeNamesIfSynRhs :: Maybe IfaceType -> NameSet freeNamesIfSynRhs (Just ty) = freeNamesIfType ty freeNamesIfSynRhs Nothing = emptyNameSet -freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet -freeNamesIfTcFam (Just (tc,tys)) = - freeNamesIfTc tc &&& fnList freeNamesIfType tys -freeNamesIfTcFam Nothing = - emptyNameSet - freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType @@ -903,6 +890,12 @@ freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es &&& freeNamesIfExpr rhs + +freeNamesIfFamInst :: IfaceFamInst -> NameSet +freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName + , ifFamInstAxiom = axName }) + = unitNameSet famName &&& + unitNameSet axName -- helpers (&&&) :: NameSet -> NameSet -> NameSet diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 7df2f49778..ec1205f83d 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -236,7 +236,7 @@ loadInterface doc_str mod from -- -- The main thing is to add the ModIface to the PIT, but -- we also take the - -- IfaceDecls, IfaceInst, IfaceFamInst, IfaceRules, IfaceVectInfo + -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, IfaceVectInfo -- out of the ModIface and put them into the big EPS pools -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined @@ -372,7 +372,7 @@ loadDecl ignore_prags mod (_version, decl) -- the names associated with the decl main_name <- lookupOrig mod (ifName decl) -- ; traceIf (text "Loading decl for " <> ppr main_name) - ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs decl) + ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl) -- Typecheck the thing, lazily -- NB. Firstly, the laziness is there in case we never need the @@ -402,7 +402,7 @@ loadDecl ignore_prags mod (_version, decl) -- (where the "MkT" is the *Name* associated with MkT, etc.) -- -- We do this by mapping the implict_names to the associated - -- TyThings. By the invariant on ifaceDeclSubBndrs and + -- TyThings. By the invariant on ifaceDeclImplicitBndrs and -- implicitTyThings, we can use getOccName on the implicit -- TyThings to make this association: each Name's OccName should -- be the OccName of exactly one implictTyThing. So the key is diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 2125181e6d..4e8c96b962 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -68,6 +68,7 @@ import CoreFVs import Class import Kind import TyCon +import Coercion ( coAxiomSplitLHS ) import DataCon import Type import TcType @@ -261,8 +262,9 @@ mkIface_ hsc_env maybe_old_fingerprint ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts ; iface_vect_info = flattenVectInfo vect_info - -- Check if we are in Safe Inference mode but we failed to pass - -- the muster + + -- Check if we are in Safe Inference mode + -- but we failed to pass the muster ; safeMode = if safeInferOn dflags && not safeInf then Sf_None else safeHaskell dflags @@ -361,7 +363,7 @@ mkIface_ hsc_env maybe_old_fingerprint deliberatelyOmitted :: String -> a deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) - ifFamInstTcName = ifaceTyConName . ifFamInstTyCon + ifFamInstTcName = ifFamInstFam flattenVectInfo (VectInfo { vectInfoVar = vVar , vectInfoTyCon = vTyCon @@ -430,7 +432,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- see IfaceDeclABI below. declABI :: IfaceDecl -> IfaceDeclABI declABI decl = (this_mod, decl, extras) - where extras = declExtras fix_fn non_orph_rules non_orph_insts decl + where extras = declExtras fix_fn non_orph_rules non_orph_insts + non_orph_fis decl edges :: [(IfaceDeclABI, Unique, [Unique])] edges = [ (abi, getUnique (ifName decl), out) @@ -451,7 +454,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls parent_map :: OccEnv OccName parent_map = foldr extend emptyOccEnv new_decls where extend d env = - extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ] + extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] where n = ifName d -- strongly-connected groups of declarations, in dependency order @@ -473,8 +476,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls | otherwise = ASSERT2( isExternalName name, ppr name ) let hash | nameModule name /= this_mod = global_hash_fn name - | otherwise = - snd (lookupOccEnv local_env (getOccName name) + | otherwise = snd (lookupOccEnv local_env (getOccName name) `orElse` pprPanic "urk! lookup local fingerprint" (ppr name)) -- (undefined,fingerprint0)) -- This panic indicates that we got the dependency @@ -484,8 +486,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- pprTraces below, run the compile again, and inspect -- the output and the generated .hi file with -- --show-iface. - in - put_ bh hash + in put_ bh hash -- take a strongly-connected group of declarations and compute -- its fingerprint. @@ -530,7 +531,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -> IO (OccEnv (OccName,Fingerprint)) extend_hash_env env0 (hash,d) = do let - sub_bndrs = ifaceDeclSubBndrs d + sub_bndrs = ifaceDeclImplicitBndrs d fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ) -- sub_fps <- mapM fp_sub_bndr sub_bndrs @@ -561,7 +562,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods orphan_hash <- computeFingerprint (mk_put_name local_env) - (map ifDFun orph_insts, orph_rules, fam_insts) + (map ifDFun orph_insts, orph_rules, orph_fis) -- the export list hash doesn't depend on the fingerprints of -- the Names it mentions, only the Names themselves, hence putNameLiterally. @@ -619,7 +620,9 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls mi_exp_hash = export_hash, mi_orphan_hash = orphan_hash, mi_flag_hash = flag_hash, - mi_orphan = not (null orph_rules && null orph_insts + mi_orphan = not ( null orph_rules + && null orph_insts + && null orph_fis && null (ifaceVectInfoVar (mi_vect_info iface0))), mi_finsts = not . null $ mi_fam_insts iface0, mi_decls = sorted_decls, @@ -631,12 +634,9 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls this_mod = mi_module iface0 dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags - (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) - (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) - -- See Note [Orphans] in IfaceSyn - -- ToDo: shouldn't we be splitting fam_insts into orphans and - -- non-orphans? - fam_insts = mi_fam_insts iface0 + (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) + (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) + (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0) fix_fn = mi_fix_fn iface0 @@ -700,7 +700,7 @@ data IfaceDeclExtras | IfaceDataExtras Fixity -- Fixity of the tycon itself - [IfaceInstABI] -- Local instances of this tycon + [IfaceInstABI] -- Local class and family instances of this tycon -- See Note [Orphans] in IfaceSyn [(Fixity,[IfaceRule])] -- For each construcotr, fixity and RULES @@ -711,10 +711,16 @@ data IfaceDeclExtras -- See Note [Orphans] in IfaceSyn [(Fixity,[IfaceRule])] -- For each class method, fixity and RULES - | IfaceSynExtras Fixity + | IfaceSynExtras Fixity [IfaceInstABI] | IfaceOtherDeclExtras +-- When hashing a class or family instance, we hash only the +-- DFunId or CoAxiom, because that depends on all the +-- information about the instance. +-- +type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance + abiDecl :: IfaceDeclABI -> IfaceDecl abiDecl (_, decl, _) = decl @@ -733,8 +739,8 @@ freeNamesDeclExtras (IfaceDataExtras _ insts subs) = unionManyNameSets (mkNameSet insts : map freeNamesSub subs) freeNamesDeclExtras (IfaceClassExtras _ insts subs) = unionManyNameSets (mkNameSet insts : map freeNamesSub subs) -freeNamesDeclExtras (IfaceSynExtras _) - = emptyNameSet +freeNamesDeclExtras (IfaceSynExtras _ insts) + = mkNameSet insts freeNamesDeclExtras IfaceOtherDeclExtras = emptyNameSet @@ -744,9 +750,9 @@ freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules) instance Outputable IfaceDeclExtras where ppr IfaceOtherDeclExtras = empty ppr (IfaceIdExtras fix rules) = ppr_id_extras fix rules - ppr (IfaceSynExtras fix) = ppr fix - ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts, - ppr_id_extras_s stuff] + ppr (IfaceSynExtras fix finsts) = vcat [ppr fix, ppr finsts] + ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts, + ppr_id_extras_s stuff] ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts, ppr_id_extras_s stuff] @@ -768,24 +774,26 @@ instance Binary IfaceDeclExtras where putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons put_ bh (IfaceClassExtras fix insts methods) = do putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods - put_ bh (IfaceSynExtras fix) = do - putByte bh 4; put_ bh fix + put_ bh (IfaceSynExtras fix finsts) = do + putByte bh 4; put_ bh fix; put_ bh finsts put_ bh IfaceOtherDeclExtras = do putByte bh 5 declExtras :: (OccName -> Fixity) -> OccEnv [IfaceRule] - -> OccEnv [IfaceInst] + -> OccEnv [IfaceClsInst] + -> OccEnv [IfaceFamInst] -> IfaceDecl -> IfaceDeclExtras -declExtras fix_fn rule_env inst_env decl +declExtras fix_fn rule_env inst_env fi_env decl = case decl of IfaceId{} -> IfaceIdExtras (fix_fn n) (lookupOccEnvL rule_env n) IfaceData{ifCons=cons} -> IfaceDataExtras (fix_fn n) - (map ifDFun $ lookupOccEnvL inst_env n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ + map ifDFun (lookupOccEnvL inst_env n)) (map (id_extras . ifConOcc) (visibleIfConDecls cons)) IfaceClass{ifSigs=sigs, ifATs=ats} -> IfaceClassExtras (fix_fn n) @@ -794,18 +802,14 @@ declExtras fix_fn rule_env inst_env decl -- Include instances of the associated types -- as well as instances of the class (Trac #5147) [id_extras op | IfaceClassOp op _ _ <- sigs] - IfaceSyn{} -> IfaceSynExtras (fix_fn n) + IfaceSyn{} -> IfaceSynExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n)) _other -> IfaceOtherDeclExtras where n = ifName decl id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ) at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl) --- --- When hashing an instance, we hash only the DFunId, because that --- depends on all the information about the instance. --- -type IfaceInstABI = IfExtName lookupOccEnvL :: OccEnv [v] -> OccName -> [v] lookupOccEnvL env k = lookupOccEnv env k `orElse` [] @@ -837,7 +841,7 @@ oldMD5 dflags bh = do return $! readHexFingerprint hash_str -} -instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg +instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg instOrphWarn unqual inst = mkWarnMsg (getSrcSpan inst) unqual $ hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst) @@ -1419,9 +1423,7 @@ tyThingToIfaceDecl (ATyCon tycon) = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, ifSynRhs = syn_rhs, - ifSynKind = syn_ki, - ifFamInst = famInstToIface (tyConFamInst_maybe tycon) - } + ifSynKind = syn_ki } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, @@ -1430,7 +1432,7 @@ tyThingToIfaceDecl (ATyCon tycon) ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifFamInst = famInstToIface (tyConFamInst_maybe tycon)} + ifAxiom = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) } | isForeignTyCon tycon = IfaceForeign { ifName = getOccName tycon, @@ -1448,7 +1450,7 @@ tyThingToIfaceDecl (ATyCon tycon) IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls DataFamilyTyCon {} = IfOpenDataTyCon + ifaceConDecls DataFamilyTyCon {} = IfDataFamTyCon ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct -- The last case happens when a TyCon has been trimmed during tidying -- Furthermore, tyThingToIfaceDecl is also used @@ -1472,11 +1474,16 @@ tyThingToIfaceDecl (ATyCon tycon) to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec] - famInstToIface Nothing = Nothing - famInstToIface (Just (famTyCon, instTys)) = - Just (toIfaceTyCon famTyCon, map toIfaceType instTys) - -tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c) +tyThingToIfaceDecl (ACoAxiom ax) + = IfaceAxiom { ifName = name + , ifTyVars = tv_bndrs + , ifLHS = lhs + , ifRHS = rhs } + where + name = getOccName ax + tv_bndrs = toIfaceTvBndrs (coAxiomTyVars ax) + lhs = toIfaceType (coAxiomLHS ax) + rhs = toIfaceType (coAxiomRHS ax) tyThingToIfaceDecl (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier @@ -1527,11 +1534,11 @@ getFS :: NamedThing a => a -> FastString getFS x = occNameFS (getOccName x) -------------------------- -instanceToIfaceInst :: Instance -> IfaceInst -instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, +instanceToIfaceInst :: ClsInst -> IfaceClsInst +instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag, is_cls = cls_name, is_tcs = mb_tcs }) = ASSERT( cls_name == className cls ) - IfaceInst { ifDFun = dfun_name, + IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag, ifInstCls = cls_name, ifInstTys = map do_rough mb_tcs, @@ -1569,16 +1576,34 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, -------------------------- famInstToIfaceFamInst :: FamInst -> IfaceFamInst -famInstToIfaceFamInst (FamInst { fi_tycon = tycon, - fi_fam = fam, - fi_tcs = mb_tcs }) - = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon - , ifFamInstFam = fam - , ifFamInstTys = map do_rough mb_tcs } +famInstToIfaceFamInst (FamInst { fi_axiom = axiom, + fi_fam = fam, + fi_tcs = mb_tcs }) + = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom + , ifFamInstFam = fam + , ifFamInstTys = map do_rough mb_tcs + , ifFamInstOrph = orph } where do_rough Nothing = Nothing do_rough (Just n) = Just (toIfaceTyCon_name n) + fam_decl = tyConName . fst $ coAxiomSplitLHS axiom + mod = ASSERT( isExternalName (coAxiomName axiom) ) + nameModule (coAxiomName axiom) + is_local name = nameIsLocalOrFrom mod name + + lhs_names = filterNameSet is_local (orphNamesOfType (coAxiomLHS axiom)) + + orph | is_local fam_decl + = Just (nameOccName fam_decl) + + | not (isEmptyNameSet lhs_names) + = Just (nameOccName (head (nameSetToList lhs_names))) + + + | otherwise + = Nothing + -------------------------- toIfaceLetBndr :: Id -> IfaceLetBndr toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index e981995bd4..c04d7284c5 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -436,31 +436,41 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, - ifFamInst = mb_family }) + ifAxiom = mb_axiom_name }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; tycon <- fixM ( \ tycon -> do + ; tycon <- fixM $ \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt + ; parent' <- tc_parent tyvars mb_axiom_name ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons - ; mb_fam_inst <- tcFamInst mb_family - ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec - gadt_syn parent mb_fam_inst - }) + ; return (buildAlgTyCon tc_name tyvars stupid_theta + cons is_rec gadt_syn parent') } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } + where + tc_parent :: [TyVar] -> Maybe Name -> IfL TyConParent + tc_parent _ Nothing = return parent + tc_parent tyvars (Just ax_name) + = ASSERT( isNoParent parent ) + do { ax <- tcIfaceCoAxiom ax_name + ; let (fam_tc, fam_tys) = coAxiomSplitLHS ax + subst = zipTopTvSubst (coAxiomTyVars ax) (mkTyVarTys tyvars) + -- The subst matches the tyvar of the TyCon + -- with those from the CoAxiom. They aren't + -- necessarily the same, since the two may be + -- gotten from separate interface-file declarations + ; return (FamInstTyCon ax fam_tc (substTys subst fam_tys)) } tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ifSynRhs = mb_rhs_ty, - ifSynKind = kind, ifFamInst = mb_family}) + ifSynKind = kind }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tc_syn_rhs mb_rhs_ty - ; fam_info <- tcFamInst mb_family - ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent fam_info - ; return (ATyCon tycon) - } + ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent + ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type syonym") <+> ppr n tc_syn_rhs Nothing = return SynFamilyTyCon @@ -493,14 +503,10 @@ tc_iface_decl _parent ignore_prags ; return (op_name, dm, op_ty) } tc_at cls (IfaceAT tc_decl defs_decls) - = do tc <- tc_iface_tc_decl (AssocFamilyTyCon cls) tc_decl + = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl defs <- mapM tc_iface_at_def defs_decls return (tc, defs) - tc_iface_tc_decl parent decl = do - ATyCon tc <- tc_iface_decl parent ignore_prags decl - return tc - tc_iface_at_def (IfaceATD tvs pat_tys ty) = bindIfaceTyVars_AT tvs $ \tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan) @@ -517,17 +523,25 @@ tc_iface_decl _ _ (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) } +tc_iface_decl _ _ (IfaceAxiom {ifName = tc_occ, ifTyVars = tv_bndrs, + ifLHS = lhs, ifRHS = rhs }) + = bindIfaceTyVars tv_bndrs $ \ tvs -> do + { tc_name <- lookupIfaceTop tc_occ + ; tc_lhs <- tcIfaceType lhs + ; tc_rhs <- tcIfaceType rhs + ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name + , co_ax_name = tc_name + , co_ax_implicit = False + , co_ax_tvs = tvs + , co_ax_lhs = tc_lhs + , co_ax_rhs = tc_rhs } + ; return (ACoAxiom axiom) } tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs tcIfaceDataCons tycon_name tycon _ if_cons = case if_cons of IfAbstractTyCon dis -> return (AbstractTyCon dis) - IfOpenDataTyCon -> return DataFamilyTyCon + IfDataFamTyCon -> return DataFamilyTyCon IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con @@ -603,8 +617,8 @@ look at it. %************************************************************************ \begin{code} -tcIfaceInst :: IfaceInst -> IfL Instance -tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, +tcIfaceInst :: IfaceClsInst -> IfL ClsInst +tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag, ifInstCls = cls, ifInstTys = mb_tcs }) = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ tcIfaceExtId dfun_occ @@ -612,14 +626,12 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, ; return (mkImportedInstance cls mb_tcs' dfun oflag) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst -tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, - ifFamInstFam = fam, ifFamInstTys = mb_tcs }) --- { tycon' <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $ --- the above line doesn't work, but this below does => CPP in Haskell = evil! - = do tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ - tcIfaceTyCon tycon +tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = axiom_name } ) + = do axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $ + tcIfaceCoAxiom axiom_name let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - return (mkImportedFamInst fam mb_tcs' tycon') + return (mkImportedFamInst fam mb_tcs' axiom') \end{code} diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot index a9684a6a91..591419a251 100644 --- a/compiler/iface/TcIface.lhs-boot +++ b/compiler/iface/TcIface.lhs-boot @@ -1,10 +1,10 @@ \begin{code} module TcIface where -import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) +import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) import TypeRep ( TyThing ) import TcRnTypes ( IfL ) -import InstEnv ( Instance ) +import InstEnv ( ClsInst ) import FamInstEnv ( FamInst ) import CoreSyn ( CoreRule ) import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo ) @@ -14,7 +14,7 @@ import Annotations ( Annotation ) tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo -tcIfaceInst :: IfaceInst -> IfL Instance +tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] \end{code} |