diff options
Diffstat (limited to 'compiler/iface/IfaceSyn.lhs')
| -rw-r--r-- | compiler/iface/IfaceSyn.lhs | 1897 |
1 files changed, 1098 insertions, 799 deletions
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 1283b095fd..935b8eda93 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -4,7 +4,8 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -15,13 +16,14 @@ module IfaceSyn ( module IfaceType, IfaceDecl(..), IfaceSynTyConRhs(..), IfaceClassOp(..), IfaceAT(..), - IfaceConDecl(..), IfaceConDecls(..), + IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceBang(..), IfaceAxBranch(..), + IfaceTyConParent(..), -- Misc ifaceDeclImplicitBndrs, visibleIfConDecls, @@ -31,7 +33,9 @@ module IfaceSyn ( freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, -- Pretty printing - pprIfaceExpr + pprIfaceExpr, + pprIfaceDecl, + ShowSub(..), ShowHowMuch(..) ) where #include "HsVersions.h" @@ -51,14 +55,17 @@ import BasicTypes import Outputable import FastString import Module -import TysWiredIn ( eqTyConName ) import Fingerprint import Binary import BooleanFormula ( BooleanFormula ) import HsBinds +import TyCon (Role (..)) +import StaticFlags (opt_PprStyle_Debug) +import Util( filterOut ) import Control.Monad import System.IO.Unsafe +import Data.Maybe (isJust) infixl 3 &&& \end{code} @@ -66,18 +73,27 @@ infixl 3 &&& %************************************************************************ %* * - Data type declarations + Declarations %* * %************************************************************************ \begin{code} +type IfaceTopBndr = OccName + -- It's convenient to have an OccName in the IfaceSyn, altough in each + -- case the namespace is implied by the context. However, having an + -- OccNames makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints + -- very convenient. + -- + -- We don't serialise the namespace onto the disk though; rather we + -- drop it when serialising and add it back in when deserialising. + data IfaceDecl - = IfaceId { ifName :: OccName, + = IfaceId { ifName :: IfaceTopBndr, ifType :: IfaceType, ifIdDetails :: IfaceIdDetails, ifIdInfo :: IfaceIdInfo } - | IfaceData { ifName :: OccName, -- Type constructor + | IfaceData { ifName :: IfaceTopBndr, -- Type constructor ifCType :: Maybe CType, -- C type for CAPI FFI ifTyVars :: [IfaceTvBndr], -- Type variables ifRoles :: [Role], -- Roles @@ -87,355 +103,115 @@ data IfaceDecl ifPromotable :: Bool, -- Promotable to kind level? ifGadtSyntax :: Bool, -- True <=> declared using -- GADT syntax - ifAxiom :: Maybe IfExtName -- The axiom, for a newtype, - -- or data/newtype family instance + ifParent :: IfaceTyConParent -- The axiom, for a newtype, + -- or data/newtype family instance } - | IfaceSyn { ifName :: OccName, -- Type constructor + | IfaceSyn { ifName :: IfaceTopBndr, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifRoles :: [Role], -- Roles ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) ifSynRhs :: IfaceSynTyConRhs } - | IfaceClass { ifCtxt :: IfaceContext, -- Context... - ifName :: OccName, -- Name of the class TyCon - ifTyVars :: [IfaceTvBndr], -- Type variables - ifRoles :: [Role], -- Roles - ifFDs :: [FunDep FastString], -- Functional dependencies - ifATs :: [IfaceAT], -- Associated type families - ifSigs :: [IfaceClassOp], -- Method signatures - ifMinDef :: BooleanFormula OccName, -- Minimal complete definition - ifRec :: RecFlag -- Is newtype/datatype associated - -- with the class recursive? + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: IfaceTopBndr, -- Name of the class TyCon + ifTyVars :: [IfaceTvBndr], -- Type variables + ifRoles :: [Role], -- Roles + ifFDs :: [FunDep FastString], -- Functional dependencies + ifATs :: [IfaceAT], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifMinDef :: BooleanFormula IfLclName, -- Minimal complete definition + ifRec :: RecFlag -- Is newtype/datatype associated + -- with the class recursive? } - | IfaceAxiom { ifName :: OccName, -- Axiom name + | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name ifTyCon :: IfaceTyCon, -- LHS TyCon ifRole :: Role, -- Role of axiom ifAxBranches :: [IfaceAxBranch] -- Branches } - | IfaceForeign { ifName :: OccName, -- Needs expanding when we move + | IfaceForeign { ifName :: IfaceTopBndr, -- Needs expanding when we move -- beyond .NET ifExtName :: Maybe FastString } - | IfacePatSyn { ifName :: OccName, -- Name of the pattern synonym - ifPatHasWrapper :: Bool, + | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym ifPatIsInfix :: Bool, + ifPatMatcher :: IfExtName, + ifPatWrapper :: Maybe IfExtName, + -- Everything below is redundant, + -- but needed to implement pprIfaceDecl ifPatUnivTvs :: [IfaceTvBndr], ifPatExTvs :: [IfaceTvBndr], ifPatProvCtxt :: IfaceContext, ifPatReqCtxt :: IfaceContext, - ifPatArgs :: [IfaceIdBndr], + ifPatArgs :: [IfaceType], ifPatTy :: IfaceType } --- A bit of magic going on here: there's no need to store the OccName --- for a decl on the disk, since we can infer the namespace from the --- context; however it is useful to have the OccName in the IfaceDecl --- to avoid re-building it in various places. So we build the OccName --- when de-serialising. - -instance Binary IfaceDecl where - put_ bh (IfaceId name ty details idinfo) = do - putByte bh 0 - put_ bh (occNameFS name) - put_ bh ty - put_ bh details - put_ bh idinfo - - put_ _ (IfaceForeign _ _) = - error "Binary.put_(IfaceDecl): IfaceForeign" - - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do - putByte bh 2 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - put_ bh a10 - - put_ bh (IfaceSyn a1 a2 a3 a4 a5) = 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 a8 a9) = do - putByte bh 4 - put_ bh a1 - put_ bh (occNameFS a2) - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - - put_ bh (IfaceAxiom a1 a2 a3 a4) = do - putByte bh 5 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9) = do - putByte bh 6 - put_ bh (occNameFS name) - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - - get bh = do - h <- getByte bh - case h of - 0 -> do name <- get bh - ty <- get bh - details <- get bh - idinfo <- get bh - occ <- return $! mkOccNameFS varName name - return (IfaceId occ ty details idinfo) - 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - a10 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9 a10) - 3 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceSyn occ a2 a3 a4 a5) - 4 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - occ <- return $! mkOccNameFS clsName a2 - return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9) - 5 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceAxiom occ a2 a3 a4) - 6 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - occ <- return $! mkOccNameFS dataName a1 - return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9) - _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) +data IfaceTyConParent + = IfNoParent + | IfDataInstance IfExtName + IfaceTyCon + IfaceTcArgs data IfaceSynTyConRhs = IfaceOpenSynFamilyTyCon - | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom + | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom + [IfaceAxBranch] -- for pretty printing purposes only | IfaceAbstractClosedSynFamilyTyCon | IfaceSynonymTyCon IfaceType + | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only -instance Binary IfaceSynTyConRhs where - put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 - put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax - put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2 - put_ bh (IfaceSynonymTyCon ty) = putByte bh 3 >> put_ bh ty - - get bh = do { h <- getByte bh - ; case h of - 0 -> return IfaceOpenSynFamilyTyCon - 1 -> do { ax <- get bh - ; return (IfaceClosedSynFamilyTyCon ax) } - 2 -> return IfaceAbstractClosedSynFamilyTyCon - _ -> do { ty <- get bh - ; return (IfaceSynonymTyCon ty) } } - -data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType +data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType -- Nothing => no default method -- Just False => ordinary polymorphic default method -- Just True => generic default method -instance Binary IfaceClassOp where - put_ bh (IfaceClassOp n def ty) = do - put_ bh (occNameFS n) - put_ bh def - put_ bh ty - get bh = do - n <- get bh - def <- get bh - ty <- get bh - occ <- return $! mkOccNameFS varName n - return (IfaceClassOp occ def ty) +data IfaceAT = IfaceAT -- See Class.ClassATItem + IfaceDecl -- The associated type declaration + (Maybe IfaceType) -- Default associated type instance, if any -data IfaceAT = IfaceAT - IfaceDecl -- The associated type declaration - [IfaceAxBranch] -- Default associated type instances, if any -instance Binary IfaceAT where - put_ bh (IfaceAT dec defs) = do - put_ bh dec - put_ bh defs - get bh = do - dec <- get bh - defs <- get bh - return (IfaceAT dec defs) - -instance Outputable IfaceAxBranch where - ppr = pprAxBranch Nothing - -pprAxBranch :: Maybe IfaceTyCon -> IfaceAxBranch -> SDoc -pprAxBranch mtycon (IfaceAxBranch { ifaxbTyVars = tvs - , ifaxbLHS = pat_tys - , ifaxbRHS = ty - , ifaxbIncomps = incomps }) - = ppr tvs <+> ppr_lhs <+> char '=' <+> ppr ty $+$ - nest 2 maybe_incomps - where - ppr_lhs - | Just tycon <- mtycon - = ppr (IfaceTyConApp tycon pat_tys) - | otherwise - = hsep (map ppr pat_tys) - - maybe_incomps - | [] <- incomps - = empty - - | otherwise - = parens (ptext (sLit "incompatible indices:") <+> ppr incomps) - --- this is just like CoAxBranch +-- This is just like CoAxBranch data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] - , ifaxbLHS :: [IfaceType] + , ifaxbLHS :: IfaceTcArgs , ifaxbRoles :: [Role] , ifaxbRHS :: IfaceType , ifaxbIncomps :: [BranchIndex] } -- See Note [Storing compatibility] in CoAxiom -instance Binary IfaceAxBranch where - put_ bh (IfaceAxBranch a1 a2 a3 a4 a5) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - return (IfaceAxBranch a1 a2 a3 a4 a5) - data IfaceConDecls = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon | IfDataFamTyCon -- Data family | IfDataTyCon [IfaceConDecl] -- Data type decls | IfNewTyCon IfaceConDecl -- Newtype decls -instance Binary IfaceConDecls where - put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d - 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 -> liftM IfAbstractTyCon $ get bh - 1 -> return IfDataFamTyCon - 2 -> liftM IfDataTyCon $ get bh - _ -> liftM IfNewTyCon $ get bh - -visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] -visibleIfConDecls (IfAbstractTyCon {}) = [] -visibleIfConDecls IfDataFamTyCon = [] -visibleIfConDecls (IfDataTyCon cs) = cs -visibleIfConDecls (IfNewTyCon c) = [c] - data IfaceConDecl = IfCon { - ifConOcc :: OccName, -- Constructor name + ifConOcc :: IfaceTopBndr, -- Constructor name ifConWrapper :: Bool, -- True <=> has a wrapper ifConInfix :: Bool, -- True <=> declared infix - ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars + + -- The universal type variables are precisely those + -- of the type constructor of this data constructor + -- This is *easy* to guarantee when creating the IfCon + -- but it's not so easy for the original TyCon/DataCon + -- So this guarantee holds for IfaceConDecl, but *not* for DataCon + ifConExTvs :: [IfaceTvBndr], -- Existential tyvars - ifConEqSpec :: [(OccName,IfaceType)], -- Equality constraints + ifConEqSpec :: IfaceEqSpec, -- Equality constraints ifConCtxt :: IfaceContext, -- Non-stupid context ifConArgTys :: [IfaceType], -- Arg types - ifConFields :: [OccName], -- ...ditto... (field labels) + ifConFields :: [IfaceTopBndr], -- ...ditto... (field labels) ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys -instance Binary IfaceConDecl where - put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - put_ bh a10 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - a10 <- get bh - return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) +type IfaceEqSpec = [(IfLclName,IfaceType)] data IfaceBang = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion -instance Binary IfaceBang where - put_ bh IfNoBang = putByte bh 0 - put_ bh IfStrict = putByte bh 1 - put_ bh IfUnpack = putByte bh 2 - put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co - - get bh = do - h <- getByte bh - case h of - 0 -> do return IfNoBang - 1 -> do return IfStrict - 2 -> do return IfUnpack - _ -> do { a <- get bh; return (IfUnpackCo a) } - data IfaceClsInst = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst @@ -449,21 +225,6 @@ data IfaceClsInst -- If this instance decl is *used*, we'll record a usage on the dfun; -- and if the head does not change it won't be used if it wasn't before -instance Binary IfaceClsInst where - put_ bh (IfaceClsInst cls tys dfun flag orph) = do - put_ bh cls - put_ bh tys - put_ bh dfun - put_ bh flag - put_ bh orph - get bh = do - cls <- get bh - tys <- get bh - dfun <- get bh - flag <- get bh - orph <- get bh - return (IfaceClsInst cls tys dfun flag orph) - -- The ifFamInstTys field of IfaceFamInst contains a list of the rough -- match types data IfaceFamInst @@ -473,19 +234,6 @@ data IfaceFamInst , ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst } -instance Binary IfaceFamInst where - put_ bh (IfaceFamInst fam tys name orph) = do - put_ bh fam - put_ bh tys - put_ bh name - put_ bh orph - get bh = do - fam <- get bh - tys <- get bh - name <- get bh - orph <- get bh - return (IfaceFamInst fam tys name orph) - data IfaceRule = IfaceRule { ifRuleName :: RuleName, @@ -498,82 +246,14 @@ data IfaceRule ifRuleOrph :: Maybe OccName -- Just like IfaceClsInst } -instance Binary IfaceRule where - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) - data IfaceAnnotation = IfaceAnnotation { ifAnnotatedTarget :: IfaceAnnTarget, ifAnnotatedValue :: AnnPayload } -instance Outputable IfaceAnnotation where - ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value - -instance Binary IfaceAnnotation where - put_ bh (IfaceAnnotation a1 a2) = do - put_ bh a1 - put_ bh a2 - get bh = do - a1 <- get bh - a2 <- get bh - return (IfaceAnnotation a1 a2) - type IfaceAnnTarget = AnnTarget OccName --- We only serialise the IdDetails of top-level Ids, and even then --- we only need a very limited selection. Notably, none of the --- implicit ones are needed here, because they are not put it --- interface files - -data IfaceIdDetails - = IfVanillaId - | IfRecSelId IfaceTyCon Bool - | IfDFunId Int -- Number of silent args - -instance Binary IfaceIdDetails where - put_ bh IfVanillaId = putByte bh 0 - put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b - put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } - get bh = do - h <- getByte bh - case h of - 0 -> return IfVanillaId - 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } - _ -> do { n <- get bh; return (IfDFunId n) } - -data IfaceIdInfo - = NoInfo -- When writing interface file without -O - | HasInfo [IfaceInfoItem] -- Has info, and here it is - -instance Binary IfaceIdInfo where - put_ bh NoInfo = putByte bh 0 - put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut - - get bh = do - h <- getByte bh - case h of - 0 -> return NoInfo - _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet - -- Here's a tricky case: -- * Compile with -O module A, and B which imports A.f -- * Change function f in A, and recompile without -O @@ -584,6 +264,10 @@ instance Binary IfaceIdInfo where -- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) -- and so gives a new version. +data IfaceIdInfo + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is + data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig @@ -592,23 +276,6 @@ data IfaceInfoItem IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs -instance Binary IfaceInfoItem where - put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa - put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab - put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad - put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad - put_ bh HsNoCafRefs = putByte bh 4 - get bh = do - h <- getByte bh - case h of - 0 -> liftM HsArity $ get bh - 1 -> liftM HsStrictness $ get bh - 2 -> do lb <- get bh - ad <- get bh - return (HsUnfold lb ad) - 3 -> liftM HsInline $ get bh - _ -> return HsNoCafRefs - -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. @@ -626,253 +293,18 @@ data IfaceUnfolding | IfDFunUnfold [IfaceBndr] [IfaceExpr] -instance Binary IfaceUnfolding where - put_ bh (IfCoreUnfold s e) = do - putByte bh 0 - put_ bh s - put_ bh e - put_ bh (IfInlineRule a b c d) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh c - put_ bh d - put_ bh (IfDFunUnfold as bs) = do - putByte bh 2 - put_ bh as - put_ bh bs - put_ bh (IfCompulsory e) = do - putByte bh 3 - put_ bh e - get bh = do - h <- getByte bh - case h of - 0 -> do s <- get bh - e <- get bh - return (IfCoreUnfold s e) - 1 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfInlineRule a b c d) - 2 -> do as <- get bh - bs <- get bh - return (IfDFunUnfold as bs) - _ -> do e <- get bh - return (IfCompulsory e) - --------------------------------- -data IfaceExpr - = IfaceLcl IfLclName - | IfaceExt IfExtName - | IfaceType IfaceType - | IfaceCo IfaceCoercion - | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted - | IfaceLam IfaceBndr IfaceExpr - | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName [IfaceAlt] - | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] - | IfaceLet IfaceBinding IfaceExpr - | IfaceCast IfaceExpr IfaceCoercion - | IfaceLit Literal - | IfaceFCall ForeignCall IfaceType - | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E -instance Binary IfaceExpr where - put_ bh (IfaceLcl aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceType ab) = do - putByte bh 1 - put_ bh ab - put_ bh (IfaceCo ab) = do - putByte bh 2 - put_ bh ab - put_ bh (IfaceTuple ac ad) = do - putByte bh 3 - put_ bh ac - put_ bh ad - put_ bh (IfaceLam ae af) = do - putByte bh 4 - put_ bh ae - put_ bh af - put_ bh (IfaceApp ag ah) = do - putByte bh 5 - put_ bh ag - put_ bh ah - put_ bh (IfaceCase ai aj ak) = do - putByte bh 6 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh (IfaceLet al am) = do - putByte bh 7 - put_ bh al - put_ bh am - put_ bh (IfaceTick an ao) = do - putByte bh 8 - put_ bh an - put_ bh ao - put_ bh (IfaceLit ap) = do - putByte bh 9 - put_ bh ap - put_ bh (IfaceFCall as at) = do - putByte bh 10 - put_ bh as - put_ bh at - put_ bh (IfaceExt aa) = do - putByte bh 11 - put_ bh aa - put_ bh (IfaceCast ie ico) = do - putByte bh 12 - put_ bh ie - put_ bh ico - put_ bh (IfaceECase a b) = do - putByte bh 13 - put_ bh a - put_ bh b - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (IfaceLcl aa) - 1 -> do ab <- get bh - return (IfaceType ab) - 2 -> do ab <- get bh - return (IfaceCo ab) - 3 -> do ac <- get bh - ad <- get bh - return (IfaceTuple ac ad) - 4 -> do ae <- get bh - af <- get bh - return (IfaceLam ae af) - 5 -> do ag <- get bh - ah <- get bh - return (IfaceApp ag ah) - 6 -> do ai <- get bh - aj <- get bh - ak <- get bh - return (IfaceCase ai aj ak) - 7 -> do al <- get bh - am <- get bh - return (IfaceLet al am) - 8 -> do an <- get bh - ao <- get bh - return (IfaceTick an ao) - 9 -> do ap <- get bh - return (IfaceLit ap) - 10 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 11 -> do aa <- get bh - return (IfaceExt aa) - 12 -> do ie <- get bh - ico <- get bh - return (IfaceCast ie ico) - 13 -> do a <- get bh - b <- get bh - return (IfaceECase a b) - _ -> panic ("get IfaceExpr " ++ show h) - -data IfaceTickish - = IfaceHpcTick Module Int -- from HpcTick x - | IfaceSCC CostCentre Bool Bool -- from ProfNote - -- no breakpoints: we never export these into interface files - -instance Binary IfaceTickish where - put_ bh (IfaceHpcTick m ix) = do - putByte bh 0 - put_ bh m - put_ bh ix - put_ bh (IfaceSCC cc tick push) = do - putByte bh 1 - put_ bh cc - put_ bh tick - put_ bh push - - get bh = do - h <- getByte bh - case h of - 0 -> do m <- get bh - ix <- get bh - return (IfaceHpcTick m ix) - 1 -> do cc <- get bh - tick <- get bh - push <- get bh - return (IfaceSCC cc tick push) - _ -> panic ("get IfaceTickish " ++ show h) - -type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) - -- Note: IfLclName, not IfaceBndr (and same with the case binder) - -- We reconstruct the kind/type of the thing from the context - -- thus saving bulk in interface files - -data IfaceConAlt = IfaceDefault - | IfaceDataAlt IfExtName - | IfaceLitAlt Literal - -instance Binary IfaceConAlt where - put_ bh IfaceDefault = putByte bh 0 - put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa - put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceDefault - 1 -> liftM IfaceDataAlt $ get bh - _ -> liftM IfaceLitAlt $ get bh - -data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, IfaceExpr)] - -instance Binary IfaceBinding where - put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab - put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } - _ -> do { ac <- get bh; return (IfaceRec ac) } - --- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too --- It's used for *non-top-level* let/rec binders --- See Note [IdInfo on nested let-bindings] -data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo +-- We only serialise the IdDetails of top-level Ids, and even then +-- we only need a very limited selection. Notably, none of the +-- implicit ones are needed here, because they are not put it +-- interface files -instance Binary IfaceLetBndr where - put_ bh (IfLetBndr a b c) = do - put_ bh a - put_ bh b - put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (IfLetBndr a b c) +data IfaceIdDetails + = IfVanillaId + | IfRecSelId IfaceTyCon Bool + | IfDFunId Int -- Number of silent args \end{code} -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In IfaceSyn an IfaceCase does not record the types of the alternatives, -unlike CorSyn Case. But we need this type if the alternatives are empty. -Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. - -Note [Expose recursive functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For supercompilation we want to put *all* unfoldings in the interface -file, even for functions that are recursive (or big). So we need to -know when an unfolding belongs to a loop-breaker so that we can refrain -from inlining it (except during supercompilation). - -Note [IdInfo on nested let-bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Occasionally we want to preserve IdInfo on nested let bindings. The one -that came up was a NOINLINE pragma on a let-binding inside an INLINE -function. The user (Duncan Coutts) really wanted the NOINLINE control -to cross the separate compilation boundary. - -In general we retain all info that is left by CoreTidy.tidyLetBndr, since -that is what is seen by importing module with --make Note [Orphans]: the ifInstOrph and ifRuleOrph fields ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -949,10 +381,22 @@ Note [Versioning of instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance#Instances] + +%************************************************************************ +%* * + Functions over declarations +%* * +%************************************************************************ + \begin{code} --- ----------------------------------------------------------------------------- --- Utils on IfaceSyn +visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] +visibleIfConDecls (IfAbstractTyCon {}) = [] +visibleIfConDecls IfDataFamTyCon = [] +visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] +\end{code} +\begin{code} ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] -- *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, @@ -1015,11 +459,6 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, dc_occ = mkClassDataConOcc cls_tc_occ is_newtype = n_sigs + n_ctxt == 1 -- Sigh -ifaceDeclImplicitBndrs (IfacePatSyn{ ifName = ps_occ, ifPatHasWrapper = has_wrapper }) - = [wrap_occ | has_wrapper] - where - wrap_occ = mkDataConWrapperOcc ps_occ -- Id namespace - ifaceDeclImplicitBndrs _ = [] -- ----------------------------------------------------------------------------- @@ -1038,80 +477,308 @@ ifaceDeclFingerprints hash decl computeFingerprint' = unsafeDupablePerformIO . computeFingerprint (panic "ifaceDeclFingerprints") +\end{code} ------------------------------ Printing IfaceDecl ------------------------------ +%************************************************************************ +%* * + Expressions +%* * +%************************************************************************ -instance Outputable IfaceDecl where - ppr = pprIfaceDecl +\begin{code} +data IfaceExpr + = IfaceLcl IfLclName + | IfaceExt IfExtName + | IfaceType IfaceType + | IfaceCo IfaceCoercion + | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] + | IfaceLet IfaceBinding IfaceExpr + | IfaceCast IfaceExpr IfaceCoercion + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType + | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E + +data IfaceTickish + = IfaceHpcTick Module Int -- from HpcTick x + | IfaceSCC CostCentre Bool Bool -- from ProfNote + -- no breakpoints: we never export these into interface files + +type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) + -- Note: IfLclName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files -pprIfaceDecl :: IfaceDecl -> SDoc -pprIfaceDecl (IfaceId {ifName = var, ifType = ty, - ifIdDetails = details, ifIdInfo = info}) - = sep [ pprPrefixOcc var <+> dcolon <+> ppr ty, - nest 2 (ppr details), - nest 2 (ppr info) ] +data IfaceConAlt = IfaceDefault + | IfaceDataAlt IfExtName + | IfaceLitAlt Literal -pprIfaceDecl (IfaceForeign {ifName = tycon}) - = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] +data IfaceBinding + = IfaceNonRec IfaceLetBndr IfaceExpr + | IfaceRec [(IfaceLetBndr, IfaceExpr)] + +-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too +-- It's used for *non-top-level* let/rec binders +-- See Note [IdInfo on nested let-bindings] +data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo +\end{code} + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In IfaceSyn an IfaceCase does not record the types of the alternatives, +unlike CorSyn Case. But we need this type if the alternatives are empty. +Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. + +Note [Expose recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For supercompilation we want to put *all* unfoldings in the interface +file, even for functions that are recursive (or big). So we need to +know when an unfolding belongs to a loop-breaker so that we can refrain +from inlining it (except during supercompilation). + +Note [IdInfo on nested let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Occasionally we want to preserve IdInfo on nested let bindings. The one +that came up was a NOINLINE pragma on a let-binding inside an INLINE +function. The user (Duncan Coutts) really wanted the NOINLINE control +to cross the separate compilation boundary. -pprIfaceDecl (IfaceSyn {ifName = tycon, - ifTyVars = tyvars, - ifSynRhs = IfaceSynonymTyCon mono_ty}) - = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) - 2 (vcat [equals <+> ppr mono_ty]) +In general we retain all info that is left by CoreTidy.tidyLetBndr, since +that is what is seen by importing module with --make + + +%************************************************************************ +%* * + Printing IfaceDecl +%* * +%************************************************************************ -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = rhs, ifSynKind = kind }) - = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) - 2 (sep [dcolon <+> ppr kind, parens (pp_rhs rhs)]) +\begin{code} +pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc +-- The TyCon might be local (just an OccName), or this might +-- be a branch for an imported TyCon, so it would be an ExtName +-- So it's easier to take an SDoc here +pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs + , ifaxbLHS = pat_tys + , ifaxbRHS = rhs + , ifaxbIncomps = incomps }) + = hang (pprUserIfaceForAll tvs) + 2 (hang pp_lhs 2 (equals <+> ppr rhs)) + $+$ + nest 2 maybe_incomps where - pp_rhs IfaceOpenSynFamilyTyCon = ptext (sLit "open") - pp_rhs (IfaceClosedSynFamilyTyCon ax) = ptext (sLit "closed, axiom") <+> ppr ax - pp_rhs IfaceAbstractClosedSynFamilyTyCon = ptext (sLit "closed, abstract") - pp_rhs _ = panic "pprIfaceDecl syn" + pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys) + maybe_incomps = ppUnless (null incomps) $ parens $ + ptext (sLit "incompatible indices:") <+> ppr incomps + +instance Outputable IfaceAnnotation where + ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value + +instance HasOccName IfaceClassOp where + occName (IfaceClassOp n _ _) = n + +instance HasOccName IfaceConDecl where + occName = ifConOcc -pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType, - ifCtxt = context, - ifTyVars = tyvars, ifRoles = roles, ifCons = condecls, - ifRec = isrec, ifPromotable = is_prom, - ifAxiom = mbAxiom}) - = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 2 (vcat [ pprCType cType - , pprRoles roles - , pprRec isrec <> comma <+> pp_prom - , pp_condecls tycon condecls - , pprAxiom mbAxiom]) +instance HasOccName IfaceDecl where + occName = ifName + +instance Outputable IfaceDecl where + ppr = pprIfaceDecl showAll + +data ShowSub + = ShowSub + { ss_ppr_bndr :: OccName -> SDoc -- Pretty-printer for binders in IfaceDecl + -- See Note [Printing IfaceDecl binders] + , ss_how_much :: ShowHowMuch } + +data ShowHowMuch + = ShowHeader -- Header information only, not rhs + | ShowSome [OccName] -- [] <=> Print all sub-components + -- (n:ns) <=> print sub-component 'n' with ShowSub=ns + -- elide other sub-components to "..." + -- May 14: the list is max 1 element long at the moment + | ShowIface -- Everything including GHC-internal information (used in --show-iface) + +showAll :: ShowSub +showAll = ShowSub { ss_how_much = ShowIface, ss_ppr_bndr = ppr } + +ppShowIface :: ShowSub -> SDoc -> SDoc +ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowIface _ _ = empty + +ppShowRhs :: ShowSub -> SDoc -> SDoc +ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _ = empty +ppShowRhs _ doc = doc + +showSub :: HasOccName n => ShowSub -> n -> Bool +showSub (ShowSub { ss_how_much = ShowHeader }) _ = False +showSub (ShowSub { ss_how_much = ShowSome (n:_) }) thing = n == occName thing +showSub (ShowSub { ss_how_much = _ }) _ = True +\end{code} + +Note [Printing IfaceDecl binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binders in an IfaceDecl are just OccNames, so we don't know what module they +come from. But when we pretty-print a TyThing by converting to an IfaceDecl +(see PprTyThing), the TyThing may come from some other module so we really need +the module qualifier. We solve this by passing in a pretty-printer for the +binders. + +When printing an interface file (--show-iface), we want to print +everything unqualified, so we can just print the OccName directly. + +\begin{code} +ppr_trim :: [Maybe SDoc] -> [SDoc] +-- Collapse a group of Nothings to a single "..." +ppr_trim xs + = snd (foldr go (False, []) xs) where - pp_prom | is_prom = ptext (sLit "Promotable") - | otherwise = ptext (sLit "Not promotable") + go (Just doc) (_, so_far) = (False, doc : so_far) + go Nothing (True, so_far) = (True, so_far) + go Nothing (False, so_far) = (True, ptext (sLit "...") : so_far) + +isIfaceDataInstance :: IfaceTyConParent -> Bool +isIfaceDataInstance IfNoParent = False +isIfaceDataInstance _ = True + +pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc +-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi +-- See Note [Pretty-printing TyThings] in PprTyThing +pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, + ifCtxt = context, ifTyVars = tc_tyvars, + ifRoles = roles, ifCons = condecls, + ifParent = parent, ifRec = isrec, + ifGadtSyntax = gadt, + ifPromotable = is_prom }) + + | gadt_style = vcat [ pp_roles + , pp_nd <+> pp_lhs <+> pp_where + , nest 2 (vcat pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + | otherwise = vcat [ pp_roles + , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + where + is_data_instance = isIfaceDataInstance parent + + gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons + cons = visibleIfConDecls condecls + pp_where = ppWhen (gadt_style && not (null cons)) $ ptext (sLit "where") + pp_cons = ppr_trim (map show_con cons) :: [SDoc] + + pp_lhs = case parent of + IfNoParent -> pprIfaceDeclHead context ss tycon tc_tyvars + _ -> ptext (sLit "instance") <+> pprIfaceTyConParent parent + + pp_roles + | is_data_instance = empty + | otherwise = pprRoles (== Representational) (pprPrefixIfDeclBndr ss tycon) + tc_tyvars roles + -- Don't display roles for data family instances (yet) + -- See discussion on Trac #8672. + + add_bars [] = empty + add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) + + ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc) + + show_con dc + | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty dc + | otherwise = Nothing + + mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc) + -- See Note [Result type of a data family GADT] + mk_user_con_res_ty eq_spec + | IfDataInstance _ tc tys <- parent + = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys))) + | otherwise + = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst)) + where + gadt_subst = mkFsEnv eq_spec + done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv) + con_univ_tvs = filterOut done_univ_tv tc_tyvars + + ppr_tc_app gadt_subst dflags + = pprPrefixIfDeclBndr ss tycon + <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv) + | (tv,_kind) <- stripIfaceKindVars dflags tc_tyvars ] + pp_nd = case condecls of - IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis) - IfDataFamTyCon -> ptext (sLit "data family") - IfDataTyCon _ -> ptext (sLit "data") - IfNewTyCon _ -> ptext (sLit "newtype") - -pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs, - ifRec = isrec}) - = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) - 2 (vcat [pprRoles roles, - pprRec isrec, - sep (map ppr ats), - sep (map ppr sigs)]) - -pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches }) - = hang (ptext (sLit "axiom") <+> ppr name <> dcolon) - 2 (vcat $ map (pprAxBranch $ Just tycon) branches) - -pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap, - ifPatIsInfix = is_infix, - ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs, - ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, - ifPatArgs = args, - ifPatTy = ty }) + IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d)) + IfDataFamTyCon -> ptext (sLit "data family") + IfDataTyCon _ -> ptext (sLit "data") + IfNewTyCon _ -> ptext (sLit "newtype") + + pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom] + + pp_prom | is_prom = ptext (sLit "Promotable") + | otherwise = empty + + +pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec + , ifCtxt = context, ifName = clas + , ifTyVars = tyvars, ifRoles = roles + , ifFDs = fds }) + = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) tyvars roles + , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas tyvars + <+> pprFundeps fds <+> pp_where + , nest 2 (vcat [vcat asocs, vcat dsigs, pprec])] + where + pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (ptext (sLit "where")) + + asocs = ppr_trim $ map maybeShowAssoc ats + dsigs = ppr_trim $ map maybeShowSig sigs + pprec = ppShowIface ss (pprRec isrec) + + maybeShowAssoc :: IfaceAT -> Maybe SDoc + maybeShowAssoc asc@(IfaceAT d _) + | showSub ss d = Just $ pprIfaceAT ss asc + | otherwise = Nothing + + maybeShowSig :: IfaceClassOp -> Maybe SDoc + maybeShowSig sg + | showSub ss sg = Just $ pprIfaceClassOp ss sg + | otherwise = Nothing + +pprIfaceDecl ss (IfaceSyn { ifName = tc + , ifTyVars = tv + , ifSynRhs = IfaceSynonymTyCon mono_ty }) + = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc tv <+> equals) + 2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau]) + where + (tvs, theta, tau) = splitIfaceSigmaTy mono_ty + +pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars + , ifSynRhs = rhs, ifSynKind = kind }) + = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars <+> dcolon) + 2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs)) + , ppShowRhs ss (nest 2 (pp_branches rhs)) ] + where + pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (ptext (sLit "open")) + pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (ptext (sLit "closed, abstract")) + pp_rhs (IfaceClosedSynFamilyTyCon _ (_:_)) = ptext (sLit "where") + pp_rhs IfaceBuiltInSynFamTyCon = ppShowIface ss (ptext (sLit "built-in")) + pp_rhs _ = panic "pprIfaceDecl syn" + + pp_branches (IfaceClosedSynFamilyTyCon ax brs) + = vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs) + $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax) + pp_branches _ = empty + +pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper, + ifPatIsInfix = is_infix, + ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs, + ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, + ifPatArgs = args, + ifPatTy = ty }) = pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt) where - args' = case (is_infix, map snd args) of + has_wrap = isJust wrapper + args' = case (is_infix, args) of (True, [left_ty, right_ty]) -> InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty) (_, tys) -> @@ -1122,70 +789,105 @@ pprIfaceDecl (IfacePatSyn { ifName = name, ifPatHasWrapper = has_wrap, pprCtxt [] = Nothing pprCtxt ctxt = Just $ pprIfaceContext ctxt +pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, + ifIdDetails = details, ifIdInfo = info }) + = vcat [ hang (pprPrefixIfDeclBndr ss var <+> dcolon) + 2 (pprIfaceSigmaType ty) + , ppShowIface ss (ppr details) + , ppShowIface ss (ppr info) ] + +pprIfaceDecl _ (IfaceForeign {ifName = tycon}) + = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] + +pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon + , ifAxBranches = branches }) + = hang (ptext (sLit "axiom") <+> ppr name <> dcolon) + 2 (vcat $ map (pprAxBranch (ppr tycon)) branches) + + pprCType :: Maybe CType -> SDoc -pprCType Nothing = ptext (sLit "No C type associated") +pprCType Nothing = empty pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType -pprRoles :: [Role] -> SDoc -pprRoles [] = empty -pprRoles roles = text "Roles:" <+> ppr roles +-- if, for each role, suppress_if role is True, then suppress the role +-- output +pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTvBndr] -> [Role] -> SDoc +pprRoles suppress_if tyCon tyvars roles + = sdocWithDynFlags $ \dflags -> + let froles = suppressIfaceKinds dflags tyvars roles + in ppUnless (all suppress_if roles || null froles) $ + ptext (sLit "type role") <+> tyCon <+> hsep (map ppr froles) pprRec :: RecFlag -> SDoc -pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec +pprRec NonRecursive = empty +pprRec Recursive = ptext (sLit "RecFlag: Recursive") -pprAxiom :: Maybe Name -> SDoc -pprAxiom Nothing = ptext (sLit "FamilyInstance: none") -pprAxiom (Just ax) = ptext (sLit "FamilyInstance:") <+> ppr ax +pprInfixIfDeclBndr, pprPrefixIfDeclBndr :: ShowSub -> OccName -> SDoc +pprInfixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ + = pprInfixVar (isSymOcc occ) (ppr_bndr occ) +pprPrefixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ + = parenSymOcc occ (ppr_bndr occ) instance Outputable IfaceClassOp where - ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty + ppr = pprIfaceClassOp showAll + +pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc +pprIfaceClassOp ss (IfaceClassOp n dm ty) = hang opHdr 2 (pprIfaceSigmaType ty) + where opHdr = pprPrefixIfDeclBndr ss n + <+> ppShowIface ss (ppr dm) <+> dcolon instance Outputable IfaceAT where - ppr (IfaceAT d defs) - = vcat [ ppr d - , ppUnless (null defs) $ nest 2 $ - ptext (sLit "Defaults:") <+> vcat (map ppr defs) ] - -pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc -pprIfaceDeclHead context thing tyvars - = hsep [pprIfaceContextArr context, parenSymOcc thing (ppr thing), - pprIfaceTvBndrs tyvars] - -pp_condecls :: OccName -> IfaceConDecls -> SDoc -pp_condecls _ (IfAbstractTyCon {}) = 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)) - -mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType --- IA0_NOTE: This is wrong, but only used for pretty-printing. -mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2] - -pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc -pprIfaceConDecl tc - (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, - ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, + ppr = pprIfaceAT showAll + +pprIfaceAT :: ShowSub -> IfaceAT -> SDoc +pprIfaceAT ss (IfaceAT d mb_def) + = vcat [ pprIfaceDecl ss d + , case mb_def of + Nothing -> empty + Just rhs -> nest 2 $ + ptext (sLit "Default:") <+> ppr rhs ] + +instance Outputable IfaceTyConParent where + ppr p = pprIfaceTyConParent p + +pprIfaceTyConParent :: IfaceTyConParent -> SDoc +pprIfaceTyConParent IfNoParent + = empty +pprIfaceTyConParent (IfDataInstance _ tc tys) + = sdocWithDynFlags $ \dflags -> + let ftys = stripKindArgs dflags tys + in pprIfaceTypeApp tc ftys + +pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName -> [IfaceTvBndr] -> SDoc +pprIfaceDeclHead context ss tc_occ tv_bndrs + = sdocWithDynFlags $ \ dflags -> + sep [ pprIfaceContextArr context + , pprPrefixIfDeclBndr ss tc_occ + <+> pprIfaceTvBndrs (stripIfaceKindVars dflags tv_bndrs) ] + +isVanillaIfaceConDecl :: IfaceConDecl -> Bool +isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs + , ifConEqSpec = eq_spec + , ifConCtxt = ctxt }) + = (null ex_tvs) && (null eq_spec) && (null ctxt) + +pprIfaceConDecl :: ShowSub -> Bool + -> (IfaceEqSpec -> ([IfaceTvBndr], SDoc)) + -> IfaceConDecl -> SDoc +pprIfaceConDecl ss gadt_style mk_user_con_res_ty + (IfCon { ifConOcc = name, ifConInfix = is_infix, + ifConExTvs = ex_tvs, ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, - ifConStricts = strs, ifConFields = fields }) - = sep [main_payload, - if is_infix then ptext (sLit "Infix") else empty, - if has_wrap then ptext (sLit "HasWrapper") else empty, - ppUnless (null strs) $ - nest 2 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), - ppUnless (null fields) $ - nest 2 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] + ifConStricts = stricts, ifConFields = labels }) + | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty + | otherwise = ppr_fields tys_w_strs where - ppr_bang IfNoBang = char '_' -- Want to see these - ppr_bang IfStrict = char '!' - ppr_bang IfUnpack = ptext (sLit "!!") - ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceCoercion co - - main_payload = ppr name <+> dcolon <+> - pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau + tys_w_strs :: [(IfaceBang, IfaceType)] + tys_w_strs = zip stricts arg_tys + pp_prefix_con = pprPrefixIfDeclBndr ss name - eq_ctxt = [(mkIfaceEqPred (IfaceTyVar (occNameFS tv)) ty) - | (tv,ty) <- eq_spec] + (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec + ppr_ty = pprIfaceForAllPart (univ_tvs ++ ex_tvs) ctxt pp_tau -- A bit gruesome this, but we can't form the full con_tau, and ppr it, -- because we don't have a Name for the tycon, only an OccName @@ -1193,7 +895,26 @@ pprIfaceConDecl tc (t:ts) -> fsep (t : map (arrow <+>) ts) [] -> panic "pp_con_taus" - pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs] + ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_' + ppr_bang IfStrict = char '!' + ppr_bang IfUnpack = ptext (sLit "{-# UNPACK #-}") + ppr_bang (IfUnpackCo co) = ptext (sLit "! {-# UNPACK #-}") <> + pprParendIfaceCoercion co + + pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty + pprBangTy (bang, ty) = ppr_bang bang <> ppr ty + + maybe_show_label (lbl,bty) + | showSub ss lbl = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty) + | otherwise = Nothing + + ppr_fields [ty1, ty2] + | is_infix && null labels + = sep [pprParendBangTy ty1, pprInfixIfDeclBndr ss name, pprParendBangTy ty2] + ppr_fields fields + | null labels = pp_prefix_con <+> sep (map pprParendBangTy fields) + | otherwise = pp_prefix_con <+> (braces $ sep $ punctuate comma $ ppr_trim $ + map maybe_show_label (zip labels fields)) instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, @@ -1205,15 +926,15 @@ instance Outputable IfaceRule where ] instance Outputable IfaceClsInst where - ppr (IfaceClsInst {ifDFun = dfun_id, ifOFlag = flag, - ifInstCls = cls, ifInstTys = mb_tcs}) + 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)) 2 (equals <+> ppr dfun_id) instance Outputable IfaceFamInst where - ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, - ifFamInstAxiom = tycon_ax}) + ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = tycon_ax}) = hang (ptext (sLit "family instance") <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) 2 (equals <+> ppr tycon_ax) @@ -1223,6 +944,26 @@ ppr_rough Nothing = dot ppr_rough (Just tc) = ppr tc \end{code} +Note [Result type of a data family GADT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T (p,q) where + T1 :: T (Int, Maybe c) + T2 :: T (Bool, q) + +The IfaceDecl actually looks like + + data TPr p q where + T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q + T2 :: forall p q. (p~Bool) => TPr p q + +To reconstruct the result types for T1 and T2 that we +want to pretty print, we substitute the eq-spec +[p->Int, q->Maybe c] in the arg pattern (p,q) to give + T (Int, Maybe c) +Remember that in IfaceSyn, the TyCon and DataCon share the same +universal type variables. ----------------------------- Printing IfaceExpr ------------------------------------ @@ -1230,6 +971,9 @@ ppr_rough (Just tc) = ppr tc instance Outputable IfaceExpr where ppr e = pprIfaceExpr noParens e +noParens :: SDoc -> SDoc +noParens pp = pp + pprParendIfaceExpr :: IfaceExpr -> SDoc pprParendIfaceExpr = pprIfaceExpr parens @@ -1355,17 +1099,22 @@ instance Outputable IfaceUnfolding where pprParendIfaceExpr e] ppr (IfDFunUnfold bs es) = hang (ptext (sLit "DFun:") <+> sep (map ppr bs) <> dot) 2 (sep (map pprParendIfaceExpr es)) +\end{code} --- ----------------------------------------------------------------------------- --- | Finding the Names in IfaceSyn +%************************************************************************ +%* * + Finding the Names in IfaceSyn +%* * +%************************************************************************ --- This is used for dependency analysis in MkIface, so that we --- fingerprint a declaration before the things that depend on it. It --- is specific to interface-file fingerprinting in the sense that we --- don't collect *all* Names: for example, the DFun of an instance is --- recorded textually rather than by its fingerprint when --- fingerprinting the instance, so DFuns are not dependencies. +This is used for dependency analysis in MkIface, so that we +fingerprint a declaration before the things that depend on it. It +is specific to interface-file fingerprinting in the sense that we +don't collect *all* Names: for example, the DFun of an instance is +recorded textually rather than by its fingerprint when +fingerprinting the instance, so DFuns are not dependencies. +\begin{code} freeNamesIfDecl :: IfaceDecl -> NameSet freeNamesIfDecl (IfaceId _s t d i) = freeNamesIfType t &&& @@ -1375,7 +1124,7 @@ freeNamesIfDecl IfaceForeign{} = emptyNameSet freeNamesIfDecl d@IfaceData{} = freeNamesIfTvBndrs (ifTyVars d) &&& - maybe emptyNameSet unitNameSet (ifAxiom d) &&& + freeNamesIfaceTyConParent (ifParent d) &&& freeNamesIfContext (ifCtxt d) &&& freeNamesIfConDecls (ifCons d) freeNamesIfDecl d@IfaceSyn{} = @@ -1392,11 +1141,13 @@ freeNamesIfDecl d@IfaceAxiom{} = freeNamesIfTc (ifTyCon d) &&& fnList freeNamesIfAxBranch (ifAxBranches d) freeNamesIfDecl d@IfacePatSyn{} = + unitNameSet (ifPatMatcher d) &&& + maybe emptyNameSet unitNameSet (ifPatWrapper d) &&& freeNamesIfTvBndrs (ifPatUnivTvs d) &&& freeNamesIfTvBndrs (ifPatExTvs d) &&& freeNamesIfContext (ifPatProvCtxt d) &&& freeNamesIfContext (ifPatReqCtxt d) &&& - fnList freeNamesIfType (map snd (ifPatArgs d)) &&& + fnList freeNamesIfType (ifPatArgs d) &&& freeNamesIfType (ifPatTy d) freeNamesIfAxBranch :: IfaceAxBranch -> NameSet @@ -1404,7 +1155,7 @@ freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars , ifaxbLHS = lhs , ifaxbRHS = rhs }) = freeNamesIfTvBndrs tyvars &&& - fnList freeNamesIfType lhs &&& + freeNamesIfTcArgs lhs &&& freeNamesIfType rhs freeNamesIfIdDetails :: IfaceIdDetails -> NameSet @@ -1415,16 +1166,20 @@ freeNamesIfIdDetails _ = emptyNameSet freeNamesIfSynRhs :: IfaceSynTyConRhs -> NameSet freeNamesIfSynRhs (IfaceSynonymTyCon ty) = freeNamesIfType ty freeNamesIfSynRhs IfaceOpenSynFamilyTyCon = emptyNameSet -freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax) = unitNameSet ax +freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax br) + = unitNameSet ax &&& fnList freeNamesIfAxBranch br freeNamesIfSynRhs IfaceAbstractClosedSynFamilyTyCon = emptyNameSet +freeNamesIfSynRhs IfaceBuiltInSynFamTyCon = emptyNameSet freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType freeNamesIfAT :: IfaceAT -> NameSet -freeNamesIfAT (IfaceAT decl defs) +freeNamesIfAT (IfaceAT decl mb_def) = freeNamesIfDecl decl &&& - fnList freeNamesIfAxBranch defs + case mb_def of + Nothing -> emptyNameSet + Just rhs -> freeNamesIfType rhs freeNamesIfClsSig :: IfaceClassOp -> NameSet freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty @@ -1435,25 +1190,30 @@ freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet -freeNamesIfConDecl c = - freeNamesIfTvBndrs (ifConUnivTvs c) &&& - freeNamesIfTvBndrs (ifConExTvs c) &&& - freeNamesIfContext (ifConCtxt c) &&& - fnList freeNamesIfType (ifConArgTys c) &&& - fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints +freeNamesIfConDecl c + = freeNamesIfTvBndrs (ifConExTvs c) &&& + freeNamesIfContext (ifConCtxt c) &&& + fnList freeNamesIfType (ifConArgTys c) &&& + fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints freeNamesIfKind :: IfaceType -> NameSet freeNamesIfKind = freeNamesIfType +freeNamesIfTcArgs :: IfaceTcArgs -> NameSet +freeNamesIfTcArgs (ITC_Type t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts +freeNamesIfTcArgs (ITC_Kind k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks +freeNamesIfTcArgs ITC_Nil = emptyNameSet + freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceTyConApp tc ts) = - freeNamesIfTc tc &&& fnList freeNamesIfType ts + freeNamesIfTc tc &&& freeNamesIfTcArgs ts freeNamesIfType (IfaceLitTy _) = emptyNameSet freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfCoercion :: IfaceCoercion -> NameSet freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t @@ -1535,8 +1295,7 @@ freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty freeNamesIfExpr (IfaceCase s _ alts) - = freeNamesIfExpr s - &&& fnList fn_alt alts &&& fn_cons alts + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts where fn_alt (_con,_bs,r) = freeNamesIfExpr r @@ -1558,7 +1317,7 @@ freeNamesIfExpr (IfaceLet (IfaceRec as) x) freeNamesIfExpr _ = emptyNameSet freeNamesIfTc :: IfaceTyCon -> NameSet -freeNamesIfTc (IfaceTc tc) = unitNameSet tc +freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) -- ToDo: shouldn't we include IfaceIntTc & co.? freeNamesIfRule :: IfaceRule -> NameSet @@ -1568,13 +1327,18 @@ 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 +freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet +freeNamesIfaceTyConParent IfNoParent = emptyNameSet +freeNamesIfaceTyConParent (IfDataInstance ax tc tys) + = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys + -- helpers (&&&) :: NameSet -> NameSet -> NameSet (&&&) = unionNameSets @@ -1608,3 +1372,538 @@ Now, lookupModule depends on DynFlags, but the transitive dependency on the *locally-defined* type PackageState is not visible. We need to take account of the use of the data constructor PS in the pattern match. + +%************************************************************************ +%* * + Binary instances +%* * +%************************************************************************ + +\begin{code} +instance Binary IfaceDecl where + put_ bh (IfaceId name ty details idinfo) = do + putByte bh 0 + put_ bh (occNameFS name) + put_ bh ty + put_ bh details + put_ bh idinfo + + put_ _ (IfaceForeign _ _) = + error "Binary.put_(IfaceDecl): IfaceForeign" + + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + putByte bh 2 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + + put_ bh (IfaceSyn a1 a2 a3 a4 a5) = 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 a8 a9) = do + putByte bh 4 + put_ bh a1 + put_ bh (occNameFS a2) + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + + put_ bh (IfaceAxiom a1 a2 a3 a4) = do + putByte bh 5 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + + put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + putByte bh 6 + put_ bh (occNameFS name) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + + get bh = do + h <- getByte bh + case h of + 0 -> do name <- get bh + ty <- get bh + details <- get bh + idinfo <- get bh + occ <- return $! mkVarOccFS name + return (IfaceId occ ty details idinfo) + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + occ <- return $! mkTcOccFS a1 + return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9 a10) + 3 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + occ <- return $! mkTcOccFS a1 + return (IfaceSyn occ a2 a3 a4 a5) + 4 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + occ <- return $! mkClsOccFS a2 + return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9) + 5 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + occ <- return $! mkTcOccFS a1 + return (IfaceAxiom occ a2 a3 a4) + 6 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + occ <- return $! mkDataOccFS a1 + return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10) + _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) + +instance Binary IfaceSynTyConRhs where + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 + put_ bh (IfaceClosedSynFamilyTyCon ax br) = putByte bh 1 >> put_ bh ax + >> put_ bh br + put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2 + put_ bh (IfaceSynonymTyCon ty) = putByte bh 3 >> put_ bh ty + put_ _ IfaceBuiltInSynFamTyCon + = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" empty + + get bh = do { h <- getByte bh + ; case h of + 0 -> return IfaceOpenSynFamilyTyCon + 1 -> do { ax <- get bh + ; br <- get bh + ; return (IfaceClosedSynFamilyTyCon ax br) } + 2 -> return IfaceAbstractClosedSynFamilyTyCon + _ -> do { ty <- get bh + ; return (IfaceSynonymTyCon ty) } } + +instance Binary IfaceClassOp where + put_ bh (IfaceClassOp n def ty) = do + put_ bh (occNameFS n) + put_ bh def + put_ bh ty + get bh = do + n <- get bh + def <- get bh + ty <- get bh + occ <- return $! mkVarOccFS n + return (IfaceClassOp occ def ty) + +instance Binary IfaceAT where + put_ bh (IfaceAT dec defs) = do + put_ bh dec + put_ bh defs + get bh = do + dec <- get bh + defs <- get bh + return (IfaceAT dec defs) + +instance Binary IfaceAxBranch where + put_ bh (IfaceAxBranch a1 a2 a3 a4 a5) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceAxBranch a1 a2 a3 a4 a5) + +instance Binary IfaceConDecls where + put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d + 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 -> liftM IfAbstractTyCon $ get bh + 1 -> return IfDataFamTyCon + 2 -> liftM IfDataTyCon $ get bh + _ -> liftM IfNewTyCon $ get bh + +instance Binary IfaceConDecl where + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) + +instance Binary IfaceBang where + put_ bh IfNoBang = putByte bh 0 + put_ bh IfStrict = putByte bh 1 + put_ bh IfUnpack = putByte bh 2 + put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co + + get bh = do + h <- getByte bh + case h of + 0 -> do return IfNoBang + 1 -> do return IfStrict + 2 -> do return IfUnpack + _ -> do { a <- get bh; return (IfUnpackCo a) } + +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph) = do + put_ bh cls + put_ bh tys + put_ bh dfun + put_ bh flag + put_ bh orph + get bh = do + cls <- get bh + tys <- get bh + dfun <- get bh + flag <- get bh + orph <- get bh + return (IfaceClsInst cls tys dfun flag orph) + +instance Binary IfaceFamInst where + put_ bh (IfaceFamInst fam tys name orph) = do + put_ bh fam + put_ bh tys + put_ bh name + put_ bh orph + get bh = do + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) + +instance Binary IfaceRule where + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) + +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b + put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } + _ -> do { n <- get bh; return (IfDFunId n) } + +instance Binary IfaceIdInfo where + put_ bh NoInfo = putByte bh 0 + put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut + + get bh = do + h <- getByte bh + case h of + 0 -> return NoInfo + _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet + +instance Binary IfaceInfoItem where + put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa + put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab + put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad + put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad + put_ bh HsNoCafRefs = putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> liftM HsArity $ get bh + 1 -> liftM HsStrictness $ get bh + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) + 3 -> liftM HsInline $ get bh + _ -> return HsNoCafRefs + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold s e) = do + putByte bh 0 + put_ bh s + put_ bh e + put_ bh (IfInlineRule a b c d) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfDFunUnfold as bs) = do + putByte bh 2 + put_ bh as + put_ bh bs + put_ bh (IfCompulsory e) = do + putByte bh 3 + put_ bh e + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) + 1 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfInlineRule a b c d) + 2 -> do as <- get bh + bs <- get bh + return (IfDFunUnfold as bs) + _ -> do e <- get bh + return (IfCompulsory e) + + +instance Binary IfaceExpr where + put_ bh (IfaceLcl aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceType ab) = do + putByte bh 1 + put_ bh ab + put_ bh (IfaceCo ab) = do + putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 + put_ bh ac + put_ bh ad + put_ bh (IfaceLam ae af) = do + putByte bh 4 + put_ bh ae + put_ bh af + put_ bh (IfaceApp ag ah) = do + putByte bh 5 + put_ bh ag + put_ bh ah + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 + put_ bh ai + put_ bh aj + put_ bh ak + put_ bh (IfaceLet al am) = do + putByte bh 7 + put_ bh al + put_ bh am + put_ bh (IfaceTick an ao) = do + putByte bh 8 + put_ bh an + put_ bh ao + put_ bh (IfaceLit ap) = do + putByte bh 9 + put_ bh ap + put_ bh (IfaceFCall as at) = do + putByte bh 10 + put_ bh as + put_ bh at + put_ bh (IfaceExt aa) = do + putByte bh 11 + put_ bh aa + put_ bh (IfaceCast ie ico) = do + putByte bh 12 + put_ bh ie + put_ bh ico + put_ bh (IfaceECase a b) = do + putByte bh 13 + put_ bh a + put_ bh b + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceLcl aa) + 1 -> do ab <- get bh + return (IfaceType ab) + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh + ad <- get bh + return (IfaceTuple ac ad) + 4 -> do ae <- get bh + af <- get bh + return (IfaceLam ae af) + 5 -> do ag <- get bh + ah <- get bh + return (IfaceApp ag ah) + 6 -> do ai <- get bh + aj <- get bh + ak <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh + am <- get bh + return (IfaceLet al am) + 8 -> do an <- get bh + ao <- get bh + return (IfaceTick an ao) + 9 -> do ap <- get bh + return (IfaceLit ap) + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh + return (IfaceExt aa) + 12 -> do ie <- get bh + ico <- get bh + return (IfaceCast ie ico) + 13 -> do a <- get bh + b <- get bh + return (IfaceECase a b) + _ -> panic ("get IfaceExpr " ++ show h) + +instance Binary IfaceTickish where + put_ bh (IfaceHpcTick m ix) = do + putByte bh 0 + put_ bh m + put_ bh ix + put_ bh (IfaceSCC cc tick push) = do + putByte bh 1 + put_ bh cc + put_ bh tick + put_ bh push + + get bh = do + h <- getByte bh + case h of + 0 -> do m <- get bh + ix <- get bh + return (IfaceHpcTick m ix) + 1 -> do cc <- get bh + tick <- get bh + push <- get bh + return (IfaceSCC cc tick push) + _ -> panic ("get IfaceTickish " ++ show h) + +instance Binary IfaceConAlt where + put_ bh IfaceDefault = putByte bh 0 + put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa + put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceDefault + 1 -> liftM IfaceDataAlt $ get bh + _ -> liftM IfaceLitAlt $ get bh + +instance Binary IfaceBinding where + put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab + put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } + _ -> do { ac <- get bh; return (IfaceRec ac) } + +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c) = do + put_ bh a + put_ bh b + put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (IfLetBndr a b c) + +instance Binary IfaceTyConParent where + put_ bh IfNoParent = putByte bh 0 + put_ bh (IfDataInstance ax pr ty) = do + putByte bh 1 + put_ bh ax + put_ bh pr + put_ bh ty + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoParent + _ -> do + ax <- get bh + pr <- get bh + ty <- get bh + return $ IfDataInstance ax pr ty +\end{code}
\ No newline at end of file |