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