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