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