compiler/iface/IfaceSyn.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   4 %
   5
   6 \begin{code}
   7 module IfaceSyn (
   8         module IfaceType,               -- Re-export all this
   9
  10         IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
  11         IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
  12         IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
  13         IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
  14
  15         -- Misc
  16         ifaceDeclSubBndrs, visibleIfConDecls,
  17
  18         -- Equality
  19         GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy,
  20         eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl,
  21
  22         -- Pretty printing
  23         pprIfaceExpr, pprIfaceDeclHead
  24     ) where
  25
  26 #include "HsVersions.h"
  27
  28 import CoreSyn
  29 import IfaceType
  30
  31 import NewDemand
  32 import Class
  33 import UniqFM
  34 import UniqSet
  35 import NameSet
  36 import Name
  37 import CostCentre
  38 import Literal
  39 import ForeignCall
  40 import BasicTypes
  41 import Outputable
  42 import FastString
  43 import Module
  44
  45 import Data.List
  46 import Data.Maybe
  47
  48 infixl 3 &&&
  49 infix  4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
  50 \end{code}
  51
  52
  53 %************************************************************************
  54 %*                                                                      *
  55                 Data type declarations
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 \begin{code}
  60 data IfaceDecl
  61   = IfaceId { ifName   :: OccName,
  62               ifType   :: IfaceType,
  63               ifIdInfo :: IfaceIdInfo }
  64
  65   | IfaceData { ifName       :: OccName,        -- Type constructor
  66                 ifTyVars     :: [IfaceTvBndr],  -- Type variables
  67                 ifCtxt       :: IfaceContext,   -- The "stupid theta"
  68                 ifCons       :: IfaceConDecls,  -- Includes new/data info
  69                 ifRec        :: RecFlag,        -- Recursive or not?
  70                 ifGadtSyntax :: Bool,           -- True <=> declared using
  71                                                 -- GADT syntax
  72                 ifGeneric    :: Bool,           -- True <=> generic converter
  73                                                 --          functions available
  74                                                 -- We need this for imported
  75                                                 -- data decls, since the
  76                                                 -- imported modules may have
  77                                                 -- been compiled with
  78                                                 -- different flags to the
  79                                                 -- current compilation unit
  80                 ifFamInst    :: Maybe (IfaceTyCon, [IfaceType])
  81                                                 -- Just <=> instance of family
  82                                                 -- Invariant:
  83                                                 --   ifCons /= IfOpenDataTyCon
  84                                                 --   for family instances
  85     }
  86
  87   | IfaceSyn  { ifName    :: OccName,           -- Type constructor
  88                 ifTyVars  :: [IfaceTvBndr],     -- Type variables
  89                 ifOpenSyn :: Bool,              -- Is an open family?
  90                 ifSynRhs  :: IfaceType,         -- Type for an ordinary
  91                                                 -- synonym and kind for an
  92                                                 -- open family
  93                 ifFamInst    :: Maybe (IfaceTyCon, [IfaceType])
  94                                                 -- Just <=> instance of family
  95                                                 -- Invariant: ifOpenSyn == False
  96                                                 --   for family instances
  97     }
  98
  99   | IfaceClass { ifCtxt    :: IfaceContext,     -- Context...
 100                  ifName    :: OccName,          -- Name of the class
 101                  ifTyVars  :: [IfaceTvBndr],    -- Type variables
 102                  ifFDs     :: [FunDep FastString], -- Functional dependencies
 103                  ifATs     :: [IfaceDecl],      -- Associated type families
 104                  ifSigs    :: [IfaceClassOp],   -- Method signatures
 105                  ifRec     :: RecFlag           -- Is newtype/datatype associated with the class recursive?
 106     }
 107
 108   | IfaceForeign { ifName :: OccName,           -- Needs expanding when we move
 109                                                 -- beyond .NET
 110                    ifExtName :: Maybe FastString }
 111
 112 data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
 113         -- Nothing    => no default method
 114         -- Just False => ordinary polymorphic default method
 115         -- Just True  => generic default method
 116
 117 data IfaceConDecls
 118   = IfAbstractTyCon             -- No info
 119   | IfOpenDataTyCon             -- Open data family
 120   | IfDataTyCon [IfaceConDecl]  -- data type decls
 121   | IfNewTyCon  IfaceConDecl    -- newtype decls
 122
 123 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 124 visibleIfConDecls IfAbstractTyCon  = []
 125 visibleIfConDecls IfOpenDataTyCon  = []
 126 visibleIfConDecls (IfDataTyCon cs) = cs
 127 visibleIfConDecls (IfNewTyCon c)   = [c]
 128
 129 data IfaceConDecl
 130   = IfCon {
 131         ifConOcc     :: OccName,                -- Constructor name
 132         ifConInfix   :: Bool,                   -- True <=> declared infix
 133         ifConUnivTvs :: [IfaceTvBndr],          -- Universal tyvars
 134         ifConExTvs   :: [IfaceTvBndr],          -- Existential tyvars
 135         ifConEqSpec  :: [(OccName,IfaceType)],  -- Equality contraints
 136         ifConCtxt    :: IfaceContext,           -- Non-stupid context
 137         ifConArgTys  :: [IfaceType],            -- Arg types
 138         ifConFields  :: [OccName],              -- ...ditto... (field labels)
 139         ifConStricts :: [StrictnessMark]}       -- Empty (meaning all lazy),
 140                                                 -- or 1-1 corresp with arg tys
 141
 142 data IfaceInst
 143   = IfaceInst { ifInstCls  :: Name,                     -- See comments with
 144                 ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of Instance
 145                 ifDFun     :: Name,                     -- The dfun
 146                 ifOFlag    :: OverlapFlag,              -- Overlap flag
 147                 ifInstOrph :: Maybe OccName }           -- See Note [Orphans]
 148         -- There's always a separate IfaceDecl for the DFun, which gives
 149         -- its IdInfo with its full type and version number.
 150         -- The instance declarations taken together have a version number,
 151         -- and we don't want that to wobble gratuitously
 152         -- If this instance decl is *used*, we'll record a usage on the dfun;
 153         -- and if the head does not change it won't be used if it wasn't before
 154
 155 data IfaceFamInst
 156   = IfaceFamInst { ifFamInstFam   :: Name                -- Family tycon
 157                  , ifFamInstTys   :: [Maybe IfaceTyCon]  -- Rough match types
 158                  , ifFamInstTyCon :: IfaceTyCon          -- Instance decl
 159                  }
 160
 161 data IfaceRule
 162   = IfaceRule {
 163         ifRuleName   :: RuleName,
 164         ifActivation :: Activation,
 165         ifRuleBndrs  :: [IfaceBndr],    -- Tyvars and term vars
 166         ifRuleHead   :: Name,           -- Head of lhs
 167         ifRuleArgs   :: [IfaceExpr],    -- Args of LHS
 168         ifRuleRhs    :: IfaceExpr,
 169         ifRuleOrph   :: Maybe OccName   -- Just like IfaceInst
 170     }
 171
 172 data IfaceIdInfo
 173   = NoInfo                      -- When writing interface file without -O
 174   | HasInfo [IfaceInfoItem]     -- Has info, and here it is
 175
 176 -- Here's a tricky case:
 177 --   * Compile with -O module A, and B which imports A.f
 178 --   * Change function f in A, and recompile without -O
 179 --   * When we read in old A.hi we read in its IdInfo (as a thunk)
 180 --      (In earlier GHCs we used to drop IdInfo immediately on reading,
 181 --       but we do not do that now.  Instead it's discarded when the
 182 --       ModIface is read into the various decl pools.)
 183 --   * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
 184 --      and so gives a new version.
 185
 186 data IfaceInfoItem
 187   = HsArity      Arity
 188   | HsStrictness StrictSig
 189   | HsInline     Activation
 190   | HsUnfold     IfaceExpr
 191   | HsNoCafRefs
 192   | HsWorker     Name Arity     -- Worker, if any see IdInfo.WorkerInfo
 193                                         -- for why we want arity here.
 194         -- NB: we need IfaceExtName (not just OccName) because the worker
 195         --     can simplify to a function in another module.
 196 -- NB: Specialisations and rules come in separately and are
 197 -- only later attached to the Id.  Partial reason: some are orphans.
 198
 199 --------------------------------
 200 data IfaceExpr
 201   = IfaceLcl    FastString
 202   | IfaceExt    Name
 203   | IfaceType   IfaceType
 204   | IfaceTuple  Boxity [IfaceExpr]              -- Saturated; type arguments omitted
 205   | IfaceLam    IfaceBndr IfaceExpr
 206   | IfaceApp    IfaceExpr IfaceExpr
 207   | IfaceCase   IfaceExpr FastString IfaceType [IfaceAlt]
 208   | IfaceLet    IfaceBinding  IfaceExpr
 209   | IfaceNote   IfaceNote IfaceExpr
 210   | IfaceCast   IfaceExpr IfaceCoercion
 211   | IfaceLit    Literal
 212   | IfaceFCall  ForeignCall IfaceType
 213   | IfaceTick   Module Int
 214
 215 data IfaceNote = IfaceSCC CostCentre
 216                | IfaceInlineMe
 217                | IfaceCoreNote String
 218
 219 type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
 220         -- Note: FastString, not IfaceBndr (and same with the case binder)
 221         -- We reconstruct the kind/type of the thing from the context
 222         -- thus saving bulk in interface files
 223
 224 data IfaceConAlt = IfaceDefault
 225                  | IfaceDataAlt Name
 226                  | IfaceTupleAlt Boxity
 227                  | IfaceLitAlt Literal
 228
 229 data IfaceBinding
 230   = IfaceNonRec IfaceLetBndr IfaceExpr
 231   | IfaceRec    [(IfaceLetBndr, IfaceExpr)]
 232
 233 -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
 234 -- It's used for *non-top-level* let/rec binders
 235 -- See Note [IdInfo on nested let-bindings]
 236 data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo
 237 \end{code}
 238
 239 Note [IdInfo on nested let-bindings]
 240 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 241 Occasionally we want to preserve IdInfo on nested let bindings. The one
 242 that came up was a NOINLINE pragma on a let-binding inside an INLINE
 243 function.  The user (Duncan Coutts) really wanted the NOINLINE control
 244 to cross the separate compilation boundary.
 245
 246 So a IfaceLetBndr keeps a trimmed-down list of IfaceIdInfo stuff.
 247 Currently we only actually retain InlinePragInfo, but in principle we could
 248 add strictness etc.
 249
 250
 251 Note [Orphans]: the ifInstOrph and ifRuleOrph fields
 252 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 253 If a module contains any "orphans", then its interface file is read
 254 regardless, so that its instances are not missed.
 255
 256 Roughly speaking, an instance is an orphan if its head (after the =>)
 257 mentions nothing defined in this module.  Functional dependencies
 258 complicate the situation though. Consider
 259
 260   module M where { class C a b | a -> b }
 261
 262 and suppose we are compiling module X:
 263
 264   module X where
 265         import M
 266         data T = ...
 267         instance C Int T where ...
 268
 269 This instance is an orphan, because when compiling a third module Y we
 270 might get a constraint (C Int v), and we'd want to improve v to T.  So
 271 we must make sure X's instances are loaded, even if we do not directly
 272 use anything from X.
 273
 274 More precisely, an instance is an orphan iff
 275
 276   If there are no fundeps, then at least of the names in
 277   the instance head is locally defined.
 278
 279   If there are fundeps, then for every fundep, at least one of the
 280   names free in a *non-determined* part of the instance head is
 281   defined in this module.
 282
 283 (Note that these conditions hold trivially if the class is locally
 284 defined.)
 285
 286 Note [Versioning of instances]
 287 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 288 Now consider versioning.  If we *use* an instance decl in one compilation,
 289 we'll depend on the dfun id for that instance, so we'll recompile if it changes.
 290 But suppose we *don't* (currently) use an instance!  We must recompile if
 291 the instance is changed in such a way that it becomes important.  (This would
 292 only matter with overlapping instances, else the importing module wouldn't have
 293 compiled before and the recompilation check is irrelevant.)
 294
 295 The is_orph field is set to (Just n) if the instance is not an orphan.
 296 The 'n' is *any* of the locally-defined names mentioned anywhere in the
 297 instance head.  This name is used for versioning; the instance decl is
 298 considered part of the defn of this 'n'.
 299
 300 I'm worried about whether this works right if we pick a name from
 301 a functionally-dependent part of the instance decl.  E.g.
 302
 303   module M where { class C a b | a -> b }
 304
 305 and suppose we are compiling module X:
 306
 307   module X where
 308         import M
 309         data S  = ...
 310         data T = ...
 311         instance C S T where ...
 312
 313 If we base the instance verion on T, I'm worried that changing S to S'
 314 would change T's version, but not S or S'.  But an importing module might
 315 not depend on T, and so might not be recompiled even though the new instance
 316 (C S' T) might be relevant.  I have not been able to make a concrete example,
 317 and it seems deeply obscure, so I'm going to leave it for now.
 318
 319
 320 Note [Versioning of rules]
 321 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 322 A rule that is not an orphan has an ifRuleOrph field of (Just n), where
 323 n appears on the LHS of the rule; any change in the rule changes the version of n.
 324
 325
 326 \begin{code}
 327 -- -----------------------------------------------------------------------------
 328 -- Utils on IfaceSyn
 329
 330 ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
 331 --  *Excludes* the 'main' name, but *includes* the implicitly-bound names
 332 -- Deeply revolting, because it has to predict what gets bound,
 333 -- especially the question of whether there's a wrapper for a datacon
 334
 335 -- N.B. the set of names returned here *must* match the set of
 336 -- TyThings returned by HscTypes.implicitTyThings, in the sense that
 337 -- TyThing.getOccName should define a bijection between the two lists.
 338 -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
 339 -- The order of the list does not matter.
 340 ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}  = []
 341
 342 -- Newtype
 343 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
 344                               ifCons = IfNewTyCon (
 345                                         IfCon { ifConOcc = con_occ,
 346                                                 ifConFields = fields
 347                                                   }),
 348                               ifFamInst = famInst})
 349   = -- fields (names of selectors)
 350     fields ++
 351     -- implicit coerion and (possibly) family instance coercion
 352     (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
 353     -- data constructor and worker (newtypes don't have a wrapper)
 354     [con_occ, mkDataConWorkerOcc con_occ]
 355
 356
 357 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
 358                               ifCons = IfDataTyCon cons,
 359                               ifFamInst = famInst})
 360   = -- fields (names of selectors)
 361     nub (concatMap ifConFields cons)    -- Eliminate duplicate fields
 362     -- (possibly) family instance coercion;
 363     -- there is no implicit coercion for non-newtypes
 364     ++ famInstCo famInst tc_occ
 365     -- for each data constructor in order,
 366     --    data constructor, worker, and (possibly) wrapper
 367     ++ concatMap dc_occs cons
 368   where
 369     dc_occs con_decl
 370         | has_wrapper = [con_occ, work_occ, wrap_occ]
 371         | otherwise   = [con_occ, work_occ]
 372         where
 373           con_occ  = ifConOcc con_decl                  -- DataCon namespace
 374           wrap_occ = mkDataConWrapperOcc con_occ        -- Id namespace
 375           work_occ = mkDataConWorkerOcc con_occ         -- Id namespace
 376           strs     = ifConStricts con_decl
 377           has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
 378                         || not (null . ifConEqSpec $ con_decl)
 379                         || isJust famInst
 380                 -- ToDo: may miss strictness in existential dicts
 381
 382 ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
 383                                ifSigs = sigs, ifATs = ats })
 384   = -- dictionary datatype:
 385     --   type constructor
 386     tc_occ :
 387     --   (possibly) newtype coercion
 388     co_occs ++
 389     --    data constructor (DataCon namespace)
 390     --    data worker (Id namespace)
 391     --    no wrapper (class dictionaries never have a wrapper)
 392     [dc_occ, dcww_occ] ++
 393     -- associated types
 394     [ifName at | at <- ats ] ++
 395     -- superclass selectors
 396     [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++
 397     -- operation selectors
 398     [op | IfaceClassOp op  _ _ <- sigs]
 399   where
 400     n_ctxt = length sc_ctxt
 401     n_sigs = length sigs
 402     tc_occ  = mkClassTyConOcc cls_occ
 403     dc_occ  = mkClassDataConOcc cls_occ
 404     co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
 405             | otherwise  = []
 406     dcww_occ = mkDataConWorkerOcc dc_occ
 407     is_newtype = n_sigs + n_ctxt == 1                   -- Sigh
 408
 409 ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
 410                              ifFamInst = famInst})
 411   = famInstCo famInst tc_occ
 412
 413 ifaceDeclSubBndrs _ = []
 414
 415 -- coercion for data/newtype family instances
 416 famInstCo :: Maybe (IfaceTyCon, [IfaceType]) -> OccName -> [OccName]
 417 famInstCo Nothing  _       = []
 418 famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
 419
 420 ----------------------------- Printing IfaceDecl ------------------------------
 421
 422 instance Outputable IfaceDecl where
 423   ppr = pprIfaceDecl
 424
 425 pprIfaceDecl :: IfaceDecl -> SDoc
 426 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
 427   = sep [ ppr var <+> dcolon <+> ppr ty,
 428           nest 2 (ppr info) ]
 429
 430 pprIfaceDecl (IfaceForeign {ifName = tycon})
 431   = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
 432
 433 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
 434                         ifOpenSyn = False, ifSynRhs = mono_ty,
 435                         ifFamInst = mbFamInst})
 436   = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
 437        4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
 438
 439 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
 440                         ifOpenSyn = True, ifSynRhs = mono_ty})
 441   = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
 442        4 (dcolon <+> ppr mono_ty)
 443
 444 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
 445                          ifTyVars = tyvars, ifCons = condecls,
 446                          ifRec = isrec, ifFamInst = mbFamInst})
 447   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
 448        4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
 449                 pprFamily mbFamInst])
 450   where
 451     pp_nd = case condecls of
 452                 IfAbstractTyCon -> ptext (sLit "data")
 453                 IfOpenDataTyCon -> ptext (sLit "data family")
 454                 IfDataTyCon _   -> ptext (sLit "data")
 455                 IfNewTyCon _    -> ptext (sLit "newtype")
 456
 457 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 458                           ifFDs = fds, ifATs = ats, ifSigs = sigs,
 459                           ifRec = isrec})
 460   = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
 461        4 (vcat [pprRec isrec,
 462                 sep (map ppr ats),
 463                 sep (map ppr sigs)])
 464
 465 pprRec :: RecFlag -> SDoc
 466 pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
 467
 468 pprGen :: Bool -> SDoc
 469 pprGen True  = ptext (sLit "Generics: yes")
 470 pprGen False = ptext (sLit "Generics: no")
 471
 472 pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
 473 pprFamily Nothing        = ptext (sLit "FamilyInstance: none")
 474 pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
 475
 476 instance Outputable IfaceClassOp where
 477    ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
 478
 479 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
 480 pprIfaceDeclHead context thing tyvars
 481   = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
 482           pprIfaceTvBndrs tyvars]
 483
 484 pp_condecls :: OccName -> IfaceConDecls -> SDoc
 485 pp_condecls _  IfAbstractTyCon  = ptext (sLit "{- abstract -}")
 486 pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
 487 pp_condecls _  IfOpenDataTyCon  = empty
 488 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
 489                                                              (map (pprIfaceConDecl tc) cs))
 490
 491 pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
 492 pprIfaceConDecl tc
 493         (IfCon { ifConOcc = name, ifConInfix = is_infix,
 494                  ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
 495                  ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
 496                  ifConStricts = strs, ifConFields = fields })
 497   = sep [main_payload,
 498          if is_infix then ptext (sLit "Infix") else empty,
 499          if null strs then empty
 500               else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
 501          if null fields then empty
 502               else nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
 503   where
 504     main_payload = ppr name <+> dcolon <+>
 505                    pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
 506
 507     eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
 508               | (tv,ty) <- eq_spec]
 509
 510         -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
 511         -- because we don't have a Name for the tycon, only an OccName
 512     pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
 513                 (t:ts) -> fsep (t : map (arrow <+>) ts)
 514                 []     -> panic "pp_con_taus"
 515
 516     pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
 517
 518 instance Outputable IfaceRule where
 519   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
 520                    ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
 521     = sep [hsep [doubleQuotes (ftext name), ppr act,
 522                  ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
 523            nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
 524                         ptext (sLit "=") <+> ppr rhs])
 525       ]
 526
 527 instance Outputable IfaceInst where
 528   ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
 529                   ifInstCls = cls, ifInstTys = mb_tcs})
 530     = hang (ptext (sLit "instance") <+> ppr flag
 531                 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
 532          2 (equals <+> ppr dfun_id)
 533
 534 instance Outputable IfaceFamInst where
 535   ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
 536                      ifFamInstTyCon = tycon_id})
 537     = hang (ptext (sLit "family instance") <+>
 538             ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
 539          2 (equals <+> ppr tycon_id)
 540
 541 ppr_rough :: Maybe IfaceTyCon -> SDoc
 542 ppr_rough Nothing   = dot
 543 ppr_rough (Just tc) = ppr tc
 544 \end{code}
 545
 546
 547 ----------------------------- Printing IfaceExpr ------------------------------------
 548
 549 \begin{code}
 550 instance Outputable IfaceExpr where
 551     ppr e = pprIfaceExpr noParens e
 552
 553 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
 554         -- The function adds parens in context that need
 555         -- an atomic value (e.g. function args)
 556
 557 pprIfaceExpr _       (IfaceLcl v)       = ppr v
 558 pprIfaceExpr _       (IfaceExt v)       = ppr v
 559 pprIfaceExpr _       (IfaceLit l)       = ppr l
 560 pprIfaceExpr _       (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 561 pprIfaceExpr _       (IfaceTick m ix)   = braces (text "tick" <+> ppr m <+> ppr ix)
 562 pprIfaceExpr _       (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
 563
 564 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 565 pprIfaceExpr _       (IfaceTuple c as)  = tupleParens c (interpp'SP as)
 566
 567 pprIfaceExpr add_par e@(IfaceLam _ _)
 568   = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
 569                   pprIfaceExpr noParens body])
 570   where
 571     (bndrs,body) = collect [] e
 572     collect bs (IfaceLam b e) = collect (b:bs) e
 573     collect bs e              = (reverse bs, e)
 574
 575 pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
 576   = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
 577                         <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
 578                         <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
 579                   pprIfaceExpr noParens rhs <+> char '}'])
 580
 581 pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
 582   = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
 583                         <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
 584                         <+> ppr bndr <+> char '{',
 585                   nest 2 (sep (map ppr_alt alts)) <+> char '}'])
 586
 587 pprIfaceExpr _       (IfaceCast expr co)
 588   = sep [pprIfaceExpr parens expr,
 589          nest 2 (ptext (sLit "`cast`")),
 590          pprParendIfaceType co]
 591
 592 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
 593   = add_par (sep [ptext (sLit "let {"),
 594                   nest 2 (ppr_bind (b, rhs)),
 595                   ptext (sLit "} in"),
 596                   pprIfaceExpr noParens body])
 597
 598 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
 599   = add_par (sep [ptext (sLit "letrec {"),
 600                   nest 2 (sep (map ppr_bind pairs)),
 601                   ptext (sLit "} in"),
 602                   pprIfaceExpr noParens body])
 603
 604 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
 605
 606 ppr_alt :: (IfaceConAlt, [FastString], IfaceExpr) -> SDoc
 607 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
 608                               arrow <+> pprIfaceExpr noParens rhs]
 609
 610 ppr_con_bs :: IfaceConAlt -> [FastString] -> SDoc
 611 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
 612 ppr_con_bs con bs                     = ppr con <+> hsep (map ppr bs)
 613
 614 ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
 615 ppr_bind (IfLetBndr b ty info, rhs)
 616   = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
 617          equals <+> pprIfaceExpr noParens rhs]
 618
 619 ------------------
 620 pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
 621 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
 622 pprIfaceApp fun                args = sep (pprIfaceExpr parens fun : args)
 623
 624 ------------------
 625 instance Outputable IfaceNote where
 626     ppr (IfaceSCC cc)     = pprCostCentreCore cc
 627     ppr IfaceInlineMe     = ptext (sLit "__inline_me")
 628     ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s)
 629
 630
 631 instance Outputable IfaceConAlt where
 632     ppr IfaceDefault      = text "DEFAULT"
 633     ppr (IfaceLitAlt l)   = ppr l
 634     ppr (IfaceDataAlt d)  = ppr d
 635     ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt"
 636     -- IfaceTupleAlt is handled by the case-alternative printer
 637
 638 ------------------
 639 instance Outputable IfaceIdInfo where
 640   ppr NoInfo       = empty
 641   ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}")
 642
 643 instance Outputable IfaceInfoItem where
 644   ppr (HsUnfold unf)     = ptext (sLit "Unfolding:") <+>
 645                                         parens (pprIfaceExpr noParens unf)
 646   ppr (HsInline act)     = ptext (sLit "Inline:") <+> ppr act
 647   ppr (HsArity arity)    = ptext (sLit "Arity:") <+> int arity
 648   ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
 649   ppr HsNoCafRefs        = ptext (sLit "HasNoCafRefs")
 650   ppr (HsWorker w a)     = ptext (sLit "Worker:") <+> ppr w <+> int a
 651 \end{code}
 652
 653
 654 %************************************************************************
 655 %*                                                                      *
 656         Equality, for interface file version generaion only
 657 %*                                                                      *
 658 %************************************************************************
 659
 660 Equality over IfaceSyn returns an IfaceEq, not a Bool.  The new
 661 constructor is EqBut, which gives the set of things whose version must
 662 be equal for the whole thing to be equal.  So the key function is
 663 eqIfExt, which compares Names.
 664
 665 Of course, equality is also done modulo alpha conversion.
 666
 667 \begin{code}
 668 data GenIfaceEq a
 669   = Equal               -- Definitely exactly the same
 670   | NotEqual            -- Definitely different
 671   | EqBut (UniqSet a)   -- The same provided these things have not changed
 672
 673 type IfaceEq = GenIfaceEq Name
 674
 675 instance Outputable a => Outputable (GenIfaceEq a) where
 676   ppr Equal          = ptext (sLit "Equal")
 677   ppr NotEqual       = ptext (sLit "NotEqual")
 678   ppr (EqBut occset) = ptext (sLit "EqBut") <+> ppr (uniqSetToList occset)
 679
 680 bool :: Bool -> IfaceEq
 681 bool True  = Equal
 682 bool False = NotEqual
 683
 684 toBool :: IfaceEq -> Bool
 685 toBool Equal     = True
 686 toBool (EqBut _) = True
 687 toBool NotEqual  = False
 688
 689 zapEq :: IfaceEq -> IfaceEq     -- Used to forget EqBut information
 690 zapEq (EqBut _) = Equal
 691 zapEq other     = other
 692
 693 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
 694 Equal       &&& x           = x
 695 NotEqual    &&& _           = NotEqual
 696 EqBut nms   &&& Equal       = EqBut nms
 697 EqBut _     &&& NotEqual    = NotEqual
 698 EqBut nms1  &&& EqBut nms2  = EqBut (nms1 `unionNameSets` nms2)
 699
 700 -- This function is the core of the EqBut stuff
 701 -- ASSUMPTION: The left-hand argument is the NEW CODE, and hence
 702 -- any Names in the left-hand arg have the correct parent in them.
 703 eqIfExt :: Name -> Name -> IfaceEq
 704 eqIfExt name1 name2
 705   | name1 == name2 = EqBut (unitNameSet name1)
 706   | otherwise      = NotEqual
 707
 708 ---------------------
 709 checkBootDecl :: IfaceDecl      -- The boot decl
 710               -> IfaceDecl      -- The real decl
 711               -> Bool           -- True <=> compatible
 712 checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
 713   = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
 714
 715 checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 716   = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
 717
 718 checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 719   = ASSERT( ifName d1 == ifName d2 )
 720     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 721           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 722
 723 checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
 724 -- We don't check the recursion flags because the boot-one is
 725 -- recursive, to be conservative, but the real one may not be.
 726 -- I'm not happy with the way recursive flags are dealt with.
 727   = ASSERT( ifName d1    == ifName d2 )
 728     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 729         eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 730         case ifCons d1 of
 731             IfAbstractTyCon -> Equal
 732             cons1           -> eq_hsCD env cons1 (ifCons d2)
 733
 734 checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 735   = ASSERT( ifName d1 == ifName d2 )
 736     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 737           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 738           case (ifCtxt d1, ifSigs d1) of
 739              ([], [])      -> Equal
 740              (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2)  &&&
 741                               eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
 742
 743 checkBootDecl _ _ = False       -- default case
 744
 745 ---------------------
 746 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
 747 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
 748   = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
 749
 750 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 751   = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
 752
 753 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
 754   = bool (ifName d1    == ifName d2 &&
 755           ifRec d1     == ifRec   d2 &&
 756           ifGadtSyntax d1 == ifGadtSyntax   d2 &&
 757           ifGeneric d1 == ifGeneric d2) &&&
 758     ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
 759     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 760             eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 761             eq_hsCD env (ifCons d1) (ifCons d2)
 762         )
 763         -- The type variables of the data type do not scope
 764         -- over the constructors (any more), but they do scope
 765         -- over the stupid context in the IfaceConDecls
 766
 767 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 768   = bool (ifName d1 == ifName d2) &&&
 769     ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
 770     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 771           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 772         )
 773
 774 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 775   = bool (ifName d1 == ifName d2 &&
 776           ifRec d1  == ifRec  d2) &&&
 777     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 778           eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
 779           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 780           eqListBy eqIfDecl         (ifATs d1)  (ifATs d2) &&&
 781           eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
 782        )
 783
 784 eqIfDecl _ _ = NotEqual -- default case
 785
 786 -- Helper
 787 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
 788 eqWith = eq_ifTvBndrs emptyEqEnv
 789
 790 eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType])
 791            -> Maybe (IfaceTyCon, [IfaceType])
 792            -> IfaceEq
 793 Nothing             `eqIfTc_fam` Nothing             = Equal
 794 (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
 795   fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
 796 _                       `eqIfTc_fam` _               = NotEqual
 797
 798
 799 -----------------------
 800 eqIfInst :: IfaceInst -> IfaceInst -> IfaceEq
 801 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
 802 -- All other changes are handled via the version info on the dfun
 803
 804 eqIfFamInst :: IfaceFamInst -> IfaceFamInst -> IfaceEq
 805 eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
 806 -- All other changes are handled via the version info on the tycon
 807
 808 eqIfRule :: IfaceRule -> IfaceRule -> IfaceEq
 809 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
 810          (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
 811        = bool (n1==n2 && a1==a2 && o1 == o2) &&&
 812          f1 `eqIfExt` f2 &&&
 813          eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
 814          zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
 815                 -- zapEq: for the LHSs, ignore the EqBut part
 816          eq_ifaceExpr env rhs1 rhs2)
 817
 818 eq_hsCD :: EqEnv -> IfaceConDecls -> IfaceConDecls -> IfaceEq
 819 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
 820   = eqListBy (eq_ConDecl env) c1 c2
 821
 822 eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
 823 eq_hsCD _   IfAbstractTyCon  IfAbstractTyCon  = Equal
 824 eq_hsCD _   IfOpenDataTyCon  IfOpenDataTyCon  = Equal
 825 eq_hsCD _   _                _                = NotEqual
 826
 827 eq_ConDecl :: EqEnv -> IfaceConDecl -> IfaceConDecl -> IfaceEq
 828 eq_ConDecl env c1 c2
 829   = bool (ifConOcc c1     == ifConOcc c2 &&
 830           ifConInfix c1   == ifConInfix c2 &&
 831           ifConStricts c1 == ifConStricts c2 &&
 832           ifConFields c1  == ifConFields c2) &&&
 833     eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
 834     eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
 835         eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
 836         eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
 837
 838 eq_hsFD :: EqEnv
 839         -> ([FastString], [FastString])
 840         -> ([FastString], [FastString])
 841         -> IfaceEq
 842 eq_hsFD env (ns1,ms1) (ns2,ms2)
 843   = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
 844
 845 eq_cls_sig :: EqEnv -> IfaceClassOp -> IfaceClassOp -> IfaceEq
 846 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
 847   = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
 848 \end{code}
 849
 850
 851 \begin{code}
 852 -----------------
 853 eqIfIdInfo :: IfaceIdInfo -> IfaceIdInfo -> GenIfaceEq Name
 854 eqIfIdInfo NoInfo        NoInfo        = Equal
 855 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
 856 eqIfIdInfo _             _             = NotEqual
 857
 858 eq_item :: IfaceInfoItem -> IfaceInfoItem -> IfaceEq
 859 eq_item (HsInline a1)      (HsInline a2)      = bool (a1 == a2)
 860 eq_item (HsArity a1)       (HsArity a2)       = bool (a1 == a2)
 861 eq_item (HsStrictness s1)  (HsStrictness s2)  = bool (s1 == s2)
 862 eq_item (HsUnfold u1)   (HsUnfold u2)         = eq_ifaceExpr emptyEqEnv u1 u2
 863 eq_item HsNoCafRefs        HsNoCafRefs        = Equal
 864 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
 865 eq_item _ _ = NotEqual
 866
 867 -----------------
 868 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
 869 eq_ifaceExpr env (IfaceLcl v1)        (IfaceLcl v2)        = eqIfOcc env v1 v2
 870 eq_ifaceExpr _   (IfaceExt v1)        (IfaceExt v2)        = eqIfExt v1 v2
 871 eq_ifaceExpr _   (IfaceLit l1)        (IfaceLit l2)        = bool (l1 == l2)
 872 eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
 873 eq_ifaceExpr _   (IfaceTick m1 ix1)   (IfaceTick m2 ix2)   = bool (m1==m2) &&& bool (ix1 == ix2)
 874 eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)      = eq_ifType env ty1 ty2
 875 eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
 876 eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
 877 eq_ifaceExpr env (IfaceApp f1 a1)     (IfaceApp f2 a2)     = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
 878 eq_ifaceExpr env (IfaceCast e1 co1)   (IfaceCast e2 co2)   = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
 879 eq_ifaceExpr env (IfaceNote n1 r1)    (IfaceNote n2 r2)    = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
 880
 881 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
 882   = eq_ifaceExpr env s1 s2 &&&
 883     eq_ifType env ty1 ty2 &&&
 884     eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
 885   where
 886     eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
 887         = bool (eq_ifaceConAlt c1 c2) &&&
 888           eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
 889
 890 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
 891   = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
 892
 893 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
 894   = eq_ifLetBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
 895   where
 896     (bs1,rs1) = unzip as1
 897     (bs2,rs2) = unzip as2
 898
 899
 900 eq_ifaceExpr _ _ _ = NotEqual
 901
 902 -----------------
 903 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
 904 eq_ifaceConAlt IfaceDefault       IfaceDefault          = True
 905 eq_ifaceConAlt (IfaceDataAlt n1)  (IfaceDataAlt n2)     = n1==n2
 906 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2)    = c1==c2
 907 eq_ifaceConAlt (IfaceLitAlt l1)   (IfaceLitAlt l2)      = l1==l2
 908 eq_ifaceConAlt _ _ = False
 909
 910 -----------------
 911 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
 912 eq_ifaceNote _   (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
 913 eq_ifaceNote _   IfaceInlineMe    IfaceInlineMe        = Equal
 914 eq_ifaceNote _   (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
 915 eq_ifaceNote _   _ _ = NotEqual
 916 \end{code}
 917
 918 \begin{code}
 919 ---------------------
 920 eqIfType :: IfaceType -> IfaceType -> IfaceEq
 921 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
 922
 923 -------------------
 924 eq_ifType :: EqEnv -> IfaceType -> IfaceType -> IfaceEq
 925 eq_ifType env (IfaceTyVar n1)         (IfaceTyVar n2)         = eqIfOcc env n1 n2
 926 eq_ifType env (IfaceAppTy s1 t1)      (IfaceAppTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 927 eq_ifType env (IfacePredTy st1)       (IfacePredTy st2)       = eq_ifPredType env st1 st2
 928 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
 929 eq_ifType env (IfaceForAllTy tv1 t1)  (IfaceForAllTy tv2 t2)  = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
 930 eq_ifType env (IfaceFunTy s1 t1)      (IfaceFunTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 931 eq_ifType _ _ _ = NotEqual
 932
 933 -------------------
 934 eq_ifTypes :: EqEnv -> [IfaceType] -> [IfaceType] -> IfaceEq
 935 eq_ifTypes env = eqListBy (eq_ifType env)
 936
 937 -------------------
 938 eq_ifContext :: EqEnv -> [IfacePredType] -> [IfacePredType] -> IfaceEq
 939 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
 940
 941 -------------------
 942 eq_ifPredType :: EqEnv -> IfacePredType -> IfacePredType -> IfaceEq
 943 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&&  eq_ifTypes env tys1 tys2
 944 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2)   = bool (n1 == n2) &&& eq_ifType env ty1 ty2
 945 eq_ifPredType _   _ _ = NotEqual
 946
 947 -------------------
 948 eqIfTc :: IfaceTyCon -> IfaceTyCon -> IfaceEq
 949 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
 950 eqIfTc IfaceIntTc    IfaceIntTc    = Equal
 951 eqIfTc IfaceCharTc   IfaceCharTc   = Equal
 952 eqIfTc IfaceBoolTc   IfaceBoolTc   = Equal
 953 eqIfTc IfaceListTc   IfaceListTc   = Equal
 954 eqIfTc IfacePArrTc   IfacePArrTc   = Equal
 955 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
 956 eqIfTc IfaceLiftedTypeKindTc   IfaceLiftedTypeKindTc   = Equal
 957 eqIfTc IfaceOpenTypeKindTc     IfaceOpenTypeKindTc     = Equal
 958 eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
 959 eqIfTc IfaceUbxTupleKindTc     IfaceUbxTupleKindTc     = Equal
 960 eqIfTc IfaceArgTypeKindTc      IfaceArgTypeKindTc      = Equal
 961 eqIfTc _                       _                       = NotEqual
 962 \end{code}
 963
 964 -----------------------------------------------------------
 965         Support code for equality checking
 966 -----------------------------------------------------------
 967
 968 \begin{code}
 969 ------------------------------------
 970 type EqEnv = UniqFM FastString  -- Tracks the mapping from L-variables to R-variables
 971
 972 eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
 973 eqIfOcc env n1 n2 = case lookupUFM env n1 of
 974                         Just n1 -> bool (n1 == n2)
 975                         Nothing -> bool (n1 == n2)
 976
 977 extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
 978 extendEqEnv env n1 n2 | n1 == n2  = env
 979                       | otherwise = addToUFM env n1 n2
 980
 981 emptyEqEnv :: EqEnv
 982 emptyEqEnv = emptyUFM
 983
 984 ------------------------------------
 985 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
 986
 987 eq_ifNakedBndr :: ExtEnv FastString
 988 eq_ifBndr      :: ExtEnv IfaceBndr
 989 eq_ifTvBndr    :: ExtEnv IfaceTvBndr
 990 eq_ifIdBndr    :: ExtEnv IfaceIdBndr
 991
 992 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
 993
 994 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
 995 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
 996 eq_ifBndr _ _ _ _ = NotEqual
 997
 998 eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
 999 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
1000
1001 eq_ifLetBndr :: EqEnv -> IfaceLetBndr -> IfaceLetBndr -> (EqEnv -> IfaceEq)
1002              -> IfaceEq
1003 eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k
1004   = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2)
1005
1006 eq_ifBndrs      :: ExtEnv [IfaceBndr]
1007 eq_ifLetBndrs   :: ExtEnv [IfaceLetBndr]
1008 eq_ifTvBndrs    :: ExtEnv [IfaceTvBndr]
1009 eq_ifNakedBndrs :: ExtEnv [FastString]
1010 eq_ifBndrs      = eq_bndrs_with eq_ifBndr
1011 eq_ifTvBndrs    = eq_bndrs_with eq_ifTvBndr
1012 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
1013 eq_ifLetBndrs   = eq_bndrs_with eq_ifLetBndr
1014
1015 -- eq_bndrs_with :: (a -> a -> IfaceEq) -> ExtEnv a
1016 eq_bndrs_with :: ExtEnv a -> ExtEnv [a]
1017 eq_bndrs_with _  env []       []       k = k env
1018 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
1019 eq_bndrs_with _  _   _        _        _ = NotEqual
1020 \end{code}
1021
1022 \begin{code}
1023 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
1024 eqListBy _  []     []     = Equal
1025 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
1026 eqListBy _  _      _      = NotEqual
1027
1028 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
1029 eqMaybeBy _  Nothing  Nothing  = Equal
1030 eqMaybeBy eq (Just x) (Just y) = eq x y
1031 eqMaybeBy _  _        _        = NotEqual
1032 \end{code}