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