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 _other = []
 416
 417 -- coercion for data/newtype family instances
 418 famInstCo Nothing  baseOcc = []
 419 famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
 420
 421 ----------------------------- Printing IfaceDecl ------------------------------
 422
 423 instance Outputable IfaceDecl where
 424   ppr = pprIfaceDecl
 425
 426 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
 427   = sep [ ppr var <+> dcolon <+> ppr ty,
 428           nest 2 (ppr info) ]
 429
 430 pprIfaceDecl (IfaceForeign {ifName = tycon})
 431   = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
 432
 433 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
 434                         ifOpenSyn = False, ifSynRhs = mono_ty,
 435                         ifFamInst = mbFamInst})
 436   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
 437        4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
 438
 439 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
 440                         ifOpenSyn = True, ifSynRhs = mono_ty})
 441   = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
 442        4 (dcolon <+> ppr mono_ty)
 443
 444 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
 445                          ifTyVars = tyvars, ifCons = condecls,
 446                          ifRec = isrec, ifFamInst = mbFamInst})
 447   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
 448        4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
 449                 pprFamily mbFamInst])
 450   where
 451     pp_nd = case condecls of
 452                 IfAbstractTyCon -> ptext SLIT("data")
 453                 IfOpenDataTyCon -> ptext SLIT("data family")
 454                 IfDataTyCon _   -> ptext SLIT("data")
 455                 IfNewTyCon _    -> ptext SLIT("newtype")
 456
 457 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 458                           ifFDs = fds, ifATs = ats, ifSigs = sigs,
 459                           ifRec = isrec})
 460   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
 461        4 (vcat [pprRec isrec,
 462                 sep (map ppr ats),
 463                 sep (map ppr sigs)])
 464
 465 pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
 466 pprGen True  = ptext SLIT("Generics: yes")
 467 pprGen False = ptext SLIT("Generics: no")
 468
 469 pprFamily Nothing        = ptext SLIT("FamilyInstance: none")
 470 pprFamily (Just famInst) = ptext SLIT("FamilyInstance:") <+> ppr famInst
 471
 472 instance Outputable IfaceClassOp where
 473    ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
 474
 475 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
 476 pprIfaceDeclHead context thing tyvars
 477   = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
 478           pprIfaceTvBndrs tyvars]
 479
 480 pp_condecls tc IfAbstractTyCon  = ptext SLIT("{- abstract -}")
 481 pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
 482 pp_condecls tc IfOpenDataTyCon  = empty
 483 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
 484                                                              (map (pprIfaceConDecl tc) cs))
 485
 486 pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
 487 pprIfaceConDecl tc
 488         (IfCon { ifConOcc = name, ifConInfix = is_infix,
 489                  ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
 490                  ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
 491                  ifConStricts = strs, ifConFields = fields })
 492   = sep [main_payload,
 493          if is_infix then ptext SLIT("Infix") else empty,
 494          if null strs then empty
 495               else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
 496          if null fields then empty
 497               else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
 498   where
 499     main_payload = ppr name <+> dcolon <+>
 500                    pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
 501
 502     eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
 503               | (tv,ty) <- eq_spec]
 504
 505         -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
 506         -- because we don't have a Name for the tycon, only an OccName
 507     pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
 508                 (t:ts) -> fsep (t : map (arrow <+>) ts)
 509                 []     -> panic "pp_con_taus"
 510
 511     pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
 512
 513 instance Outputable IfaceRule where
 514   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
 515                    ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
 516     = sep [hsep [doubleQuotes (ftext name), ppr act,
 517                  ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
 518            nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
 519                         ptext SLIT("=") <+> ppr rhs])
 520       ]
 521
 522 instance Outputable IfaceInst where
 523   ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
 524                   ifInstCls = cls, ifInstTys = mb_tcs})
 525     = hang (ptext SLIT("instance") <+> ppr flag
 526                 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
 527          2 (equals <+> ppr dfun_id)
 528
 529 instance Outputable IfaceFamInst where
 530   ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
 531                      ifFamInstTyCon = tycon_id})
 532     = hang (ptext SLIT("family instance") <+>
 533             ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
 534          2 (equals <+> ppr tycon_id)
 535
 536 ppr_rough :: Maybe IfaceTyCon -> SDoc
 537 ppr_rough Nothing   = dot
 538 ppr_rough (Just tc) = ppr tc
 539 \end{code}
 540
 541
 542 ----------------------------- Printing IfaceExpr ------------------------------------
 543
 544 \begin{code}
 545 instance Outputable IfaceExpr where
 546     ppr e = pprIfaceExpr noParens e
 547
 548 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
 549         -- The function adds parens in context that need
 550         -- an atomic value (e.g. function args)
 551
 552 pprIfaceExpr add_par (IfaceLcl v)       = ppr v
 553 pprIfaceExpr add_par (IfaceExt v)       = ppr v
 554 pprIfaceExpr add_par (IfaceLit l)       = ppr l
 555 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 556 pprIfaceExpr add_par (IfaceTick m ix)   = braces (text "tick" <+> ppr m <+> ppr ix)
 557 pprIfaceExpr add_par (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
 558
 559 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 560 pprIfaceExpr add_par (IfaceTuple c as)  = tupleParens c (interpp'SP as)
 561
 562 pprIfaceExpr add_par e@(IfaceLam _ _)
 563   = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
 564                   pprIfaceExpr noParens body])
 565   where
 566     (bndrs,body) = collect [] e
 567     collect bs (IfaceLam b e) = collect (b:bs) e
 568     collect bs e              = (reverse bs, e)
 569
 570 pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
 571   = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
 572                         <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
 573                         <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
 574                   pprIfaceExpr noParens rhs <+> char '}'])
 575
 576 pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
 577   = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
 578                         <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
 579                         <+> ppr bndr <+> char '{',
 580                   nest 2 (sep (map ppr_alt alts)) <+> char '}'])
 581
 582 pprIfaceExpr add_par (IfaceCast expr co)
 583   = sep [pprIfaceExpr parens expr,
 584          nest 2 (ptext SLIT("`cast`")),
 585          pprParendIfaceType co]
 586
 587 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
 588   = add_par (sep [ptext SLIT("let {"),
 589                   nest 2 (ppr_bind (b, rhs)),
 590                   ptext SLIT("} in"),
 591                   pprIfaceExpr noParens body])
 592
 593 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
 594   = add_par (sep [ptext SLIT("letrec {"),
 595                   nest 2 (sep (map ppr_bind pairs)),
 596                   ptext SLIT("} in"),
 597                   pprIfaceExpr noParens body])
 598
 599 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
 600
 601 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
 602                               arrow <+> pprIfaceExpr noParens rhs]
 603
 604 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
 605 ppr_con_bs con bs                     = ppr con <+> hsep (map ppr bs)
 606
 607 ppr_bind (IfLetBndr b ty info, rhs)
 608   = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
 609          equals <+> pprIfaceExpr noParens rhs]
 610
 611 ------------------
 612 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
 613 pprIfaceApp fun                args = sep (pprIfaceExpr parens fun : args)
 614
 615 ------------------
 616 instance Outputable IfaceNote where
 617     ppr (IfaceSCC cc)     = pprCostCentreCore cc
 618     ppr IfaceInlineMe     = ptext SLIT("__inline_me")
 619     ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
 620
 621
 622 instance Outputable IfaceConAlt where
 623     ppr IfaceDefault      = text "DEFAULT"
 624     ppr (IfaceLitAlt l)   = ppr l
 625     ppr (IfaceDataAlt d)  = ppr d
 626     ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
 627         -- IfaceTupleAlt is handled by the case-alternative printer
 628
 629 ------------------
 630 instance Outputable IfaceIdInfo where
 631   ppr NoInfo       = empty
 632   ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr is) <+> ptext SLIT("-}")
 633
 634 instance Outputable IfaceInfoItem where
 635   ppr (HsUnfold unf)     = ptext SLIT("Unfolding:") <+>
 636                                         parens (pprIfaceExpr noParens unf)
 637   ppr (HsInline act)     = ptext SLIT("Inline:") <+> ppr act
 638   ppr (HsArity arity)    = ptext SLIT("Arity:") <+> int arity
 639   ppr (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
 640   ppr HsNoCafRefs        = ptext SLIT("HasNoCafRefs")
 641   ppr (HsWorker w a)     = ptext SLIT("Worker:") <+> ppr w <+> int a
 642 \end{code}
 643
 644
 645 %************************************************************************
 646 %*                                                                      *
 647         Equality, for interface file version generaion only
 648 %*                                                                      *
 649 %************************************************************************
 650
 651 Equality over IfaceSyn returns an IfaceEq, not a Bool.  The new
 652 constructor is EqBut, which gives the set of things whose version must
 653 be equal for the whole thing to be equal.  So the key function is
 654 eqIfExt, which compares Names.
 655
 656 Of course, equality is also done modulo alpha conversion.
 657
 658 \begin{code}
 659 data GenIfaceEq a
 660   = Equal               -- Definitely exactly the same
 661   | NotEqual            -- Definitely different
 662   | EqBut a       -- The same provided these Names have not changed
 663
 664 type IfaceEq = GenIfaceEq NameSet
 665
 666 instance Outputable IfaceEq where
 667   ppr Equal          = ptext SLIT("Equal")
 668   ppr NotEqual       = ptext SLIT("NotEqual")
 669   ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset)
 670
 671 bool :: Bool -> IfaceEq
 672 bool True  = Equal
 673 bool False = NotEqual
 674
 675 toBool :: IfaceEq -> Bool
 676 toBool Equal     = True
 677 toBool (EqBut _) = True
 678 toBool NotEqual  = False
 679
 680 zapEq :: IfaceEq -> IfaceEq     -- Used to forget EqBut information
 681 zapEq (EqBut _) = Equal
 682 zapEq other     = other
 683
 684 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
 685 Equal       &&& x           = x
 686 NotEqual    &&& x           = NotEqual
 687 EqBut nms   &&& Equal       = EqBut nms
 688 EqBut nms   &&& NotEqual    = NotEqual
 689 EqBut nms1  &&& EqBut nms2  = EqBut (nms1 `unionNameSets` nms2)
 690
 691 -- This function is the core of the EqBut stuff
 692 -- ASSUMPTION: The left-hand argument is the NEW CODE, and hence
 693 -- any Names in the left-hand arg have the correct parent in them.
 694 eqIfExt :: Name -> Name -> IfaceEq
 695 eqIfExt name1 name2
 696   | name1 == name2 = EqBut (unitNameSet name1)
 697   | otherwise      = NotEqual
 698
 699 ---------------------
 700 checkBootDecl :: IfaceDecl      -- The boot decl
 701               -> IfaceDecl      -- The real decl
 702               -> Bool           -- True <=> compatible
 703 checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
 704   = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
 705
 706 checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 707   = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
 708
 709 checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 710   = ASSERT( ifName d1 == ifName d2 )
 711     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 712           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 713
 714 checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
 715 -- We don't check the recursion flags because the boot-one is
 716 -- recursive, to be conservative, but the real one may not be.
 717 -- I'm not happy with the way recursive flags are dealt with.
 718   = ASSERT( ifName d1    == ifName d2 )
 719     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 720         eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 721         case ifCons d1 of
 722             IfAbstractTyCon -> Equal
 723             cons1           -> eq_hsCD env cons1 (ifCons d2)
 724
 725 checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 726   = ASSERT( ifName d1 == ifName d2 )
 727     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 728           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 729           case (ifCtxt d1, ifSigs d1) of
 730              ([], [])      -> Equal
 731              (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2)  &&&
 732                               eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
 733
 734 checkBootDecl _ _ = False       -- default case
 735
 736 ---------------------
 737 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
 738 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
 739   = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
 740
 741 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 742   = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
 743
 744 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
 745   = bool (ifName d1    == ifName d2 &&
 746           ifRec d1     == ifRec   d2 &&
 747           ifGadtSyntax d1 == ifGadtSyntax   d2 &&
 748           ifGeneric d1 == ifGeneric d2) &&&
 749     ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
 750     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 751             eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 752             eq_hsCD env (ifCons d1) (ifCons d2)
 753         )
 754         -- The type variables of the data type do not scope
 755         -- over the constructors (any more), but they do scope
 756         -- over the stupid context in the IfaceConDecls
 757
 758 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 759   = bool (ifName d1 == ifName d2) &&&
 760     ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
 761     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 762           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 763         )
 764
 765 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 766   = bool (ifName d1 == ifName d2 &&
 767           ifRec d1  == ifRec  d2) &&&
 768     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 769           eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
 770           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 771           eqListBy eqIfDecl         (ifATs d1)  (ifATs d2) &&&
 772           eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
 773        )
 774
 775 eqIfDecl _ _ = NotEqual -- default case
 776
 777 -- Helper
 778 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
 779 eqWith = eq_ifTvBndrs emptyEqEnv
 780
 781 eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType])
 782            -> Maybe (IfaceTyCon, [IfaceType])
 783            -> IfaceEq
 784 Nothing             `eqIfTc_fam` Nothing             = Equal
 785 (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
 786   fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
 787 _                       `eqIfTc_fam` _               = NotEqual
 788
 789
 790 -----------------------
 791 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
 792 -- All other changes are handled via the version info on the dfun
 793
 794 eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
 795 -- All other changes are handled via the version info on the tycon
 796
 797 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
 798          (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
 799        = bool (n1==n2 && a1==a2 && o1 == o2) &&&
 800          f1 `eqIfExt` f2 &&&
 801          eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
 802          zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
 803                 -- zapEq: for the LHSs, ignore the EqBut part
 804          eq_ifaceExpr env rhs1 rhs2)
 805
 806 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
 807   = eqListBy (eq_ConDecl env) c1 c2
 808
 809 eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
 810 eq_hsCD env IfAbstractTyCon  IfAbstractTyCon  = Equal
 811 eq_hsCD env IfOpenDataTyCon  IfOpenDataTyCon  = Equal
 812 eq_hsCD env d1               d2               = NotEqual
 813
 814 eq_ConDecl env c1 c2
 815   = bool (ifConOcc c1     == ifConOcc c2 &&
 816           ifConInfix c1   == ifConInfix c2 &&
 817           ifConStricts c1 == ifConStricts c2 &&
 818           ifConFields c1  == ifConFields c2) &&&
 819     eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
 820     eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
 821         eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
 822         eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
 823
 824 eq_hsFD env (ns1,ms1) (ns2,ms2)
 825   = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
 826
 827 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
 828   = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
 829 \end{code}
 830
 831
 832 \begin{code}
 833 -----------------
 834 eqIfIdInfo NoInfo        NoInfo        = Equal
 835 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
 836 eqIfIdInfo i1            i2 = NotEqual
 837
 838 eq_item (HsInline a1)      (HsInline a2)      = bool (a1 == a2)
 839 eq_item (HsArity a1)       (HsArity a2)       = bool (a1 == a2)
 840 eq_item (HsStrictness s1)  (HsStrictness s2)  = bool (s1 == s2)
 841 eq_item (HsUnfold u1)   (HsUnfold u2)         = eq_ifaceExpr emptyEqEnv u1 u2
 842 eq_item HsNoCafRefs        HsNoCafRefs        = Equal
 843 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
 844 eq_item _ _ = NotEqual
 845
 846 -----------------
 847 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
 848 eq_ifaceExpr env (IfaceLcl v1)        (IfaceLcl v2)        = eqIfOcc env v1 v2
 849 eq_ifaceExpr env (IfaceExt v1)        (IfaceExt v2)        = eqIfExt v1 v2
 850 eq_ifaceExpr env (IfaceLit l1)        (IfaceLit l2)        = bool (l1 == l2)
 851 eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
 852 eq_ifaceExpr env (IfaceTick m1 ix1)   (IfaceTick m2 ix2)   = bool (m1==m2) &&& bool (ix1 == ix2)
 853 eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)      = eq_ifType env ty1 ty2
 854 eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
 855 eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
 856 eq_ifaceExpr env (IfaceApp f1 a1)     (IfaceApp f2 a2)     = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
 857 eq_ifaceExpr env (IfaceCast e1 co1)   (IfaceCast e2 co2)   = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
 858 eq_ifaceExpr env (IfaceNote n1 r1)    (IfaceNote n2 r2)    = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
 859
 860 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
 861   = eq_ifaceExpr env s1 s2 &&&
 862     eq_ifType env ty1 ty2 &&&
 863     eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
 864   where
 865     eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
 866         = bool (eq_ifaceConAlt c1 c2) &&&
 867           eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
 868
 869 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
 870   = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
 871
 872 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
 873   = eq_ifLetBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
 874   where
 875     (bs1,rs1) = unzip as1
 876     (bs2,rs2) = unzip as2
 877
 878
 879 eq_ifaceExpr env _ _ = NotEqual
 880
 881 -----------------
 882 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
 883 eq_ifaceConAlt IfaceDefault       IfaceDefault          = True
 884 eq_ifaceConAlt (IfaceDataAlt n1)  (IfaceDataAlt n2)     = n1==n2
 885 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2)    = c1==c2
 886 eq_ifaceConAlt (IfaceLitAlt l1)   (IfaceLitAlt l2)      = l1==l2
 887 eq_ifaceConAlt _ _ = False
 888
 889 -----------------
 890 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
 891 eq_ifaceNote env (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
 892 eq_ifaceNote env IfaceInlineMe    IfaceInlineMe        = Equal
 893 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
 894 eq_ifaceNote env _ _ = NotEqual
 895 \end{code}
 896
 897 \begin{code}
 898 ---------------------
 899 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
 900
 901 -------------------
 902 eq_ifType env (IfaceTyVar n1)         (IfaceTyVar n2)         = eqIfOcc env n1 n2
 903 eq_ifType env (IfaceAppTy s1 t1)      (IfaceAppTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 904 eq_ifType env (IfacePredTy st1)       (IfacePredTy st2)       = eq_ifPredType env st1 st2
 905 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
 906 eq_ifType env (IfaceForAllTy tv1 t1)  (IfaceForAllTy tv2 t2)  = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
 907 eq_ifType env (IfaceFunTy s1 t1)      (IfaceFunTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 908 eq_ifType env _ _ = NotEqual
 909
 910 -------------------
 911 eq_ifTypes env = eqListBy (eq_ifType env)
 912
 913 -------------------
 914 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
 915
 916 -------------------
 917 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&&  eq_ifTypes env tys1 tys2
 918 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2)   = bool (n1 == n2) &&& eq_ifType env ty1 ty2
 919 eq_ifPredType env _ _ = NotEqual
 920
 921 -------------------
 922 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
 923 eqIfTc IfaceIntTc    IfaceIntTc    = Equal
 924 eqIfTc IfaceCharTc   IfaceCharTc   = Equal
 925 eqIfTc IfaceBoolTc   IfaceBoolTc   = Equal
 926 eqIfTc IfaceListTc   IfaceListTc   = Equal
 927 eqIfTc IfacePArrTc   IfacePArrTc   = Equal
 928 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
 929 eqIfTc IfaceLiftedTypeKindTc   IfaceLiftedTypeKindTc   = Equal
 930 eqIfTc IfaceOpenTypeKindTc     IfaceOpenTypeKindTc     = Equal
 931 eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
 932 eqIfTc IfaceUbxTupleKindTc     IfaceUbxTupleKindTc     = Equal
 933 eqIfTc IfaceArgTypeKindTc      IfaceArgTypeKindTc      = Equal
 934 eqIfTc _                       _                       = NotEqual
 935 \end{code}
 936
 937 -----------------------------------------------------------
 938         Support code for equality checking
 939 -----------------------------------------------------------
 940
 941 \begin{code}
 942 ------------------------------------
 943 type EqEnv = UniqFM FastString  -- Tracks the mapping from L-variables to R-variables
 944
 945 eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
 946 eqIfOcc env n1 n2 = case lookupUFM env n1 of
 947                         Just n1 -> bool (n1 == n2)
 948                         Nothing -> bool (n1 == n2)
 949
 950 extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
 951 extendEqEnv env n1 n2 | n1 == n2  = env
 952                       | otherwise = addToUFM env n1 n2
 953
 954 emptyEqEnv :: EqEnv
 955 emptyEqEnv = emptyUFM
 956
 957 ------------------------------------
 958 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
 959
 960 eq_ifNakedBndr :: ExtEnv FastString
 961 eq_ifBndr      :: ExtEnv IfaceBndr
 962 eq_ifTvBndr    :: ExtEnv IfaceTvBndr
 963 eq_ifIdBndr    :: ExtEnv IfaceIdBndr
 964
 965 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
 966
 967 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
 968 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
 969 eq_ifBndr _ _ _ _ = NotEqual
 970
 971 eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
 972 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
 973
 974 eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k
 975   = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2)
 976
 977 eq_ifBndrs      :: ExtEnv [IfaceBndr]
 978 eq_ifLetBndrs   :: ExtEnv [IfaceLetBndr]
 979 eq_ifTvBndrs    :: ExtEnv [IfaceTvBndr]
 980 eq_ifNakedBndrs :: ExtEnv [FastString]
 981 eq_ifBndrs      = eq_bndrs_with eq_ifBndr
 982 eq_ifTvBndrs    = eq_bndrs_with eq_ifTvBndr
 983 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
 984 eq_ifLetBndrs   = eq_bndrs_with eq_ifLetBndr
 985
 986 eq_bndrs_with eq env []       []       k = k env
 987 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
 988 eq_bndrs_with eq env _        _        _ = NotEqual
 989 \end{code}
 990
 991 \begin{code}
 992 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
 993 eqListBy eq []     []     = Equal
 994 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
 995 eqListBy eq xs     ys     = NotEqual
 996
 997 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
 998 eqMaybeBy eq Nothing Nothing   = Equal
 999 eqMaybeBy eq (Just x) (Just y) = eq x y
1000 eqMaybeBy eq x        y        = NotEqual
1001 \end{code}