1{- 2(c) The University of Glasgow 2006 3(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 4-} 5 6{-# LANGUAGE CPP #-} 7{-# LANGUAGE LambdaCase #-} 8 9module IfaceSyn ( 10 module IfaceType, 11 12 IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), 13 IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, 14 IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..), 15 IfaceBinding(..), IfaceConAlt(..), 16 IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), 17 IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, 18 IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), 19 IfaceClassBody(..), 20 IfaceBang(..), 21 IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), 22 IfaceAxBranch(..), 23 IfaceTyConParent(..), 24 IfaceCompleteMatch(..), 25 26 -- * Binding names 27 IfaceTopBndr, 28 putIfaceTopBndr, getIfaceTopBndr, 29 30 -- Misc 31 ifaceDeclImplicitBndrs, visibleIfConDecls, 32 ifaceDeclFingerprints, 33 34 -- Free Names 35 freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, 36 37 -- Pretty printing 38 pprIfaceExpr, 39 pprIfaceDecl, 40 AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader 41 ) where 42 43#include "HsVersions.h" 44 45import GhcPrelude 46 47import IfaceType 48import BinFingerprint 49import CoreSyn( IsOrphan, isOrphan ) 50import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) ) 51import Demand 52import Class 53import FieldLabel 54import NameSet 55import CoAxiom ( BranchIndex ) 56import Name 57import CostCentre 58import Literal 59import ForeignCall 60import Annotations( AnnPayload, AnnTarget ) 61import BasicTypes 62import Outputable 63import Module 64import SrcLoc 65import Fingerprint 66import Binary 67import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) 68import Var( VarBndr(..), binderVar ) 69import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) 70import Util( dropList, filterByList, notNull, unzipWith ) 71import DataCon (SrcStrictness(..), SrcUnpackedness(..)) 72import Lexeme (isLexSym) 73import TysWiredIn ( constraintKindTyConName ) 74import Util (seqList) 75 76import Control.Monad 77import System.IO.Unsafe 78import Control.DeepSeq 79 80infixl 3 &&& 81 82{- 83************************************************************************ 84* * 85 Declarations 86* * 87************************************************************************ 88-} 89 90-- | A binding top-level 'Name' in an interface file (e.g. the name of an 91-- 'IfaceDecl'). 92type IfaceTopBndr = Name 93 -- It's convenient to have a Name in the IfaceSyn, although in each 94 -- case the namespace is implied by the context. However, having an 95 -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints 96 -- very convenient. Moreover, having the key of the binder means that 97 -- we can encode known-key things cleverly in the symbol table. See Note 98 -- [Symbol table representation of Names] 99 -- 100 -- We don't serialise the namespace onto the disk though; rather we 101 -- drop it when serialising and add it back in when deserialising. 102 103getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr 104getIfaceTopBndr bh = get bh 105 106putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO () 107putIfaceTopBndr bh name = 108 case getUserData bh of 109 UserData{ ud_put_binding_name = put_binding_name } -> 110 --pprTrace "putIfaceTopBndr" (ppr name) $ 111 put_binding_name bh name 112 113data IfaceDecl 114 = IfaceId { ifName :: IfaceTopBndr, 115 ifType :: IfaceType, 116 ifIdDetails :: IfaceIdDetails, 117 ifIdInfo :: IfaceIdInfo } 118 119 | IfaceData { ifName :: IfaceTopBndr, -- Type constructor 120 ifBinders :: [IfaceTyConBinder], 121 ifResKind :: IfaceType, -- Result kind of type constructor 122 ifCType :: Maybe CType, -- C type for CAPI FFI 123 ifRoles :: [Role], -- Roles 124 ifCtxt :: IfaceContext, -- The "stupid theta" 125 ifCons :: IfaceConDecls, -- Includes new/data/data family info 126 ifGadtSyntax :: Bool, -- True <=> declared using 127 -- GADT syntax 128 ifParent :: IfaceTyConParent -- The axiom, for a newtype, 129 -- or data/newtype family instance 130 } 131 132 | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor 133 ifRoles :: [Role], -- Roles 134 ifBinders :: [IfaceTyConBinder], 135 ifResKind :: IfaceKind, -- Kind of the *result* 136 ifSynRhs :: IfaceType } 137 138 | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor 139 ifResVar :: Maybe IfLclName, -- Result variable name, used 140 -- only for pretty-printing 141 -- with --show-iface 142 ifBinders :: [IfaceTyConBinder], 143 ifResKind :: IfaceKind, -- Kind of the *tycon* 144 ifFamFlav :: IfaceFamTyConFlav, 145 ifFamInj :: Injectivity } -- injectivity information 146 147 | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon 148 ifRoles :: [Role], -- Roles 149 ifBinders :: [IfaceTyConBinder], 150 ifFDs :: [FunDep IfLclName], -- Functional dependencies 151 ifBody :: IfaceClassBody -- Methods, superclasses, ATs 152 } 153 154 | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name 155 ifTyCon :: IfaceTyCon, -- LHS TyCon 156 ifRole :: Role, -- Role of axiom 157 ifAxBranches :: [IfaceAxBranch] -- Branches 158 } 159 160 | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym 161 ifPatIsInfix :: Bool, 162 ifPatMatcher :: (IfExtName, Bool), 163 ifPatBuilder :: Maybe (IfExtName, Bool), 164 -- Everything below is redundant, 165 -- but needed to implement pprIfaceDecl 166 ifPatUnivBndrs :: [IfaceForAllBndr], 167 ifPatExBndrs :: [IfaceForAllBndr], 168 ifPatProvCtxt :: IfaceContext, 169 ifPatReqCtxt :: IfaceContext, 170 ifPatArgs :: [IfaceType], 171 ifPatTy :: IfaceType, 172 ifFieldLabels :: [FieldLabel] } 173 174-- See also 'ClassBody' 175data IfaceClassBody 176 -- Abstract classes don't specify their body; they only occur in @hs-boot@ and 177 -- @hsig@ files. 178 = IfAbstractClass 179 | IfConcreteClass { 180 ifClassCtxt :: IfaceContext, -- Super classes 181 ifATs :: [IfaceAT], -- Associated type families 182 ifSigs :: [IfaceClassOp], -- Method signatures 183 ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition 184 } 185 186data IfaceTyConParent 187 = IfNoParent 188 | IfDataInstance 189 IfExtName -- Axiom name 190 IfaceTyCon -- Family TyCon (pretty-printing only, not used in TcIface) 191 -- see Note [Pretty printing via IfaceSyn] in PprTyThing 192 IfaceAppArgs -- Arguments of the family TyCon 193 194data IfaceFamTyConFlav 195 = IfaceDataFamilyTyCon -- Data family 196 | IfaceOpenSynFamilyTyCon 197 | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch])) 198 -- ^ Name of associated axiom and branches for pretty printing purposes, 199 -- or 'Nothing' for an empty closed family without an axiom 200 -- See Note [Pretty printing via IfaceSyn] in PprTyThing 201 | IfaceAbstractClosedSynFamilyTyCon 202 | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only 203 204data IfaceClassOp 205 = IfaceClassOp IfaceTopBndr 206 IfaceType -- Class op type 207 (Maybe (DefMethSpec IfaceType)) -- Default method 208 -- The types of both the class op itself, 209 -- and the default method, are *not* quantified 210 -- over the class variables 211 212data IfaceAT = IfaceAT -- See Class.ClassATItem 213 IfaceDecl -- The associated type declaration 214 (Maybe IfaceType) -- Default associated type instance, if any 215 216 217-- This is just like CoAxBranch 218data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] 219 , ifaxbEtaTyVars :: [IfaceTvBndr] 220 , ifaxbCoVars :: [IfaceIdBndr] 221 , ifaxbLHS :: IfaceAppArgs 222 , ifaxbRoles :: [Role] 223 , ifaxbRHS :: IfaceType 224 , ifaxbIncomps :: [BranchIndex] } 225 -- See Note [Storing compatibility] in CoAxiom 226 227data IfaceConDecls 228 = IfAbstractTyCon -- c.f TyCon.AbstractTyCon 229 | IfDataTyCon [IfaceConDecl] -- Data type decls 230 | IfNewTyCon IfaceConDecl -- Newtype decls 231 232-- For IfDataTyCon and IfNewTyCon we store: 233-- * the data constructor(s); 234-- The field labels are stored individually in the IfaceConDecl 235-- (there is some redundancy here, because a field label may occur 236-- in multiple IfaceConDecls and represent the same field label) 237 238data IfaceConDecl 239 = IfCon { 240 ifConName :: IfaceTopBndr, -- Constructor name 241 ifConWrapper :: Bool, -- True <=> has a wrapper 242 ifConInfix :: Bool, -- True <=> declared infix 243 244 -- The universal type variables are precisely those 245 -- of the type constructor of this data constructor 246 -- This is *easy* to guarantee when creating the IfCon 247 -- but it's not so easy for the original TyCon/DataCon 248 -- So this guarantee holds for IfaceConDecl, but *not* for DataCon 249 250 ifConExTCvs :: [IfaceBndr], -- Existential ty/covars 251 ifConUserTvBinders :: [IfaceForAllBndr], 252 -- The tyvars, in the order the user wrote them 253 -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the 254 -- set of tyvars (*not* covars) of ifConExTCvs, unioned 255 -- with the set of ifBinders (from the parent IfaceDecl) 256 -- whose tyvars do not appear in ifConEqSpec 257 -- See Note [DataCon user type variable binders] in DataCon 258 ifConEqSpec :: IfaceEqSpec, -- Equality constraints 259 ifConCtxt :: IfaceContext, -- Non-stupid context 260 ifConArgTys :: [IfaceType], -- Arg types 261 ifConFields :: [FieldLabel], -- ...ditto... (field labels) 262 ifConStricts :: [IfaceBang], 263 -- Empty (meaning all lazy), 264 -- or 1-1 corresp with arg tys 265 -- See Note [Bangs on imported data constructors] in MkId 266 ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts 267 268type IfaceEqSpec = [(IfLclName,IfaceType)] 269 270-- | This corresponds to an HsImplBang; that is, the final 271-- implementation decision about the data constructor arg 272data IfaceBang 273 = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion 274 275-- | This corresponds to HsSrcBang 276data IfaceSrcBang 277 = IfSrcBang SrcUnpackedness SrcStrictness 278 279data IfaceClsInst 280 = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with 281 ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst 282 ifDFun :: IfExtName, -- The dfun 283 ifOFlag :: OverlapFlag, -- Overlap flag 284 ifInstOrph :: IsOrphan } -- See Note [Orphans] in InstEnv 285 -- There's always a separate IfaceDecl for the DFun, which gives 286 -- its IdInfo with its full type and version number. 287 -- The instance declarations taken together have a version number, 288 -- and we don't want that to wobble gratuitously 289 -- If this instance decl is *used*, we'll record a usage on the dfun; 290 -- and if the head does not change it won't be used if it wasn't before 291 292-- The ifFamInstTys field of IfaceFamInst contains a list of the rough 293-- match types 294data IfaceFamInst 295 = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name 296 , ifFamInstTys :: [Maybe IfaceTyCon] -- See above 297 , ifFamInstAxiom :: IfExtName -- The axiom 298 , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst 299 } 300 301data IfaceRule 302 = IfaceRule { 303 ifRuleName :: RuleName, 304 ifActivation :: Activation, 305 ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars 306 ifRuleHead :: IfExtName, -- Head of lhs 307 ifRuleArgs :: [IfaceExpr], -- Args of LHS 308 ifRuleRhs :: IfaceExpr, 309 ifRuleAuto :: Bool, 310 ifRuleOrph :: IsOrphan -- Just like IfaceClsInst 311 } 312 313data IfaceAnnotation 314 = IfaceAnnotation { 315 ifAnnotatedTarget :: IfaceAnnTarget, 316 ifAnnotatedValue :: AnnPayload 317 } 318 319type IfaceAnnTarget = AnnTarget OccName 320 321data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName 322 323instance Outputable IfaceCompleteMatch where 324 ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls 325 <+> dcolon <+> ppr ty 326 327 328 329 330-- Here's a tricky case: 331-- * Compile with -O module A, and B which imports A.f 332-- * Change function f in A, and recompile without -O 333-- * When we read in old A.hi we read in its IdInfo (as a thunk) 334-- (In earlier GHCs we used to drop IdInfo immediately on reading, 335-- but we do not do that now. Instead it's discarded when the 336-- ModIface is read into the various decl pools.) 337-- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) 338-- and so gives a new version. 339 340data IfaceIdInfo 341 = NoInfo -- When writing interface file without -O 342 | HasInfo [IfaceInfoItem] -- Has info, and here it is 343 344data IfaceInfoItem 345 = HsArity Arity 346 | HsStrictness StrictSig 347 | HsInline InlinePragma 348 | HsUnfold Bool -- True <=> isStrongLoopBreaker is true 349 IfaceUnfolding -- See Note [Expose recursive functions] 350 | HsNoCafRefs 351 | HsLevity -- Present <=> never levity polymorphic 352 353-- NB: Specialisations and rules come in separately and are 354-- only later attached to the Id. Partial reason: some are orphans. 355 356data IfaceUnfolding 357 = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding 358 -- Possibly could eliminate the Bool here, the information 359 -- is also in the InlinePragma. 360 361 | IfCompulsory IfaceExpr -- Only used for default methods, in fact 362 363 | IfInlineRule Arity -- INLINE pragmas 364 Bool -- OK to inline even if *un*-saturated 365 Bool -- OK to inline even if context is boring 366 IfaceExpr 367 368 | IfDFunUnfold [IfaceBndr] [IfaceExpr] 369 370 371-- We only serialise the IdDetails of top-level Ids, and even then 372-- we only need a very limited selection. Notably, none of the 373-- implicit ones are needed here, because they are not put it 374-- interface files 375 376data IfaceIdDetails 377 = IfVanillaId 378 | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool 379 | IfDFunId 380 381{- 382Note [Versioning of instances] 383~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 384See [https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#instances] 385 386 387************************************************************************ 388* * 389 Functions over declarations 390* * 391************************************************************************ 392-} 393 394visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] 395visibleIfConDecls IfAbstractTyCon = [] 396visibleIfConDecls (IfDataTyCon cs) = cs 397visibleIfConDecls (IfNewTyCon c) = [c] 398 399ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] 400-- *Excludes* the 'main' name, but *includes* the implicitly-bound names 401-- Deeply revolting, because it has to predict what gets bound, 402-- especially the question of whether there's a wrapper for a datacon 403-- See Note [Implicit TyThings] in HscTypes 404 405-- N.B. the set of names returned here *must* match the set of 406-- TyThings returned by HscTypes.implicitTyThings, in the sense that 407-- TyThing.getOccName should define a bijection between the two lists. 408-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) 409-- The order of the list does not matter. 410 411ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) 412 = case cons of 413 IfAbstractTyCon -> [] 414 IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd 415 IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds 416 417ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) 418 = [] 419 420ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name 421 , ifBody = IfConcreteClass { 422 ifClassCtxt = sc_ctxt, 423 ifSigs = sigs, 424 ifATs = ats 425 }}) 426 = -- (possibly) newtype coercion 427 co_occs ++ 428 -- data constructor (DataCon namespace) 429 -- data worker (Id namespace) 430 -- no wrapper (class dictionaries never have a wrapper) 431 [dc_occ, dcww_occ] ++ 432 -- associated types 433 [occName (ifName at) | IfaceAT at _ <- ats ] ++ 434 -- superclass selectors 435 [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ 436 -- operation selectors 437 [occName op | IfaceClassOp op _ _ <- sigs] 438 where 439 cls_tc_occ = occName cls_tc_name 440 n_ctxt = length sc_ctxt 441 n_sigs = length sigs 442 co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] 443 | otherwise = [] 444 dcww_occ = mkDataConWorkerOcc dc_occ 445 dc_occ = mkClassDataConOcc cls_tc_occ 446 is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass) 447 448ifaceDeclImplicitBndrs _ = [] 449 450ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName] 451ifaceConDeclImplicitBndrs (IfCon { 452 ifConWrapper = has_wrapper, ifConName = con_name }) 453 = [occName con_name, work_occ] ++ wrap_occs 454 where 455 con_occ = occName con_name 456 work_occ = mkDataConWorkerOcc con_occ -- Id namespace 457 wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace 458 | otherwise = [] 459 460-- ----------------------------------------------------------------------------- 461-- The fingerprints of an IfaceDecl 462 463 -- We better give each name bound by the declaration a 464 -- different fingerprint! So we calculate the fingerprint of 465 -- each binder by combining the fingerprint of the whole 466 -- declaration with the name of the binder. (#5614, #7215) 467ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] 468ifaceDeclFingerprints hash decl 469 = (getOccName decl, hash) : 470 [ (occ, computeFingerprint' (hash,occ)) 471 | occ <- ifaceDeclImplicitBndrs decl ] 472 where 473 computeFingerprint' = 474 unsafeDupablePerformIO 475 . computeFingerprint (panic "ifaceDeclFingerprints") 476 477{- 478************************************************************************ 479* * 480 Expressions 481* * 482************************************************************************ 483-} 484 485data IfaceExpr 486 = IfaceLcl IfLclName 487 | IfaceExt IfExtName 488 | IfaceType IfaceType 489 | IfaceCo IfaceCoercion 490 | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted 491 | IfaceLam IfaceLamBndr IfaceExpr 492 | IfaceApp IfaceExpr IfaceExpr 493 | IfaceCase IfaceExpr IfLclName [IfaceAlt] 494 | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] 495 | IfaceLet IfaceBinding IfaceExpr 496 | IfaceCast IfaceExpr IfaceCoercion 497 | IfaceLit Literal 498 | IfaceFCall ForeignCall IfaceType 499 | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E 500 501data IfaceTickish 502 = IfaceHpcTick Module Int -- from HpcTick x 503 | IfaceSCC CostCentre Bool Bool -- from ProfNote 504 | IfaceSource RealSrcSpan String -- from SourceNote 505 -- no breakpoints: we never export these into interface files 506 507type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) 508 -- Note: IfLclName, not IfaceBndr (and same with the case binder) 509 -- We reconstruct the kind/type of the thing from the context 510 -- thus saving bulk in interface files 511 512data IfaceConAlt = IfaceDefault 513 | IfaceDataAlt IfExtName 514 | IfaceLitAlt Literal 515 516data IfaceBinding 517 = IfaceNonRec IfaceLetBndr IfaceExpr 518 | IfaceRec [(IfaceLetBndr, IfaceExpr)] 519 520-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too 521-- It's used for *non-top-level* let/rec binders 522-- See Note [IdInfo on nested let-bindings] 523data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo 524 525data IfaceJoinInfo = IfaceNotJoinPoint 526 | IfaceJoinPoint JoinArity 527 528{- 529Note [Empty case alternatives] 530~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 531In IfaceSyn an IfaceCase does not record the types of the alternatives, 532unlike CorSyn Case. But we need this type if the alternatives are empty. 533Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. 534 535Note [Expose recursive functions] 536~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 537For supercompilation we want to put *all* unfoldings in the interface 538file, even for functions that are recursive (or big). So we need to 539know when an unfolding belongs to a loop-breaker so that we can refrain 540from inlining it (except during supercompilation). 541 542Note [IdInfo on nested let-bindings] 543~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 544Occasionally we want to preserve IdInfo on nested let bindings. The one 545that came up was a NOINLINE pragma on a let-binding inside an INLINE 546function. The user (Duncan Coutts) really wanted the NOINLINE control 547to cross the separate compilation boundary. 548 549In general we retain all info that is left by CoreTidy.tidyLetBndr, since 550that is what is seen by importing module with --make 551 552Note [Displaying axiom incompatibilities] 553~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 554With -fprint-axiom-incomps we display which closed type family equations 555are incompatible with which. This information is sometimes necessary 556because GHC doesn't try equations in order: any equation can be used when 557all preceding equations that are incompatible with it do not apply. 558 559For example, the last "a && a = a" equation in Data.Type.Bool.&& is 560actually compatible with all previous equations, and can reduce at any 561time. 562 563This is displayed as: 564Prelude> :i Data.Type.Equality.== 565type family (==) (a :: k) (b :: k) :: Bool 566 where 567 {- #0 -} (==) (f a) (g b) = (f == g) && (a == b) 568 {- #1 -} (==) a a = 'True 569 -- incompatible with: #0 570 {- #2 -} (==) _1 _2 = 'False 571 -- incompatible with: #1, #0 572The comment after an equation refers to all previous equations (0-indexed) 573that are incompatible with it. 574 575************************************************************************ 576* * 577 Printing IfaceDecl 578* * 579************************************************************************ 580-} 581 582pprAxBranch :: SDoc -> BranchIndex -> IfaceAxBranch -> SDoc 583-- The TyCon might be local (just an OccName), or this might 584-- be a branch for an imported TyCon, so it would be an ExtName 585-- So it's easier to take an SDoc here 586-- 587-- This function is used 588-- to print interface files, 589-- in debug messages 590-- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon 591-- For user error messages we use Coercion.pprCoAxiom and friends 592pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs 593 , ifaxbCoVars = _cvs 594 , ifaxbLHS = pat_tys 595 , ifaxbRHS = rhs 596 , ifaxbIncomps = incomps }) 597 = WARN( not (null _cvs), pp_tc $$ ppr _cvs ) 598 hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) 599 $+$ 600 nest 4 maybe_incomps 601 where 602 -- See Note [Printing foralls in type family instances] in IfaceType 603 ppr_binders = maybe_index <+> 604 pprUserIfaceForAll (map (mkIfaceForAllTvBndr Specified) tvs) 605 pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys) 606 607 -- See Note [Displaying axiom incompatibilities] 608 maybe_index 609 = sdocWithDynFlags $ \dflags -> 610 ppWhen (gopt Opt_PrintAxiomIncomps dflags) $ 611 text "{-" <+> (text "#" <> ppr idx) <+> text "-}" 612 maybe_incomps 613 = sdocWithDynFlags $ \dflags -> 614 ppWhen (gopt Opt_PrintAxiomIncomps dflags && notNull incomps) $ 615 text "--" <+> text "incompatible with:" 616 <+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps 617 618instance Outputable IfaceAnnotation where 619 ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value 620 621instance NamedThing IfaceClassOp where 622 getName (IfaceClassOp n _ _) = n 623 624instance HasOccName IfaceClassOp where 625 occName = getOccName 626 627instance NamedThing IfaceConDecl where 628 getName = ifConName 629 630instance HasOccName IfaceConDecl where 631 occName = getOccName 632 633instance NamedThing IfaceDecl where 634 getName = ifName 635 636instance HasOccName IfaceDecl where 637 occName = getOccName 638 639instance Outputable IfaceDecl where 640 ppr = pprIfaceDecl showToIface 641 642{- 643Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 644The minimal complete definition should only be included if a complete 645class definition is shown. Since the minimal complete definition is 646anonymous we can't reuse the same mechanism that is used for the 647filtering of method signatures. Instead we just check if anything at all is 648filtered and hide it in that case. 649-} 650 651data ShowSub 652 = ShowSub 653 { ss_how_much :: ShowHowMuch 654 , ss_forall :: ShowForAllFlag } 655 656-- See Note [Printing IfaceDecl binders] 657-- The alternative pretty printer referred to in the note. 658newtype AltPpr = AltPpr (Maybe (OccName -> SDoc)) 659 660data ShowHowMuch 661 = ShowHeader AltPpr -- ^Header information only, not rhs 662 | ShowSome [OccName] AltPpr 663 -- ^ Show only some sub-components. Specifically, 664 -- 665 -- [@[]@] Print all sub-components. 666 -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@; 667 -- elide other sub-components to @...@ 668 -- May 14: the list is max 1 element long at the moment 669 | ShowIface 670 -- ^Everything including GHC-internal information (used in --show-iface) 671 672{- 673Note [Printing IfaceDecl binders] 674~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 675The binders in an IfaceDecl are just OccNames, so we don't know what module they 676come from. But when we pretty-print a TyThing by converting to an IfaceDecl 677(see PprTyThing), the TyThing may come from some other module so we really need 678the module qualifier. We solve this by passing in a pretty-printer for the 679binders. 680 681When printing an interface file (--show-iface), we want to print 682everything unqualified, so we can just print the OccName directly. 683-} 684 685instance Outputable ShowHowMuch where 686 ppr (ShowHeader _) = text "ShowHeader" 687 ppr ShowIface = text "ShowIface" 688 ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs 689 690showToHeader :: ShowSub 691showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing 692 , ss_forall = ShowForAllWhen } 693 694showToIface :: ShowSub 695showToIface = ShowSub { ss_how_much = ShowIface 696 , ss_forall = ShowForAllWhen } 697 698ppShowIface :: ShowSub -> SDoc -> SDoc 699ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc 700ppShowIface _ _ = Outputable.empty 701 702-- show if all sub-components or the complete interface is shown 703ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition] 704ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc 705ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc 706ppShowAllSubs _ _ = Outputable.empty 707 708ppShowRhs :: ShowSub -> SDoc -> SDoc 709ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty 710ppShowRhs _ doc = doc 711 712showSub :: HasOccName n => ShowSub -> n -> Bool 713showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False 714showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing 715showSub (ShowSub { ss_how_much = _ }) _ = True 716 717ppr_trim :: [Maybe SDoc] -> [SDoc] 718-- Collapse a group of Nothings to a single "..." 719ppr_trim xs 720 = snd (foldr go (False, []) xs) 721 where 722 go (Just doc) (_, so_far) = (False, doc : so_far) 723 go Nothing (True, so_far) = (True, so_far) 724 go Nothing (False, so_far) = (True, text "..." : so_far) 725 726isIfaceDataInstance :: IfaceTyConParent -> Bool 727isIfaceDataInstance IfNoParent = False 728isIfaceDataInstance _ = True 729 730pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc 731pprClassRoles ss clas binders roles = 732 pprRoles (== Nominal) 733 (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) 734 binders 735 roles 736 737pprClassStandaloneKindSig :: ShowSub -> IfaceTopBndr -> IfaceKind -> SDoc 738pprClassStandaloneKindSig ss clas = 739 pprStandaloneKindSig (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) 740 741constraintIfaceKind :: IfaceKind 742constraintIfaceKind = 743 IfaceTyConApp (IfaceTyCon constraintKindTyConName (IfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil 744 745pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc 746-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi 747-- See Note [Pretty-printing TyThings] in PprTyThing 748pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, 749 ifCtxt = context, ifResKind = kind, 750 ifRoles = roles, ifCons = condecls, 751 ifParent = parent, 752 ifGadtSyntax = gadt, 753 ifBinders = binders }) 754 755 | gadt = vcat [ pp_roles 756 , pp_ki_sig 757 , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where 758 , nest 2 (vcat pp_cons) 759 , nest 2 $ ppShowIface ss pp_extra ] 760 | otherwise = vcat [ pp_roles 761 , pp_ki_sig 762 , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) 763 , nest 2 $ ppShowIface ss pp_extra ] 764 where 765 is_data_instance = isIfaceDataInstance parent 766 -- See Note [Printing foralls in type family instances] in IfaceType 767 pp_data_inst_forall :: SDoc 768 pp_data_inst_forall = pprUserIfaceForAll forall_bndrs 769 770 forall_bndrs :: [IfaceForAllBndr] 771 forall_bndrs = [Bndr (binderVar tc_bndr) Specified | tc_bndr <- binders] 772 773 cons = visibleIfConDecls condecls 774 pp_where = ppWhen (gadt && not (null cons)) $ text "where" 775 pp_cons = ppr_trim (map show_con cons) :: [SDoc] 776 pp_kind = ppUnless (if ki_sig_printable 777 then isIfaceTauType kind 778 -- Even in the presence of a standalone kind signature, a non-tau 779 -- result kind annotation cannot be discarded as it determines the arity. 780 -- See Note [Arity inference in kcDeclHeader_sig] in TcHsType 781 else isIfaceLiftedTypeKind kind) 782 (dcolon <+> ppr kind) 783 784 pp_lhs = case parent of 785 IfNoParent -> pprIfaceDeclHead suppress_bndr_sig context ss tycon binders 786 IfDataInstance{} 787 -> text "instance" <+> pp_data_inst_forall 788 <+> pprIfaceTyConParent parent 789 790 pp_roles 791 | is_data_instance = empty 792 | otherwise = pprRoles (== Representational) name_doc binders roles 793 -- Don't display roles for data family instances (yet) 794 -- See discussion on #8672. 795 796 ki_sig_printable = 797 -- If we print a standalone kind signature for a data instance, we leak 798 -- the internal constructor name: 799 -- 800 -- type T15827.R:Dka :: forall k. k -> * 801 -- data instance forall k (a :: k). D a = MkD (Proxy a) 802 -- 803 -- This T15827.R:Dka is a compiler-generated type constructor for the 804 -- data instance. 805 not is_data_instance 806 807 pp_ki_sig = ppWhen ki_sig_printable $ 808 pprStandaloneKindSig name_doc (mkIfaceTyConKind binders kind) 809 810 -- See Note [Suppressing binder signatures] in IfaceType 811 suppress_bndr_sig = SuppressBndrSig ki_sig_printable 812 813 name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) 814 815 add_bars [] = Outputable.empty 816 add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs) 817 818 ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc) 819 820 show_con dc 821 | ok_con dc = Just $ pprIfaceConDecl ss gadt tycon binders parent dc 822 | otherwise = Nothing 823 824 pp_nd = case condecls of 825 IfAbstractTyCon{} -> text "data" 826 IfDataTyCon{} -> text "data" 827 IfNewTyCon{} -> text "newtype" 828 829 pp_extra = vcat [pprCType ctype] 830 831pprIfaceDecl ss (IfaceClass { ifName = clas 832 , ifRoles = roles 833 , ifFDs = fds 834 , ifBinders = binders 835 , ifBody = IfAbstractClass }) 836 = vcat [ pprClassRoles ss clas binders roles 837 , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) 838 , text "class" <+> pprIfaceDeclHead suppress_bndr_sig [] ss clas binders <+> pprFundeps fds ] 839 where 840 -- See Note [Suppressing binder signatures] in IfaceType 841 suppress_bndr_sig = SuppressBndrSig True 842 843pprIfaceDecl ss (IfaceClass { ifName = clas 844 , ifRoles = roles 845 , ifFDs = fds 846 , ifBinders = binders 847 , ifBody = IfConcreteClass { 848 ifATs = ats, 849 ifSigs = sigs, 850 ifClassCtxt = context, 851 ifMinDef = minDef 852 }}) 853 = vcat [ pprClassRoles ss clas binders roles 854 , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) 855 , text "class" <+> pprIfaceDeclHead suppress_bndr_sig context ss clas binders <+> pprFundeps fds <+> pp_where 856 , nest 2 (vcat [ vcat asocs, vcat dsigs 857 , ppShowAllSubs ss (pprMinDef minDef)])] 858 where 859 pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") 860 861 asocs = ppr_trim $ map maybeShowAssoc ats 862 dsigs = ppr_trim $ map maybeShowSig sigs 863 864 maybeShowAssoc :: IfaceAT -> Maybe SDoc 865 maybeShowAssoc asc@(IfaceAT d _) 866 | showSub ss d = Just $ pprIfaceAT ss asc 867 | otherwise = Nothing 868 869 maybeShowSig :: IfaceClassOp -> Maybe SDoc 870 maybeShowSig sg 871 | showSub ss sg = Just $ pprIfaceClassOp ss sg 872 | otherwise = Nothing 873 874 pprMinDef :: BooleanFormula IfLclName -> SDoc 875 pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions 876 text "{-# MINIMAL" <+> 877 pprBooleanFormula 878 (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> 879 text "#-}" 880 881 -- See Note [Suppressing binder signatures] in IfaceType 882 suppress_bndr_sig = SuppressBndrSig True 883 884pprIfaceDecl ss (IfaceSynonym { ifName = tc 885 , ifBinders = binders 886 , ifSynRhs = mono_ty 887 , ifResKind = res_kind}) 888 = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) 889 , hang (text "type" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tc binders <+> equals) 890 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau 891 , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ]) 892 ] 893 where 894 (tvs, theta, tau) = splitIfaceSigmaTy mono_ty 895 name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc) 896 897 -- See Note [Suppressing binder signatures] in IfaceType 898 suppress_bndr_sig = SuppressBndrSig True 899 900pprIfaceDecl ss (IfaceFamily { ifName = tycon 901 , ifFamFlav = rhs, ifBinders = binders 902 , ifResKind = res_kind 903 , ifResVar = res_var, ifFamInj = inj }) 904 | IfaceDataFamilyTyCon <- rhs 905 = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) 906 , text "data family" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders 907 ] 908 909 | otherwise 910 = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) 911 , hang (text "type family" 912 <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders 913 <+> ppShowRhs ss (pp_where rhs)) 914 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) 915 $$ 916 nest 2 (ppShowRhs ss (pp_branches rhs)) 917 ] 918 where 919 name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) 920 921 pp_where (IfaceClosedSynFamilyTyCon {}) = text "where" 922 pp_where _ = empty 923 924 pp_inj Nothing _ = empty 925 pp_inj (Just res) inj 926 | Injective injectivity <- inj = hsep [ equals, ppr res 927 , pp_inj_cond res injectivity] 928 | otherwise = hsep [ equals, ppr res ] 929 930 pp_inj_cond res inj = case filterByList inj binders of 931 [] -> empty 932 tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)] 933 934 pp_rhs IfaceDataFamilyTyCon 935 = ppShowIface ss (text "data") 936 pp_rhs IfaceOpenSynFamilyTyCon 937 = ppShowIface ss (text "open") 938 pp_rhs IfaceAbstractClosedSynFamilyTyCon 939 = ppShowIface ss (text "closed, abstract") 940 pp_rhs (IfaceClosedSynFamilyTyCon {}) 941 = empty -- see pp_branches 942 pp_rhs IfaceBuiltInSynFamTyCon 943 = ppShowIface ss (text "built-in") 944 945 pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) 946 = vcat (unzipWith (pprAxBranch 947 (pprPrefixIfDeclBndr 948 (ss_how_much ss) 949 (occName tycon)) 950 ) $ zip [0..] brs) 951 $$ ppShowIface ss (text "axiom" <+> ppr ax) 952 pp_branches _ = Outputable.empty 953 954 -- See Note [Suppressing binder signatures] in IfaceType 955 suppress_bndr_sig = SuppressBndrSig True 956 957pprIfaceDecl _ (IfacePatSyn { ifName = name, 958 ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs, 959 ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, 960 ifPatArgs = arg_tys, 961 ifPatTy = pat_ty} ) 962 = sdocWithDynFlags mk_msg 963 where 964 mk_msg dflags 965 = hang (text "pattern" <+> pprPrefixOcc name) 966 2 (dcolon <+> sep [univ_msg 967 , pprIfaceContextArr req_ctxt 968 , ppWhen insert_empty_ctxt $ parens empty <+> darrow 969 , ex_msg 970 , pprIfaceContextArr prov_ctxt 971 , pprIfaceType $ foldr (IfaceFunTy VisArg) pat_ty arg_tys ]) 972 where 973 univ_msg = pprUserIfaceForAll univ_bndrs 974 ex_msg = pprUserIfaceForAll ex_bndrs 975 976 insert_empty_ctxt = null req_ctxt 977 && not (null prov_ctxt && isEmpty dflags ex_msg) 978 979pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, 980 ifIdDetails = details, ifIdInfo = info }) 981 = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon) 982 2 (pprIfaceSigmaType (ss_forall ss) ty) 983 , ppShowIface ss (ppr details) 984 , ppShowIface ss (ppr info) ] 985 986pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon 987 , ifAxBranches = branches }) 988 = hang (text "axiom" <+> ppr name <+> dcolon) 989 2 (vcat $ unzipWith (pprAxBranch (ppr tycon)) $ zip [0..] branches) 990 991pprCType :: Maybe CType -> SDoc 992pprCType Nothing = Outputable.empty 993pprCType (Just cType) = text "C type:" <+> ppr cType 994 995-- if, for each role, suppress_if role is True, then suppress the role 996-- output 997pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder] 998 -> [Role] -> SDoc 999pprRoles suppress_if tyCon bndrs roles 1000 = sdocWithDynFlags $ \dflags -> 1001 let froles = suppressIfaceInvisibles dflags bndrs roles 1002 in ppUnless (all suppress_if froles || null froles) $ 1003 text "type role" <+> tyCon <+> hsep (map ppr froles) 1004 1005pprStandaloneKindSig :: SDoc -> IfaceType -> SDoc 1006pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> text "::" <+> ppr ty 1007 1008pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc 1009pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name 1010 = pprInfixVar (isSymOcc name) (ppr_bndr name) 1011pprInfixIfDeclBndr _ name 1012 = pprInfixVar (isSymOcc name) (ppr name) 1013 1014pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc 1015pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name 1016 = parenSymOcc name (ppr_bndr name) 1017pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name 1018 = parenSymOcc name (ppr_bndr name) 1019pprPrefixIfDeclBndr _ name 1020 = parenSymOcc name (ppr name) 1021 1022instance Outputable IfaceClassOp where 1023 ppr = pprIfaceClassOp showToIface 1024 1025pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc 1026pprIfaceClassOp ss (IfaceClassOp n ty dm) 1027 = pp_sig n ty $$ generic_dm 1028 where 1029 generic_dm | Just (GenericDM dm_ty) <- dm 1030 = text "default" <+> pp_sig n dm_ty 1031 | otherwise 1032 = empty 1033 pp_sig n ty 1034 = pprPrefixIfDeclBndr (ss_how_much ss) (occName n) 1035 <+> dcolon 1036 <+> pprIfaceSigmaType ShowForAllWhen ty 1037 1038instance Outputable IfaceAT where 1039 ppr = pprIfaceAT showToIface 1040 1041pprIfaceAT :: ShowSub -> IfaceAT -> SDoc 1042pprIfaceAT ss (IfaceAT d mb_def) 1043 = vcat [ pprIfaceDecl ss d 1044 , case mb_def of 1045 Nothing -> Outputable.empty 1046 Just rhs -> nest 2 $ 1047 text "Default:" <+> ppr rhs ] 1048 1049instance Outputable IfaceTyConParent where 1050 ppr p = pprIfaceTyConParent p 1051 1052pprIfaceTyConParent :: IfaceTyConParent -> SDoc 1053pprIfaceTyConParent IfNoParent 1054 = Outputable.empty 1055pprIfaceTyConParent (IfDataInstance _ tc tys) 1056 = pprIfaceTypeApp topPrec tc tys 1057 1058pprIfaceDeclHead :: SuppressBndrSig 1059 -> IfaceContext -> ShowSub -> Name 1060 -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression 1061 -> SDoc 1062pprIfaceDeclHead suppress_sig context ss tc_occ bndrs 1063 = sdocWithDynFlags $ \ dflags -> 1064 sep [ pprIfaceContextArr context 1065 , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ) 1066 <+> pprIfaceTyConBinders suppress_sig 1067 (suppressIfaceInvisibles dflags bndrs bndrs) ] 1068 1069pprIfaceConDecl :: ShowSub -> Bool 1070 -> IfaceTopBndr 1071 -> [IfaceTyConBinder] 1072 -> IfaceTyConParent 1073 -> IfaceConDecl -> SDoc 1074pprIfaceConDecl ss gadt_style tycon tc_binders parent 1075 (IfCon { ifConName = name, ifConInfix = is_infix, 1076 ifConUserTvBinders = user_tvbs, 1077 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, 1078 ifConStricts = stricts, ifConFields = fields }) 1079 | gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty 1080 | otherwise = ppr_ex_quant pp_h98_con 1081 where 1082 pp_h98_con 1083 | not (null fields) = pp_prefix_con <+> pp_field_args 1084 | is_infix 1085 , [ty1, ty2] <- pp_args 1086 = sep [ ty1 1087 , pprInfixIfDeclBndr how_much (occName name) 1088 , ty2] 1089 | otherwise = pp_prefix_con <+> sep pp_args 1090 1091 how_much = ss_how_much ss 1092 tys_w_strs :: [(IfaceBang, IfaceType)] 1093 tys_w_strs = zip stricts arg_tys 1094 pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name) 1095 1096 -- If we're pretty-printing a H98-style declaration with existential 1097 -- quantification, then user_tvbs will always consist of the universal 1098 -- tyvar binders followed by the existential tyvar binders. So to recover 1099 -- the visibilities of the existential tyvar binders, we can simply drop 1100 -- the universal tyvar binders from user_tvbs. 1101 ex_tvbs = dropList tc_binders user_tvbs 1102 ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt 1103 pp_gadt_res_ty = mk_user_con_res_ty eq_spec 1104 ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau 1105 1106 -- A bit gruesome this, but we can't form the full con_tau, and ppr it, 1107 -- because we don't have a Name for the tycon, only an OccName 1108 pp_tau | null fields 1109 = case pp_args ++ [pp_gadt_res_ty] of 1110 (t:ts) -> fsep (t : map (arrow <+>) ts) 1111 [] -> panic "pp_con_taus" 1112 | otherwise 1113 = sep [pp_field_args, arrow <+> pp_gadt_res_ty] 1114 1115 ppr_bang IfNoBang = whenPprDebug $ char '_' 1116 ppr_bang IfStrict = char '!' 1117 ppr_bang IfUnpack = text "{-# UNPACK #-}" 1118 ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> 1119 pprParendIfaceCoercion co 1120 1121 pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc 1122 -- If using record syntax, the only reason one would need to parenthesize 1123 -- a compound field type is if it's preceded by a bang pattern. 1124 pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty 1125 -- If not using record syntax, a compound field type might need to be 1126 -- parenthesized if one of the following holds: 1127 -- 1128 -- 1. We're using Haskell98 syntax. 1129 -- 2. The field type is preceded with a bang pattern. 1130 pprArgTy (bang, ty) = ppr_arg_ty (max gadt_prec (bang_prec bang)) bang ty 1131 1132 ppr_arg_ty :: PprPrec -> IfaceBang -> IfaceType -> SDoc 1133 ppr_arg_ty prec bang ty = ppr_bang bang <> pprPrecIfaceType prec ty 1134 1135 -- If we're displaying the fields GADT-style, e.g., 1136 -- 1137 -- data Foo a where 1138 -- MkFoo :: (Int -> Int) -> Maybe a -> Foo 1139 -- 1140 -- Then we use `funPrec`, since that will ensure `Int -> Int` gets the 1141 -- parentheses that it requires, but simple compound types like `Maybe a` 1142 -- (which don't require parentheses in a function argument position) won't 1143 -- get them, assuming that there are no bang patterns (see bang_prec). 1144 -- 1145 -- If we're displaying the fields Haskell98-style, e.g., 1146 -- 1147 -- data Foo a = MkFoo (Int -> Int) (Maybe a) 1148 -- 1149 -- Then not only must we parenthesize `Int -> Int`, we must also 1150 -- parenthesize compound fields like (Maybe a). Therefore, we pick 1151 -- `appPrec`, which has higher precedence than `funPrec`. 1152 gadt_prec :: PprPrec 1153 gadt_prec 1154 | gadt_style = funPrec 1155 | otherwise = appPrec 1156 1157 -- The presence of bang patterns or UNPACK annotations requires 1158 -- surrounding the type with parentheses, if needed (#13699) 1159 bang_prec :: IfaceBang -> PprPrec 1160 bang_prec IfNoBang = topPrec 1161 bang_prec IfStrict = appPrec 1162 bang_prec IfUnpack = appPrec 1163 bang_prec IfUnpackCo{} = appPrec 1164 1165 pp_args :: [SDoc] -- No records, e.g., ` Maybe a -> Int -> ...` or 1166 -- `!(Maybe a) -> !Int -> ...` 1167 pp_args = map pprArgTy tys_w_strs 1168 1169 pp_field_args :: SDoc -- Records, e.g., { x :: Maybe a, y :: Int } or 1170 -- { x :: !(Maybe a), y :: !Int } 1171 pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $ 1172 zipWith maybe_show_label fields tys_w_strs 1173 1174 maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc 1175 maybe_show_label lbl bty 1176 | showSub ss sel = Just (pprPrefixIfDeclBndr how_much occ 1177 <+> dcolon <+> pprFieldArgTy bty) 1178 | otherwise = Nothing 1179 where 1180 sel = flSelector lbl 1181 occ = mkVarOccFS (flLabel lbl) 1182 1183 mk_user_con_res_ty :: IfaceEqSpec -> SDoc 1184 -- See Note [Result type of a data family GADT] 1185 mk_user_con_res_ty eq_spec 1186 | IfDataInstance _ tc tys <- parent 1187 = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys)) 1188 | otherwise 1189 = ppr_tc_app gadt_subst 1190 where 1191 gadt_subst = mkIfaceTySubst eq_spec 1192 1193 -- When pretty-printing a GADT return type, we: 1194 -- 1195 -- 1. Take the data tycon binders, extract their variable names and 1196 -- visibilities, and construct suitable arguments from them. (This is 1197 -- the role of mk_tc_app_args.) 1198 -- 2. Apply the GADT substitution constructed from the eq_spec. 1199 -- (See Note [Result type of a data family GADT].) 1200 -- 3. Pretty-print the data type constructor applied to its arguments. 1201 -- This process will omit any invisible arguments, such as coercion 1202 -- variables, if necessary. (See Note 1203 -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.) 1204 ppr_tc_app gadt_subst = 1205 pprPrefixIfDeclBndr how_much (occName tycon) 1206 <+> pprParendIfaceAppArgs 1207 (substIfaceAppArgs gadt_subst (mk_tc_app_args tc_binders)) 1208 1209 mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs 1210 mk_tc_app_args [] = IA_Nil 1211 mk_tc_app_args (Bndr bndr vis:tc_bndrs) = 1212 IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisArgFlag vis) 1213 (mk_tc_app_args tc_bndrs) 1214 1215instance Outputable IfaceRule where 1216 ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, 1217 ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, 1218 ifRuleOrph = orph }) 1219 = sep [ hsep [ pprRuleName name 1220 , if isOrphan orph then text "[orphan]" else Outputable.empty 1221 , ppr act 1222 , pp_foralls ] 1223 , nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), 1224 text "=" <+> ppr rhs]) ] 1225 where 1226 pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot 1227 1228instance Outputable IfaceClsInst where 1229 ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag 1230 , ifInstCls = cls, ifInstTys = mb_tcs 1231 , ifInstOrph = orph }) 1232 = hang (text "instance" <+> ppr flag 1233 <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) 1234 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 1235 2 (equals <+> ppr dfun_id) 1236 1237instance Outputable IfaceFamInst where 1238 ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs 1239 , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph }) 1240 = hang (text "family instance" 1241 <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) 1242 <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) 1243 2 (equals <+> ppr tycon_ax) 1244 1245ppr_rough :: Maybe IfaceTyCon -> SDoc 1246ppr_rough Nothing = dot 1247ppr_rough (Just tc) = ppr tc 1248 1249{- 1250Note [Result type of a data family GADT] 1251~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1252Consider 1253 data family T a 1254 data instance T (p,q) where 1255 T1 :: T (Int, Maybe c) 1256 T2 :: T (Bool, q) 1257 1258The IfaceDecl actually looks like 1259 1260 data TPr p q where 1261 T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q 1262 T2 :: forall p q. (p~Bool) => TPr p q 1263 1264To reconstruct the result types for T1 and T2 that we 1265want to pretty print, we substitute the eq-spec 1266[p->Int, q->Maybe c] in the arg pattern (p,q) to give 1267 T (Int, Maybe c) 1268Remember that in IfaceSyn, the TyCon and DataCon share the same 1269universal type variables. 1270 1271----------------------------- Printing IfaceExpr ------------------------------------ 1272-} 1273 1274instance Outputable IfaceExpr where 1275 ppr e = pprIfaceExpr noParens e 1276 1277noParens :: SDoc -> SDoc 1278noParens pp = pp 1279 1280pprParendIfaceExpr :: IfaceExpr -> SDoc 1281pprParendIfaceExpr = pprIfaceExpr parens 1282 1283-- | Pretty Print an IfaceExpre 1284-- 1285-- The first argument should be a function that adds parens in context that need 1286-- an atomic value (e.g. function args) 1287pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc 1288 1289pprIfaceExpr _ (IfaceLcl v) = ppr v 1290pprIfaceExpr _ (IfaceExt v) = ppr v 1291pprIfaceExpr _ (IfaceLit l) = ppr l 1292pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) 1293pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty 1294pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co 1295 1296pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) 1297pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) 1298 1299pprIfaceExpr add_par i@(IfaceLam _ _) 1300 = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, 1301 pprIfaceExpr noParens body]) 1302 where 1303 (bndrs,body) = collect [] i 1304 collect bs (IfaceLam b e) = collect (b:bs) e 1305 collect bs e = (reverse bs, e) 1306 1307pprIfaceExpr add_par (IfaceECase scrut ty) 1308 = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut 1309 , text "ret_ty" <+> pprParendIfaceType ty 1310 , text "of {}" ]) 1311 1312pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) 1313 = add_par (sep [text "case" 1314 <+> pprIfaceExpr noParens scrut <+> text "of" 1315 <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, 1316 pprIfaceExpr noParens rhs <+> char '}']) 1317 1318pprIfaceExpr add_par (IfaceCase scrut bndr alts) 1319 = add_par (sep [text "case" 1320 <+> pprIfaceExpr noParens scrut <+> text "of" 1321 <+> ppr bndr <+> char '{', 1322 nest 2 (sep (map ppr_alt alts)) <+> char '}']) 1323 1324pprIfaceExpr _ (IfaceCast expr co) 1325 = sep [pprParendIfaceExpr expr, 1326 nest 2 (text "`cast`"), 1327 pprParendIfaceCoercion co] 1328 1329pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) 1330 = add_par (sep [text "let {", 1331 nest 2 (ppr_bind (b, rhs)), 1332 text "} in", 1333 pprIfaceExpr noParens body]) 1334 1335pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) 1336 = add_par (sep [text "letrec {", 1337 nest 2 (sep (map ppr_bind pairs)), 1338 text "} in", 1339 pprIfaceExpr noParens body]) 1340 1341pprIfaceExpr add_par (IfaceTick tickish e) 1342 = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) 1343 1344ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc 1345ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, 1346 arrow <+> pprIfaceExpr noParens rhs] 1347 1348ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc 1349ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) 1350 1351ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc 1352ppr_bind (IfLetBndr b ty info ji, rhs) 1353 = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info), 1354 equals <+> pprIfaceExpr noParens rhs] 1355 1356------------------ 1357pprIfaceTickish :: IfaceTickish -> SDoc 1358pprIfaceTickish (IfaceHpcTick m ix) 1359 = braces (text "tick" <+> ppr m <+> ppr ix) 1360pprIfaceTickish (IfaceSCC cc tick scope) 1361 = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) 1362pprIfaceTickish (IfaceSource src _names) 1363 = braces (pprUserRealSpan True src) 1364 1365------------------ 1366pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc 1367pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ 1368 nest 2 (pprParendIfaceExpr arg) : args 1369pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) 1370 1371------------------ 1372instance Outputable IfaceConAlt where 1373 ppr IfaceDefault = text "DEFAULT" 1374 ppr (IfaceLitAlt l) = ppr l 1375 ppr (IfaceDataAlt d) = ppr d 1376 1377------------------ 1378instance Outputable IfaceIdDetails where 1379 ppr IfVanillaId = Outputable.empty 1380 ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc 1381 <+> if b 1382 then text "<naughty>" 1383 else Outputable.empty 1384 ppr IfDFunId = text "DFunId" 1385 1386instance Outputable IfaceIdInfo where 1387 ppr NoInfo = Outputable.empty 1388 ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is 1389 <+> text "-}" 1390 1391instance Outputable IfaceInfoItem where 1392 ppr (HsUnfold lb unf) = text "Unfolding" 1393 <> ppWhen lb (text "(loop-breaker)") 1394 <> colon <+> ppr unf 1395 ppr (HsInline prag) = text "Inline:" <+> ppr prag 1396 ppr (HsArity arity) = text "Arity:" <+> int arity 1397 ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str 1398 ppr HsNoCafRefs = text "HasNoCafRefs" 1399 ppr HsLevity = text "Never levity-polymorphic" 1400 1401instance Outputable IfaceJoinInfo where 1402 ppr IfaceNotJoinPoint = empty 1403 ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar) 1404 1405instance Outputable IfaceUnfolding where 1406 ppr (IfCompulsory e) = text "<compulsory>" <+> parens (ppr e) 1407 ppr (IfCoreUnfold s e) = (if s 1408 then text "<stable>" 1409 else Outputable.empty) 1410 <+> parens (ppr e) 1411 ppr (IfInlineRule a uok bok e) = sep [text "InlineRule" 1412 <+> ppr (a,uok,bok), 1413 pprParendIfaceExpr e] 1414 ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) 1415 2 (sep (map pprParendIfaceExpr es)) 1416 1417{- 1418************************************************************************ 1419* * 1420 Finding the Names in IfaceSyn 1421* * 1422************************************************************************ 1423 1424This is used for dependency analysis in MkIface, so that we 1425fingerprint a declaration before the things that depend on it. It 1426is specific to interface-file fingerprinting in the sense that we 1427don't collect *all* Names: for example, the DFun of an instance is 1428recorded textually rather than by its fingerprint when 1429fingerprinting the instance, so DFuns are not dependencies. 1430-} 1431 1432freeNamesIfDecl :: IfaceDecl -> NameSet 1433freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i}) 1434 = freeNamesIfType t &&& 1435 freeNamesIfIdInfo i &&& 1436 freeNamesIfIdDetails d 1437 1438freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k 1439 , ifParent = p, ifCtxt = ctxt, ifCons = cons }) 1440 = freeNamesIfVarBndrs bndrs &&& 1441 freeNamesIfType res_k &&& 1442 freeNamesIfaceTyConParent p &&& 1443 freeNamesIfContext ctxt &&& 1444 freeNamesIfConDecls cons 1445 1446freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k 1447 , ifSynRhs = rhs }) 1448 = freeNamesIfVarBndrs bndrs &&& 1449 freeNamesIfKind res_k &&& 1450 freeNamesIfType rhs 1451 1452freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k 1453 , ifFamFlav = flav }) 1454 = freeNamesIfVarBndrs bndrs &&& 1455 freeNamesIfKind res_k &&& 1456 freeNamesIfFamFlav flav 1457 1458freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body }) 1459 = freeNamesIfVarBndrs bndrs &&& 1460 freeNamesIfClassBody cls_body 1461 1462freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches }) 1463 = freeNamesIfTc tc &&& 1464 fnList freeNamesIfAxBranch branches 1465 1466freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _) 1467 , ifPatBuilder = mb_builder 1468 , ifPatUnivBndrs = univ_bndrs 1469 , ifPatExBndrs = ex_bndrs 1470 , ifPatProvCtxt = prov_ctxt 1471 , ifPatReqCtxt = req_ctxt 1472 , ifPatArgs = args 1473 , ifPatTy = pat_ty 1474 , ifFieldLabels = lbls }) 1475 = unitNameSet matcher &&& 1476 maybe emptyNameSet (unitNameSet . fst) mb_builder &&& 1477 freeNamesIfVarBndrs univ_bndrs &&& 1478 freeNamesIfVarBndrs ex_bndrs &&& 1479 freeNamesIfContext prov_ctxt &&& 1480 freeNamesIfContext req_ctxt &&& 1481 fnList freeNamesIfType args &&& 1482 freeNamesIfType pat_ty &&& 1483 mkNameSet (map flSelector lbls) 1484 1485freeNamesIfClassBody :: IfaceClassBody -> NameSet 1486freeNamesIfClassBody IfAbstractClass 1487 = emptyNameSet 1488freeNamesIfClassBody (IfConcreteClass{ ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }) 1489 = freeNamesIfContext ctxt &&& 1490 fnList freeNamesIfAT ats &&& 1491 fnList freeNamesIfClsSig sigs 1492 1493freeNamesIfAxBranch :: IfaceAxBranch -> NameSet 1494freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars 1495 , ifaxbCoVars = covars 1496 , ifaxbLHS = lhs 1497 , ifaxbRHS = rhs }) 1498 = fnList freeNamesIfTvBndr tyvars &&& 1499 fnList freeNamesIfIdBndr covars &&& 1500 freeNamesIfAppArgs lhs &&& 1501 freeNamesIfType rhs 1502 1503freeNamesIfIdDetails :: IfaceIdDetails -> NameSet 1504freeNamesIfIdDetails (IfRecSelId tc _) = 1505 either freeNamesIfTc freeNamesIfDecl tc 1506freeNamesIfIdDetails _ = emptyNameSet 1507 1508-- All other changes are handled via the version info on the tycon 1509freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet 1510freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet 1511freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet 1512freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br))) 1513 = unitNameSet ax &&& fnList freeNamesIfAxBranch br 1514freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet 1515freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet 1516freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet 1517 1518freeNamesIfContext :: IfaceContext -> NameSet 1519freeNamesIfContext = fnList freeNamesIfType 1520 1521freeNamesIfAT :: IfaceAT -> NameSet 1522freeNamesIfAT (IfaceAT decl mb_def) 1523 = freeNamesIfDecl decl &&& 1524 case mb_def of 1525 Nothing -> emptyNameSet 1526 Just rhs -> freeNamesIfType rhs 1527 1528freeNamesIfClsSig :: IfaceClassOp -> NameSet 1529freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm 1530 1531freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet 1532freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty 1533freeNamesDM _ = emptyNameSet 1534 1535freeNamesIfConDecls :: IfaceConDecls -> NameSet 1536freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c 1537freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c 1538freeNamesIfConDecls _ = emptyNameSet 1539 1540freeNamesIfConDecl :: IfaceConDecl -> NameSet 1541freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt 1542 , ifConArgTys = arg_tys 1543 , ifConFields = flds 1544 , ifConEqSpec = eq_spec 1545 , ifConStricts = bangs }) 1546 = fnList freeNamesIfBndr ex_tvs &&& 1547 freeNamesIfContext ctxt &&& 1548 fnList freeNamesIfType arg_tys &&& 1549 mkNameSet (map flSelector flds) &&& 1550 fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints 1551 fnList freeNamesIfBang bangs 1552 1553freeNamesIfBang :: IfaceBang -> NameSet 1554freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co 1555freeNamesIfBang _ = emptyNameSet 1556 1557freeNamesIfKind :: IfaceType -> NameSet 1558freeNamesIfKind = freeNamesIfType 1559 1560freeNamesIfAppArgs :: IfaceAppArgs -> NameSet 1561freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts 1562freeNamesIfAppArgs IA_Nil = emptyNameSet 1563 1564freeNamesIfType :: IfaceType -> NameSet 1565freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet 1566freeNamesIfType (IfaceTyVar _) = emptyNameSet 1567freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t 1568freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts 1569freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts 1570freeNamesIfType (IfaceLitTy _) = emptyNameSet 1571freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t 1572freeNamesIfType (IfaceFunTy _ s t) = freeNamesIfType s &&& freeNamesIfType t 1573freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c 1574freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c 1575 1576freeNamesIfMCoercion :: IfaceMCoercion -> NameSet 1577freeNamesIfMCoercion IfaceMRefl = emptyNameSet 1578freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co 1579 1580freeNamesIfCoercion :: IfaceCoercion -> NameSet 1581freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t 1582freeNamesIfCoercion (IfaceGReflCo _ t mco) 1583 = freeNamesIfType t &&& freeNamesIfMCoercion mco 1584freeNamesIfCoercion (IfaceFunCo _ c1 c2) 1585 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 1586freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) 1587 = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos 1588freeNamesIfCoercion (IfaceAppCo c1 c2) 1589 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 1590freeNamesIfCoercion (IfaceForAllCo _ kind_co co) 1591 = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co 1592freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet 1593freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet 1594freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet 1595freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) 1596 = unitNameSet ax &&& fnList freeNamesIfCoercion cos 1597freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) 1598 = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2 1599freeNamesIfCoercion (IfaceSymCo c) 1600 = freeNamesIfCoercion c 1601freeNamesIfCoercion (IfaceTransCo c1 c2) 1602 = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 1603freeNamesIfCoercion (IfaceNthCo _ co) 1604 = freeNamesIfCoercion co 1605freeNamesIfCoercion (IfaceLRCo _ co) 1606 = freeNamesIfCoercion co 1607freeNamesIfCoercion (IfaceInstCo co co2) 1608 = freeNamesIfCoercion co &&& freeNamesIfCoercion co2 1609freeNamesIfCoercion (IfaceKindCo c) 1610 = freeNamesIfCoercion c 1611freeNamesIfCoercion (IfaceSubCo co) 1612 = freeNamesIfCoercion co 1613freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) 1614 -- the axiom is just a string, so we don't count it as a name. 1615 = fnList freeNamesIfCoercion cos 1616 1617freeNamesIfProv :: IfaceUnivCoProv -> NameSet 1618freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet 1619freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co 1620freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co 1621freeNamesIfProv (IfacePluginProv _) = emptyNameSet 1622 1623freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet 1624freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr 1625 1626freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet 1627freeNamesIfVarBndrs = fnList freeNamesIfVarBndr 1628 1629freeNamesIfBndr :: IfaceBndr -> NameSet 1630freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b 1631freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b 1632 1633freeNamesIfBndrs :: [IfaceBndr] -> NameSet 1634freeNamesIfBndrs = fnList freeNamesIfBndr 1635 1636freeNamesIfLetBndr :: IfaceLetBndr -> NameSet 1637-- Remember IfaceLetBndr is used only for *nested* bindings 1638-- The IdInfo can contain an unfolding (in the case of 1639-- local INLINE pragmas), so look there too 1640freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty 1641 &&& freeNamesIfIdInfo info 1642 1643freeNamesIfTvBndr :: IfaceTvBndr -> NameSet 1644freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k 1645 -- kinds can have Names inside, because of promotion 1646 1647freeNamesIfIdBndr :: IfaceIdBndr -> NameSet 1648freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k 1649 1650freeNamesIfIdInfo :: IfaceIdInfo -> NameSet 1651freeNamesIfIdInfo NoInfo = emptyNameSet 1652freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i 1653 1654freeNamesItem :: IfaceInfoItem -> NameSet 1655freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u 1656freeNamesItem _ = emptyNameSet 1657 1658freeNamesIfUnfold :: IfaceUnfolding -> NameSet 1659freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e 1660freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e 1661freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e 1662freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es 1663 1664freeNamesIfExpr :: IfaceExpr -> NameSet 1665freeNamesIfExpr (IfaceExt v) = unitNameSet v 1666freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty 1667freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty 1668freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co 1669freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as 1670freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body 1671freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a 1672freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co 1673freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e 1674freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty 1675freeNamesIfExpr (IfaceCase s _ alts) 1676 = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts 1677 where 1678 fn_alt (_con,_bs,r) = freeNamesIfExpr r 1679 1680 -- Depend on the data constructors. Just one will do! 1681 -- Note [Tracking data constructors] 1682 fn_cons [] = emptyNameSet 1683 fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs 1684 fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con 1685 fn_cons (_ : _ ) = emptyNameSet 1686 1687freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) 1688 = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body 1689 1690freeNamesIfExpr (IfaceLet (IfaceRec as) x) 1691 = fnList fn_pair as &&& freeNamesIfExpr x 1692 where 1693 fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs 1694 1695freeNamesIfExpr _ = emptyNameSet 1696 1697freeNamesIfTc :: IfaceTyCon -> NameSet 1698freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) 1699-- ToDo: shouldn't we include IfaceIntTc & co.? 1700 1701freeNamesIfRule :: IfaceRule -> NameSet 1702freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f 1703 , ifRuleArgs = es, ifRuleRhs = rhs }) 1704 = unitNameSet f &&& 1705 fnList freeNamesIfBndr bs &&& 1706 fnList freeNamesIfExpr es &&& 1707 freeNamesIfExpr rhs 1708 1709freeNamesIfFamInst :: IfaceFamInst -> NameSet 1710freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName 1711 , ifFamInstAxiom = axName }) 1712 = unitNameSet famName &&& 1713 unitNameSet axName 1714 1715freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet 1716freeNamesIfaceTyConParent IfNoParent = emptyNameSet 1717freeNamesIfaceTyConParent (IfDataInstance ax tc tys) 1718 = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys 1719 1720-- helpers 1721(&&&) :: NameSet -> NameSet -> NameSet 1722(&&&) = unionNameSet 1723 1724fnList :: (a -> NameSet) -> [a] -> NameSet 1725fnList f = foldr (&&&) emptyNameSet . map f 1726 1727{- 1728Note [Tracking data constructors] 1729~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1730In a case expression 1731 case e of { C a -> ...; ... } 1732You might think that we don't need to include the datacon C 1733in the free names, because its type will probably show up in 1734the free names of 'e'. But in rare circumstances this may 1735not happen. Here's the one that bit me: 1736 1737 module DynFlags where 1738 import {-# SOURCE #-} Packages( PackageState ) 1739 data DynFlags = DF ... PackageState ... 1740 1741 module Packages where 1742 import DynFlags 1743 data PackageState = PS ... 1744 lookupModule (df :: DynFlags) 1745 = case df of 1746 DF ...p... -> case p of 1747 PS ... -> ... 1748 1749Now, lookupModule depends on DynFlags, but the transitive dependency 1750on the *locally-defined* type PackageState is not visible. We need 1751to take account of the use of the data constructor PS in the pattern match. 1752 1753 1754************************************************************************ 1755* * 1756 Binary instances 1757* * 1758************************************************************************ 1759 1760Note that there is a bit of subtlety here when we encode names. While 1761IfaceTopBndrs is really just a synonym for Name, we need to take care to 1762encode them with {get,put}IfaceTopBndr. The difference becomes important when 1763we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for 1764details. 1765 1766-} 1767 1768instance Binary IfaceDecl where 1769 put_ bh (IfaceId name ty details idinfo) = do 1770 putByte bh 0 1771 putIfaceTopBndr bh name 1772 lazyPut bh (ty, details, idinfo) 1773 -- See Note [Lazy deserialization of IfaceId] 1774 1775 put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do 1776 putByte bh 2 1777 putIfaceTopBndr bh a1 1778 put_ bh a2 1779 put_ bh a3 1780 put_ bh a4 1781 put_ bh a5 1782 put_ bh a6 1783 put_ bh a7 1784 put_ bh a8 1785 put_ bh a9 1786 1787 put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do 1788 putByte bh 3 1789 putIfaceTopBndr bh a1 1790 put_ bh a2 1791 put_ bh a3 1792 put_ bh a4 1793 put_ bh a5 1794 1795 put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do 1796 putByte bh 4 1797 putIfaceTopBndr bh a1 1798 put_ bh a2 1799 put_ bh a3 1800 put_ bh a4 1801 put_ bh a5 1802 put_ bh a6 1803 1804 -- NB: Written in a funny way to avoid an interface change 1805 put_ bh (IfaceClass { 1806 ifName = a2, 1807 ifRoles = a3, 1808 ifBinders = a4, 1809 ifFDs = a5, 1810 ifBody = IfConcreteClass { 1811 ifClassCtxt = a1, 1812 ifATs = a6, 1813 ifSigs = a7, 1814 ifMinDef = a8 1815 }}) = do 1816 putByte bh 5 1817 put_ bh a1 1818 putIfaceTopBndr bh a2 1819 put_ bh a3 1820 put_ bh a4 1821 put_ bh a5 1822 put_ bh a6 1823 put_ bh a7 1824 put_ bh a8 1825 1826 put_ bh (IfaceAxiom a1 a2 a3 a4) = do 1827 putByte bh 6 1828 putIfaceTopBndr bh a1 1829 put_ bh a2 1830 put_ bh a3 1831 put_ bh a4 1832 1833 put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do 1834 putByte bh 7 1835 putIfaceTopBndr bh a1 1836 put_ bh a2 1837 put_ bh a3 1838 put_ bh a4 1839 put_ bh a5 1840 put_ bh a6 1841 put_ bh a7 1842 put_ bh a8 1843 put_ bh a9 1844 put_ bh a10 1845 put_ bh a11 1846 1847 put_ bh (IfaceClass { 1848 ifName = a1, 1849 ifRoles = a2, 1850 ifBinders = a3, 1851 ifFDs = a4, 1852 ifBody = IfAbstractClass }) = do 1853 putByte bh 8 1854 putIfaceTopBndr bh a1 1855 put_ bh a2 1856 put_ bh a3 1857 put_ bh a4 1858 1859 get bh = do 1860 h <- getByte bh 1861 case h of 1862 0 -> do name <- get bh 1863 ~(ty, details, idinfo) <- lazyGet bh 1864 -- See Note [Lazy deserialization of IfaceId] 1865 return (IfaceId name ty details idinfo) 1866 1 -> error "Binary.get(TyClDecl): ForeignType" 1867 2 -> do a1 <- getIfaceTopBndr bh 1868 a2 <- get bh 1869 a3 <- get bh 1870 a4 <- get bh 1871 a5 <- get bh 1872 a6 <- get bh 1873 a7 <- get bh 1874 a8 <- get bh 1875 a9 <- get bh 1876 return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) 1877 3 -> do a1 <- getIfaceTopBndr bh 1878 a2 <- get bh 1879 a3 <- get bh 1880 a4 <- get bh 1881 a5 <- get bh 1882 return (IfaceSynonym a1 a2 a3 a4 a5) 1883 4 -> do a1 <- getIfaceTopBndr bh 1884 a2 <- get bh 1885 a3 <- get bh 1886 a4 <- get bh 1887 a5 <- get bh 1888 a6 <- get bh 1889 return (IfaceFamily a1 a2 a3 a4 a5 a6) 1890 5 -> do a1 <- get bh 1891 a2 <- getIfaceTopBndr bh 1892 a3 <- get bh 1893 a4 <- get bh 1894 a5 <- get bh 1895 a6 <- get bh 1896 a7 <- get bh 1897 a8 <- get bh 1898 return (IfaceClass { 1899 ifName = a2, 1900 ifRoles = a3, 1901 ifBinders = a4, 1902 ifFDs = a5, 1903 ifBody = IfConcreteClass { 1904 ifClassCtxt = a1, 1905 ifATs = a6, 1906 ifSigs = a7, 1907 ifMinDef = a8 1908 }}) 1909 6 -> do a1 <- getIfaceTopBndr bh 1910 a2 <- get bh 1911 a3 <- get bh 1912 a4 <- get bh 1913 return (IfaceAxiom a1 a2 a3 a4) 1914 7 -> do a1 <- getIfaceTopBndr bh 1915 a2 <- get bh 1916 a3 <- get bh 1917 a4 <- get bh 1918 a5 <- get bh 1919 a6 <- get bh 1920 a7 <- get bh 1921 a8 <- get bh 1922 a9 <- get bh 1923 a10 <- get bh 1924 a11 <- get bh 1925 return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) 1926 8 -> do a1 <- getIfaceTopBndr bh 1927 a2 <- get bh 1928 a3 <- get bh 1929 a4 <- get bh 1930 return (IfaceClass { 1931 ifName = a1, 1932 ifRoles = a2, 1933 ifBinders = a3, 1934 ifFDs = a4, 1935 ifBody = IfAbstractClass }) 1936 _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) 1937 1938{- Note [Lazy deserialization of IfaceId] 1939~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1940The use of lazyPut and lazyGet in the IfaceId Binary instance is 1941purely for performance reasons, to avoid deserializing details about 1942identifiers that will never be used. It's not involved in tying the 1943knot in the type checker. It saved ~1% of the total build time of GHC. 1944 1945When we read an interface file, we extend the PTE, a mapping of Names 1946to TyThings, with the declarations we have read. The extension of the 1947PTE is strict in the Names, but not in the TyThings themselves. 1948LoadIface.loadDecl calculates the list of (Name, TyThing) bindings to 1949add to the PTE. For an IfaceId, there's just one binding to add; and 1950the ty, details, and idinfo fields of an IfaceId are used only in the 1951TyThing. So by reading those fields lazily we may be able to save the 1952work of ever having to deserialize them (into IfaceType, etc.). 1953 1954For IfaceData and IfaceClass, loadDecl creates extra implicit bindings 1955(the constructors and field selectors of the data declaration, or the 1956methods of the class), whose Names depend on more than just the Name 1957of the type constructor or class itself. So deserializing them lazily 1958would be more involved. Similar comments apply to the other 1959constructors of IfaceDecl with the additional point that they probably 1960represent a small proportion of all declarations. 1961-} 1962 1963instance Binary IfaceFamTyConFlav where 1964 put_ bh IfaceDataFamilyTyCon = putByte bh 0 1965 put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1 1966 put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb 1967 put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3 1968 put_ _ IfaceBuiltInSynFamTyCon 1969 = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty 1970 1971 get bh = do { h <- getByte bh 1972 ; case h of 1973 0 -> return IfaceDataFamilyTyCon 1974 1 -> return IfaceOpenSynFamilyTyCon 1975 2 -> do { mb <- get bh 1976 ; return (IfaceClosedSynFamilyTyCon mb) } 1977 3 -> return IfaceAbstractClosedSynFamilyTyCon 1978 _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" 1979 (ppr (fromIntegral h :: Int)) } 1980 1981instance Binary IfaceClassOp where 1982 put_ bh (IfaceClassOp n ty def) = do 1983 putIfaceTopBndr bh n 1984 put_ bh ty 1985 put_ bh def 1986 get bh = do 1987 n <- getIfaceTopBndr bh 1988 ty <- get bh 1989 def <- get bh 1990 return (IfaceClassOp n ty def) 1991 1992instance Binary IfaceAT where 1993 put_ bh (IfaceAT dec defs) = do 1994 put_ bh dec 1995 put_ bh defs 1996 get bh = do 1997 dec <- get bh 1998 defs <- get bh 1999 return (IfaceAT dec defs) 2000 2001instance Binary IfaceAxBranch where 2002 put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do 2003 put_ bh a1 2004 put_ bh a2 2005 put_ bh a3 2006 put_ bh a4 2007 put_ bh a5 2008 put_ bh a6 2009 put_ bh a7 2010 get bh = do 2011 a1 <- get bh 2012 a2 <- get bh 2013 a3 <- get bh 2014 a4 <- get bh 2015 a5 <- get bh 2016 a6 <- get bh 2017 a7 <- get bh 2018 return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) 2019 2020instance Binary IfaceConDecls where 2021 put_ bh IfAbstractTyCon = putByte bh 0 2022 put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs 2023 put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c 2024 get bh = do 2025 h <- getByte bh 2026 case h of 2027 0 -> return IfAbstractTyCon 2028 1 -> liftM IfDataTyCon (get bh) 2029 2 -> liftM IfNewTyCon (get bh) 2030 _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" 2031 2032instance Binary IfaceConDecl where 2033 put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do 2034 putIfaceTopBndr bh a1 2035 put_ bh a2 2036 put_ bh a3 2037 put_ bh a4 2038 put_ bh a5 2039 put_ bh a6 2040 put_ bh a7 2041 put_ bh a8 2042 put_ bh (length a9) 2043 mapM_ (put_ bh) a9 2044 put_ bh a10 2045 put_ bh a11 2046 get bh = do 2047 a1 <- getIfaceTopBndr bh 2048 a2 <- get bh 2049 a3 <- get bh 2050 a4 <- get bh 2051 a5 <- get bh 2052 a6 <- get bh 2053 a7 <- get bh 2054 a8 <- get bh 2055 n_fields <- get bh 2056 a9 <- replicateM n_fields (get bh) 2057 a10 <- get bh 2058 a11 <- get bh 2059 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) 2060 2061instance Binary IfaceBang where 2062 put_ bh IfNoBang = putByte bh 0 2063 put_ bh IfStrict = putByte bh 1 2064 put_ bh IfUnpack = putByte bh 2 2065 put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co 2066 2067 get bh = do 2068 h <- getByte bh 2069 case h of 2070 0 -> do return IfNoBang 2071 1 -> do return IfStrict 2072 2 -> do return IfUnpack 2073 _ -> do { a <- get bh; return (IfUnpackCo a) } 2074 2075instance Binary IfaceSrcBang where 2076 put_ bh (IfSrcBang a1 a2) = 2077 do put_ bh a1 2078 put_ bh a2 2079 2080 get bh = 2081 do a1 <- get bh 2082 a2 <- get bh 2083 return (IfSrcBang a1 a2) 2084 2085instance Binary IfaceClsInst where 2086 put_ bh (IfaceClsInst cls tys dfun flag orph) = do 2087 put_ bh cls 2088 put_ bh tys 2089 put_ bh dfun 2090 put_ bh flag 2091 put_ bh orph 2092 get bh = do 2093 cls <- get bh 2094 tys <- get bh 2095 dfun <- get bh 2096 flag <- get bh 2097 orph <- get bh 2098 return (IfaceClsInst cls tys dfun flag orph) 2099 2100instance Binary IfaceFamInst where 2101 put_ bh (IfaceFamInst fam tys name orph) = do 2102 put_ bh fam 2103 put_ bh tys 2104 put_ bh name 2105 put_ bh orph 2106 get bh = do 2107 fam <- get bh 2108 tys <- get bh 2109 name <- get bh 2110 orph <- get bh 2111 return (IfaceFamInst fam tys name orph) 2112 2113instance Binary IfaceRule where 2114 put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do 2115 put_ bh a1 2116 put_ bh a2 2117 put_ bh a3 2118 put_ bh a4 2119 put_ bh a5 2120 put_ bh a6 2121 put_ bh a7 2122 put_ bh a8 2123 get bh = do 2124 a1 <- get bh 2125 a2 <- get bh 2126 a3 <- get bh 2127 a4 <- get bh 2128 a5 <- get bh 2129 a6 <- get bh 2130 a7 <- get bh 2131 a8 <- get bh 2132 return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) 2133 2134instance Binary IfaceAnnotation where 2135 put_ bh (IfaceAnnotation a1 a2) = do 2136 put_ bh a1 2137 put_ bh a2 2138 get bh = do 2139 a1 <- get bh 2140 a2 <- get bh 2141 return (IfaceAnnotation a1 a2) 2142 2143instance Binary IfaceIdDetails where 2144 put_ bh IfVanillaId = putByte bh 0 2145 put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b 2146 put_ bh IfDFunId = putByte bh 2 2147 get bh = do 2148 h <- getByte bh 2149 case h of 2150 0 -> return IfVanillaId 2151 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } 2152 _ -> return IfDFunId 2153 2154instance Binary IfaceIdInfo where 2155 put_ bh NoInfo = putByte bh 0 2156 put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut 2157 2158 get bh = do 2159 h <- getByte bh 2160 case h of 2161 0 -> return NoInfo 2162 _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet 2163 2164instance Binary IfaceInfoItem where 2165 put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa 2166 put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab 2167 put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad 2168 put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad 2169 put_ bh HsNoCafRefs = putByte bh 4 2170 put_ bh HsLevity = putByte bh 5 2171 get bh = do 2172 h <- getByte bh 2173 case h of 2174 0 -> liftM HsArity $ get bh 2175 1 -> liftM HsStrictness $ get bh 2176 2 -> do lb <- get bh 2177 ad <- get bh 2178 return (HsUnfold lb ad) 2179 3 -> liftM HsInline $ get bh 2180 4 -> return HsNoCafRefs 2181 _ -> return HsLevity 2182 2183instance Binary IfaceUnfolding where 2184 put_ bh (IfCoreUnfold s e) = do 2185 putByte bh 0 2186 put_ bh s 2187 put_ bh e 2188 put_ bh (IfInlineRule a b c d) = do 2189 putByte bh 1 2190 put_ bh a 2191 put_ bh b 2192 put_ bh c 2193 put_ bh d 2194 put_ bh (IfDFunUnfold as bs) = do 2195 putByte bh 2 2196 put_ bh as 2197 put_ bh bs 2198 put_ bh (IfCompulsory e) = do 2199 putByte bh 3 2200 put_ bh e 2201 get bh = do 2202 h <- getByte bh 2203 case h of 2204 0 -> do s <- get bh 2205 e <- get bh 2206 return (IfCoreUnfold s e) 2207 1 -> do a <- get bh 2208 b <- get bh 2209 c <- get bh 2210 d <- get bh 2211 return (IfInlineRule a b c d) 2212 2 -> do as <- get bh 2213 bs <- get bh 2214 return (IfDFunUnfold as bs) 2215 _ -> do e <- get bh 2216 return (IfCompulsory e) 2217 2218 2219instance Binary IfaceExpr where 2220 put_ bh (IfaceLcl aa) = do 2221 putByte bh 0 2222 put_ bh aa 2223 put_ bh (IfaceType ab) = do 2224 putByte bh 1 2225 put_ bh ab 2226 put_ bh (IfaceCo ab) = do 2227 putByte bh 2 2228 put_ bh ab 2229 put_ bh (IfaceTuple ac ad) = do 2230 putByte bh 3 2231 put_ bh ac 2232 put_ bh ad 2233 put_ bh (IfaceLam (ae, os) af) = do 2234 putByte bh 4 2235 put_ bh ae 2236 put_ bh os 2237 put_ bh af 2238 put_ bh (IfaceApp ag ah) = do 2239 putByte bh 5 2240 put_ bh ag 2241 put_ bh ah 2242 put_ bh (IfaceCase ai aj ak) = do 2243 putByte bh 6 2244 put_ bh ai 2245 put_ bh aj 2246 put_ bh ak 2247 put_ bh (IfaceLet al am) = do 2248 putByte bh 7 2249 put_ bh al 2250 put_ bh am 2251 put_ bh (IfaceTick an ao) = do 2252 putByte bh 8 2253 put_ bh an 2254 put_ bh ao 2255 put_ bh (IfaceLit ap) = do 2256 putByte bh 9 2257 put_ bh ap 2258 put_ bh (IfaceFCall as at) = do 2259 putByte bh 10 2260 put_ bh as 2261 put_ bh at 2262 put_ bh (IfaceExt aa) = do 2263 putByte bh 11 2264 put_ bh aa 2265 put_ bh (IfaceCast ie ico) = do 2266 putByte bh 12 2267 put_ bh ie 2268 put_ bh ico 2269 put_ bh (IfaceECase a b) = do 2270 putByte bh 13 2271 put_ bh a 2272 put_ bh b 2273 get bh = do 2274 h <- getByte bh 2275 case h of 2276 0 -> do aa <- get bh 2277 return (IfaceLcl aa) 2278 1 -> do ab <- get bh 2279 return (IfaceType ab) 2280 2 -> do ab <- get bh 2281 return (IfaceCo ab) 2282 3 -> do ac <- get bh 2283 ad <- get bh 2284 return (IfaceTuple ac ad) 2285 4 -> do ae <- get bh 2286 os <- get bh 2287 af <- get bh 2288 return (IfaceLam (ae, os) af) 2289 5 -> do ag <- get bh 2290 ah <- get bh 2291 return (IfaceApp ag ah) 2292 6 -> do ai <- get bh 2293 aj <- get bh 2294 ak <- get bh 2295 return (IfaceCase ai aj ak) 2296 7 -> do al <- get bh 2297 am <- get bh 2298 return (IfaceLet al am) 2299 8 -> do an <- get bh 2300 ao <- get bh 2301 return (IfaceTick an ao) 2302 9 -> do ap <- get bh 2303 return (IfaceLit ap) 2304 10 -> do as <- get bh 2305 at <- get bh 2306 return (IfaceFCall as at) 2307 11 -> do aa <- get bh 2308 return (IfaceExt aa) 2309 12 -> do ie <- get bh 2310 ico <- get bh 2311 return (IfaceCast ie ico) 2312 13 -> do a <- get bh 2313 b <- get bh 2314 return (IfaceECase a b) 2315 _ -> panic ("get IfaceExpr " ++ show h) 2316 2317instance Binary IfaceTickish where 2318 put_ bh (IfaceHpcTick m ix) = do 2319 putByte bh 0 2320 put_ bh m 2321 put_ bh ix 2322 put_ bh (IfaceSCC cc tick push) = do 2323 putByte bh 1 2324 put_ bh cc 2325 put_ bh tick 2326 put_ bh push 2327 put_ bh (IfaceSource src name) = do 2328 putByte bh 2 2329 put_ bh (srcSpanFile src) 2330 put_ bh (srcSpanStartLine src) 2331 put_ bh (srcSpanStartCol src) 2332 put_ bh (srcSpanEndLine src) 2333 put_ bh (srcSpanEndCol src) 2334 put_ bh name 2335 2336 get bh = do 2337 h <- getByte bh 2338 case h of 2339 0 -> do m <- get bh 2340 ix <- get bh 2341 return (IfaceHpcTick m ix) 2342 1 -> do cc <- get bh 2343 tick <- get bh 2344 push <- get bh 2345 return (IfaceSCC cc tick push) 2346 2 -> do file <- get bh 2347 sl <- get bh 2348 sc <- get bh 2349 el <- get bh 2350 ec <- get bh 2351 let start = mkRealSrcLoc file sl sc 2352 end = mkRealSrcLoc file el ec 2353 name <- get bh 2354 return (IfaceSource (mkRealSrcSpan start end) name) 2355 _ -> panic ("get IfaceTickish " ++ show h) 2356 2357instance Binary IfaceConAlt where 2358 put_ bh IfaceDefault = putByte bh 0 2359 put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa 2360 put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac 2361 get bh = do 2362 h <- getByte bh 2363 case h of 2364 0 -> return IfaceDefault 2365 1 -> liftM IfaceDataAlt $ get bh 2366 _ -> liftM IfaceLitAlt $ get bh 2367 2368instance Binary IfaceBinding where 2369 put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab 2370 put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac 2371 get bh = do 2372 h <- getByte bh 2373 case h of 2374 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } 2375 _ -> do { ac <- get bh; return (IfaceRec ac) } 2376 2377instance Binary IfaceLetBndr where 2378 put_ bh (IfLetBndr a b c d) = do 2379 put_ bh a 2380 put_ bh b 2381 put_ bh c 2382 put_ bh d 2383 get bh = do a <- get bh 2384 b <- get bh 2385 c <- get bh 2386 d <- get bh 2387 return (IfLetBndr a b c d) 2388 2389instance Binary IfaceJoinInfo where 2390 put_ bh IfaceNotJoinPoint = putByte bh 0 2391 put_ bh (IfaceJoinPoint ar) = do 2392 putByte bh 1 2393 put_ bh ar 2394 get bh = do 2395 h <- getByte bh 2396 case h of 2397 0 -> return IfaceNotJoinPoint 2398 _ -> liftM IfaceJoinPoint $ get bh 2399 2400instance Binary IfaceTyConParent where 2401 put_ bh IfNoParent = putByte bh 0 2402 put_ bh (IfDataInstance ax pr ty) = do 2403 putByte bh 1 2404 put_ bh ax 2405 put_ bh pr 2406 put_ bh ty 2407 get bh = do 2408 h <- getByte bh 2409 case h of 2410 0 -> return IfNoParent 2411 _ -> do 2412 ax <- get bh 2413 pr <- get bh 2414 ty <- get bh 2415 return $ IfDataInstance ax pr ty 2416 2417instance Binary IfaceCompleteMatch where 2418 put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts 2419 get bh = IfaceCompleteMatch <$> get bh <*> get bh 2420 2421 2422{- 2423************************************************************************ 2424* * 2425 NFData instances 2426 See Note [Avoiding space leaks in toIface*] in ToIface 2427* * 2428************************************************************************ 2429-} 2430 2431instance NFData IfaceDecl where 2432 rnf = \case 2433 IfaceId f1 f2 f3 f4 -> 2434 rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 2435 2436 IfaceData f1 f2 f3 f4 f5 f6 f7 f8 f9 -> 2437 f1 `seq` seqList f2 `seq` f3 `seq` f4 `seq` f5 `seq` 2438 rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9 2439 2440 IfaceSynonym f1 f2 f3 f4 f5 -> 2441 rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 2442 2443 IfaceFamily f1 f2 f3 f4 f5 f6 -> 2444 rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 `seq` f6 `seq` () 2445 2446 IfaceClass f1 f2 f3 f4 f5 -> 2447 rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 2448 2449 IfaceAxiom nm tycon role ax -> 2450 rnf nm `seq` 2451 rnf tycon `seq` 2452 role `seq` 2453 rnf ax 2454 2455 IfacePatSyn f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 -> 2456 rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` f6 `seq` 2457 rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` f11 `seq` () 2458 2459instance NFData IfaceAxBranch where 2460 rnf (IfaceAxBranch f1 f2 f3 f4 f5 f6 f7) = 2461 rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` rnf f7 2462 2463instance NFData IfaceClassBody where 2464 rnf = \case 2465 IfAbstractClass -> () 2466 IfConcreteClass f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () 2467 2468instance NFData IfaceAT where 2469 rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2 2470 2471instance NFData IfaceClassOp where 2472 rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` f3 `seq` () 2473 2474instance NFData IfaceTyConParent where 2475 rnf = \case 2476 IfNoParent -> () 2477 IfDataInstance f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 2478 2479instance NFData IfaceConDecls where 2480 rnf = \case 2481 IfAbstractTyCon -> () 2482 IfDataTyCon f1 -> rnf f1 2483 IfNewTyCon f1 -> rnf f1 2484 2485instance NFData IfaceConDecl where 2486 rnf (IfCon f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11) = 2487 rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` 2488 rnf f7 `seq` rnf f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 2489 2490instance NFData IfaceSrcBang where 2491 rnf (IfSrcBang f1 f2) = f1 `seq` f2 `seq` () 2492 2493instance NFData IfaceBang where 2494 rnf x = x `seq` () 2495 2496instance NFData IfaceIdDetails where 2497 rnf = \case 2498 IfVanillaId -> () 2499 IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b 2500 IfRecSelId (Right decl) b -> rnf decl `seq` rnf b 2501 IfDFunId -> () 2502 2503instance NFData IfaceIdInfo where 2504 rnf = \case 2505 NoInfo -> () 2506 HasInfo f1 -> rnf f1 2507 2508instance NFData IfaceInfoItem where 2509 rnf = \case 2510 HsArity a -> rnf a 2511 HsStrictness str -> seqStrictSig str 2512 HsInline p -> p `seq` () -- TODO: seq further? 2513 HsUnfold b unf -> rnf b `seq` rnf unf 2514 HsNoCafRefs -> () 2515 HsLevity -> () 2516 2517instance NFData IfaceUnfolding where 2518 rnf = \case 2519 IfCoreUnfold inlinable expr -> 2520 rnf inlinable `seq` rnf expr 2521 IfCompulsory expr -> 2522 rnf expr 2523 IfInlineRule arity b1 b2 e -> 2524 rnf arity `seq` rnf b1 `seq` rnf b2 `seq` rnf e 2525 IfDFunUnfold bndrs exprs -> 2526 rnf bndrs `seq` rnf exprs 2527 2528instance NFData IfaceExpr where 2529 rnf = \case 2530 IfaceLcl nm -> rnf nm 2531 IfaceExt nm -> rnf nm 2532 IfaceType ty -> rnf ty 2533 IfaceCo co -> rnf co 2534 IfaceTuple sort exprs -> sort `seq` rnf exprs 2535 IfaceLam bndr expr -> rnf bndr `seq` rnf expr 2536 IfaceApp e1 e2 -> rnf e1 `seq` rnf e2 2537 IfaceCase e nm alts -> rnf e `seq` nm `seq` rnf alts 2538 IfaceECase e ty -> rnf e `seq` rnf ty 2539 IfaceLet bind e -> rnf bind `seq` rnf e 2540 IfaceCast e co -> rnf e `seq` rnf co 2541 IfaceLit l -> l `seq` () -- FIXME 2542 IfaceFCall fc ty -> fc `seq` rnf ty 2543 IfaceTick tick e -> rnf tick `seq` rnf e 2544 2545instance NFData IfaceBinding where 2546 rnf = \case 2547 IfaceNonRec bndr e -> rnf bndr `seq` rnf e 2548 IfaceRec binds -> rnf binds 2549 2550instance NFData IfaceLetBndr where 2551 rnf (IfLetBndr nm ty id_info join_info) = 2552 rnf nm `seq` rnf ty `seq` rnf id_info `seq` rnf join_info 2553 2554instance NFData IfaceFamTyConFlav where 2555 rnf = \case 2556 IfaceDataFamilyTyCon -> () 2557 IfaceOpenSynFamilyTyCon -> () 2558 IfaceClosedSynFamilyTyCon f1 -> rnf f1 2559 IfaceAbstractClosedSynFamilyTyCon -> () 2560 IfaceBuiltInSynFamTyCon -> () 2561 2562instance NFData IfaceJoinInfo where 2563 rnf x = x `seq` () 2564 2565instance NFData IfaceTickish where 2566 rnf = \case 2567 IfaceHpcTick m i -> rnf m `seq` rnf i 2568 IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2 2569 IfaceSource src str -> src `seq` rnf str 2570 2571instance NFData IfaceConAlt where 2572 rnf = \case 2573 IfaceDefault -> () 2574 IfaceDataAlt nm -> rnf nm 2575 IfaceLitAlt lit -> lit `seq` () 2576 2577instance NFData IfaceCompleteMatch where 2578 rnf (IfaceCompleteMatch f1 f2) = rnf f1 `seq` rnf f2 2579 2580instance NFData IfaceRule where 2581 rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) = 2582 rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` f8 `seq` () 2583 2584instance NFData IfaceFamInst where 2585 rnf (IfaceFamInst f1 f2 f3 f4) = 2586 rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () 2587 2588instance NFData IfaceClsInst where 2589 rnf (IfaceClsInst f1 f2 f3 f4 f5) = 2590 f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` () 2591 2592instance NFData IfaceAnnotation where 2593 rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` () 2594