compiler/iface/IfaceSyn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
  11 @TyVars@ as well.  Currently trying the former... MEGA SIGH.
  12
  13 \begin{code}
  14 module IfaceSyn (
  15         module IfaceType,               -- Re-export all this
  16
  17         IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
  18         IfaceExpr(..), IfaceAlt, IfaceNote(..),
  19         IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
  20         IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
  21
  22         -- Misc
  23         visibleIfConDecls,
  24
  25         -- Equality
  26         IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
  27         eqIfDecl, eqIfInst, eqIfRule, checkBootDecl,
  28
  29         -- Pretty printing
  30         pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
  31     ) where
  32
  33 #include "HsVersions.h"
  34
  35 import CoreSyn
  36 import IfaceType
  37
  38 import NewDemand        ( StrictSig, pprIfaceStrictSig )
  39 import TcType           ( deNoteType )
  40 import Class            ( FunDep, DefMeth, pprFundeps )
  41 import OccName          ( OccName, parenSymOcc, occNameFS,
  42                           OccSet, unionOccSets, unitOccSet )
  43 import UniqFM           ( UniqFM, emptyUFM, addToUFM, lookupUFM )
  44 import Name             ( Name, NamedThing(..), nameOccName, isExternalName )
  45 import CostCentre       ( CostCentre, pprCostCentreCore )
  46 import Literal          ( Literal )
  47 import ForeignCall      ( ForeignCall )
  48 import BasicTypes       ( Arity, Activation(..), StrictnessMark, OverlapFlag,
  49                           RecFlag(..), Boxity(..),
  50                           isAlwaysActive, tupleParens )
  51 import Outputable
  52 import FastString
  53 import Maybes           ( catMaybes )
  54 import Util             ( lengthIs )
  55
  56 infixl 3 &&&
  57 infix  4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
  58 \end{code}
  59
  60
  61 %************************************************************************
  62 %*                                                                      *
  63                 Data type declarations
  64 %*                                                                      *
  65 %************************************************************************
  66
  67 \begin{code}
  68 data IfaceDecl
  69   = IfaceId { ifName   :: OccName,
  70               ifType   :: IfaceType,
  71               ifIdInfo :: IfaceIdInfo }
  72
  73   | IfaceData { ifName       :: OccName,                -- Type constructor
  74                 ifTyVars     :: [IfaceTvBndr],  -- Type variables
  75                 ifCtxt       :: IfaceContext,   -- The "stupid theta"
  76                 ifCons       :: IfaceConDecls,  -- Includes new/data info
  77                 ifRec        :: RecFlag,        -- Recursive or not?
  78                 ifGadtSyntax :: Bool,           -- True <=> declared using GADT syntax
  79                 ifGeneric    :: Bool            -- True <=> generic converter functions available
  80     }                                           -- We need this for imported data decls, since the
  81                                                 -- imported modules may have been compiled with
  82                                                 -- different flags to the current compilation unit
  83
  84   | IfaceSyn  { ifName   :: OccName,            -- Type constructor
  85                 ifTyVars :: [IfaceTvBndr],      -- Type variables
  86                 ifSynRhs :: IfaceType           -- synonym expansion
  87     }
  88
  89   | IfaceClass { ifCtxt    :: IfaceContext,     -- Context...
  90                  ifName    :: OccName,          -- Name of the class
  91                  ifTyVars  :: [IfaceTvBndr],    -- Type variables
  92                  ifFDs     :: [FunDep FastString], -- Functional dependencies
  93                  ifSigs    :: [IfaceClassOp],   -- Method signatures
  94                  ifRec     :: RecFlag           -- Is newtype/datatype associated with the class recursive?
  95     }
  96
  97   | IfaceForeign { ifName :: OccName,           -- Needs expanding when we move beyond .NET
  98                    ifExtName :: Maybe FastString }
  99
 100 data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
 101         -- Nothing    => no default method
 102         -- Just False => ordinary polymorphic default method
 103         -- Just True  => generic default method
 104
 105 data IfaceConDecls
 106   = IfAbstractTyCon             -- No info
 107   | IfDataTyCon [IfaceConDecl]  -- data type decls
 108   | IfNewTyCon  IfaceConDecl    -- newtype decls
 109
 110 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 111 visibleIfConDecls IfAbstractTyCon  = []
 112 visibleIfConDecls (IfDataTyCon cs) = cs
 113 visibleIfConDecls (IfNewTyCon c)   = [c]
 114
 115 data IfaceConDecl
 116   = IfCon {
 117         ifConOcc     :: OccName,                -- Constructor name
 118         ifConInfix   :: Bool,                   -- True <=> declared infix
 119         ifConUnivTvs :: [IfaceTvBndr],          -- Universal tyvars
 120         ifConExTvs   :: [IfaceTvBndr],          -- Existential tyvars
 121         ifConEqSpec  :: [(OccName,IfaceType)],  -- Equality contraints
 122         ifConCtxt    :: IfaceContext,           -- Non-stupid context
 123         ifConArgTys  :: [IfaceType],            -- Arg types
 124         ifConFields  :: [OccName],              -- ...ditto... (field labels)
 125         ifConStricts :: [StrictnessMark] }      -- Empty (meaning all lazy), or 1-1 corresp with arg types
 126
 127 data IfaceInst
 128   = IfaceInst { ifInstCls  :: IfaceExtName,             -- See comments with
 129                 ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of Instance
 130                 ifDFun     :: OccName,                  -- The dfun
 131                 ifOFlag    :: OverlapFlag,              -- Overlap flag
 132                 ifInstOrph :: Maybe OccName }           -- See is_orph in defn of Instance
 133         -- There's always a separate IfaceDecl for the DFun, which gives
 134         -- its IdInfo with its full type and version number.
 135         -- The instance declarations taken together have a version number,
 136         -- and we don't want that to wobble gratuitously
 137         -- If this instance decl is *used*, we'll record a usage on the dfun;
 138         -- and if the head does not change it won't be used if it wasn't before
 139
 140 data IfaceRule
 141   = IfaceRule {
 142         ifRuleName   :: RuleName,
 143         ifActivation :: Activation,
 144         ifRuleBndrs  :: [IfaceBndr],    -- Tyvars and term vars
 145         ifRuleHead   :: IfaceExtName,   -- Head of lhs
 146         ifRuleArgs   :: [IfaceExpr],    -- Args of LHS
 147         ifRuleRhs    :: IfaceExpr,
 148         ifRuleOrph   :: Maybe OccName   -- Just like IfaceInst
 149     }
 150
 151 data IfaceIdInfo
 152   = NoInfo                      -- When writing interface file without -O
 153   | HasInfo [IfaceInfoItem]     -- Has info, and here it is
 154
 155 -- Here's a tricky case:
 156 --   * Compile with -O module A, and B which imports A.f
 157 --   * Change function f in A, and recompile without -O
 158 --   * When we read in old A.hi we read in its IdInfo (as a thunk)
 159 --      (In earlier GHCs we used to drop IdInfo immediately on reading,
 160 --       but we do not do that now.  Instead it's discarded when the
 161 --       ModIface is read into the various decl pools.)
 162 --   * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
 163 --      and so gives a new version.
 164
 165 data IfaceInfoItem
 166   = HsArity      Arity
 167   | HsStrictness StrictSig
 168   | HsInline     Activation
 169   | HsUnfold     IfaceExpr
 170   | HsNoCafRefs
 171   | HsWorker     IfaceExtName Arity     -- Worker, if any see IdInfo.WorkerInfo
 172                                         -- for why we want arity here.
 173         -- NB: we need IfaceExtName (not just OccName) because the worker
 174         --     can simplify to a function in another module.
 175 -- NB: Specialisations and rules come in separately and are
 176 -- only later attached to the Id.  Partial reason: some are orphans.
 177
 178 --------------------------------
 179 data IfaceExpr
 180   = IfaceLcl    FastString
 181   | IfaceExt    IfaceExtName
 182   | IfaceType   IfaceType
 183   | IfaceTuple  Boxity [IfaceExpr]              -- Saturated; type arguments omitted
 184   | IfaceLam    IfaceBndr IfaceExpr
 185   | IfaceApp    IfaceExpr IfaceExpr
 186   | IfaceCase   IfaceExpr FastString IfaceType [IfaceAlt]
 187   | IfaceLet    IfaceBinding  IfaceExpr
 188   | IfaceNote   IfaceNote IfaceExpr
 189   | IfaceCast   IfaceExpr IfaceCoercion
 190   | IfaceLit    Literal
 191   | IfaceFCall  ForeignCall IfaceType
 192
 193 data IfaceNote = IfaceSCC CostCentre
 194                | IfaceInlineMe
 195                | IfaceCoreNote String
 196
 197 type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
 198         -- Note: OccName, not IfaceBndr (and same with the case binder)
 199         -- We reconstruct the kind/type of the thing from the context
 200         -- thus saving bulk in interface files
 201
 202 data IfaceConAlt = IfaceDefault
 203                  | IfaceDataAlt OccName
 204                  | IfaceTupleAlt Boxity
 205                  | IfaceLitAlt Literal
 206
 207 data IfaceBinding
 208   = IfaceNonRec IfaceIdBndr IfaceExpr
 209   | IfaceRec    [(IfaceIdBndr, IfaceExpr)]
 210 \end{code}
 211
 212
 213 %************************************************************************
 214 %*                                                                      *
 215 \subsection[HsCore-print]{Printing Core unfoldings}
 216 %*                                                                      *
 217 %************************************************************************
 218
 219 ----------------------------- Printing IfaceDecl ------------------------------------
 220
 221 \begin{code}
 222 instance Outputable IfaceDecl where
 223   ppr = pprIfaceDecl
 224
 225 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
 226   = sep [ ppr var <+> dcolon <+> ppr ty,
 227           nest 2 (ppr info) ]
 228
 229 pprIfaceDecl (IfaceForeign {ifName = tycon})
 230   = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
 231
 232 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
 233   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
 234        4 (equals <+> ppr mono_ty)
 235
 236 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
 237                          ifTyVars = tyvars, ifCons = condecls,
 238                          ifRec = isrec})
 239   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
 240        4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls])
 241   where
 242     pp_nd = case condecls of
 243                 IfAbstractTyCon -> ptext SLIT("data")
 244                 IfDataTyCon _   -> ptext SLIT("data")
 245                 IfNewTyCon _    -> ptext SLIT("newtype")
 246
 247 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 248                           ifFDs = fds, ifSigs = sigs, ifRec = isrec})
 249   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
 250        4 (vcat [pprRec isrec,
 251                 sep (map ppr sigs)])
 252
 253 pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
 254 pprGen True  = ptext SLIT("Generics: yes")
 255 pprGen False = ptext SLIT("Generics: no")
 256
 257 instance Outputable IfaceClassOp where
 258    ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
 259
 260 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
 261 pprIfaceDeclHead context thing tyvars
 262   = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
 263
 264 pp_condecls tc IfAbstractTyCon  = ptext SLIT("{- abstract -}")
 265 pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
 266 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
 267                                                              (map (pprIfaceConDecl tc) cs))
 268
 269 pprIfaceConDecl tc
 270         (IfCon { ifConOcc = name, ifConInfix = is_infix,
 271                  ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
 272                  ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
 273                  ifConStricts = strs, ifConFields = fields })
 274   = sep [main_payload,
 275          if is_infix then ptext SLIT("Infix") else empty,
 276          if null strs then empty
 277               else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
 278          if null fields then empty
 279               else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
 280   where
 281     main_payload = ppr name <+> dcolon <+>
 282                    pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) (ppr con_tau)
 283
 284     eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
 285               | (tv,ty) <- eq_spec]
 286     con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app])
 287     tc_app  = IfaceTyConApp (IfaceTc (LocalTop tc))
 288                             [IfaceTyVar tv | (tv,_) <- univ_tvs]
 289         -- Gruesome, but jsut for debug print
 290
 291 instance Outputable IfaceRule where
 292   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
 293                    ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
 294     = sep [hsep [doubleQuotes (ftext name), ppr act,
 295                  ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
 296            nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
 297                         ptext SLIT("=") <+> ppr rhs])
 298       ]
 299
 300 instance Outputable IfaceInst where
 301   ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
 302                   ifInstCls = cls, ifInstTys = mb_tcs})
 303     = hang (ptext SLIT("instance") <+> ppr flag
 304                 <+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs))
 305          2 (equals <+> ppr dfun_id)
 306     where
 307       ppr_mb Nothing   = dot
 308       ppr_mb (Just tc) = ppr tc
 309 \end{code}
 310
 311
 312 ----------------------------- Printing IfaceExpr ------------------------------------
 313
 314 \begin{code}
 315 instance Outputable IfaceExpr where
 316     ppr e = pprIfaceExpr noParens e
 317
 318 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
 319         -- The function adds parens in context that need
 320         -- an atomic value (e.g. function args)
 321
 322 pprIfaceExpr add_par (IfaceLcl v)       = ppr v
 323 pprIfaceExpr add_par (IfaceExt v)       = ppr v
 324 pprIfaceExpr add_par (IfaceLit l)       = ppr l
 325 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 326 pprIfaceExpr add_par (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
 327
 328 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 329 pprIfaceExpr add_par (IfaceTuple c as)  = tupleParens c (interpp'SP as)
 330
 331 pprIfaceExpr add_par e@(IfaceLam _ _)
 332   = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
 333                   pprIfaceExpr noParens body])
 334   where
 335     (bndrs,body) = collect [] e
 336     collect bs (IfaceLam b e) = collect (b:bs) e
 337     collect bs e              = (reverse bs, e)
 338
 339 -- gaw 2004
 340 pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
 341 -- gaw 2004
 342   = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
 343                         <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
 344                   pprIfaceExpr noParens rhs <+> char '}'])
 345
 346 -- gaw 2004
 347 pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
 348 -- gaw 2004
 349   = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
 350                         <+> ppr bndr <+> char '{',
 351                   nest 2 (sep (map ppr_alt alts)) <+> char '}'])
 352
 353 pprIfaceExpr add_par (IfaceCast expr co) = add_par (ptext SLIT("cast") <+> ppr expr <+> ppr co)
 354
 355 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
 356   = add_par (sep [ptext SLIT("let {"),
 357                   nest 2 (ppr_bind (b, rhs)),
 358                   ptext SLIT("} in"),
 359                   pprIfaceExpr noParens body])
 360
 361 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
 362   = add_par (sep [ptext SLIT("letrec {"),
 363                   nest 2 (sep (map ppr_bind pairs)),
 364                   ptext SLIT("} in"),
 365                   pprIfaceExpr noParens body])
 366
 367 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
 368
 369 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
 370                               arrow <+> pprIfaceExpr noParens rhs]
 371
 372 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
 373 ppr_con_bs con bs                     = ppr con <+> hsep (map ppr bs)
 374
 375 ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
 376                              equals <+> pprIfaceExpr noParens rhs]
 377
 378 ------------------
 379 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
 380 pprIfaceApp fun                args = sep (pprIfaceExpr parens fun : args)
 381
 382 ------------------
 383 instance Outputable IfaceNote where
 384     ppr (IfaceSCC cc)     = pprCostCentreCore cc
 385     ppr IfaceInlineMe     = ptext SLIT("__inline_me")
 386     ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
 387
 388 instance Outputable IfaceConAlt where
 389     ppr IfaceDefault      = text "DEFAULT"
 390     ppr (IfaceLitAlt l)   = ppr l
 391     ppr (IfaceDataAlt d)  = ppr d
 392     ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
 393         -- IfaceTupleAlt is handled by the case-alternative printer
 394
 395 ------------------
 396 instance Outputable IfaceIdInfo where
 397    ppr NoInfo       = empty
 398    ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
 399
 400 ppr_hs_info (HsUnfold unf)      = ptext SLIT("Unfolding:") <+>
 401                                         parens (pprIfaceExpr noParens unf)
 402 ppr_hs_info (HsInline act)      = ptext SLIT("Inline:") <+> ppr act
 403 ppr_hs_info (HsArity arity)     = ptext SLIT("Arity:") <+> int arity
 404 ppr_hs_info (HsStrictness str)  = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
 405 ppr_hs_info HsNoCafRefs         = ptext SLIT("HasNoCafRefs")
 406 ppr_hs_info (HsWorker w a)      = ptext SLIT("Worker:") <+> ppr w <+> int a
 407 \end{code}
 408
 409
 410 %************************************************************************
 411 %*                                                                      *
 412         Equality, for interface file version generaion only
 413 %*                                                                      *
 414 %************************************************************************
 415
 416 Equality over IfaceSyn returns an IfaceEq, not a Bool.  The new constructor is
 417 EqBut, which gives the set of *locally-defined* things whose version must be equal
 418 for the whole thing to be equal.  So the key function is eqIfExt, which compares
 419 IfaceExtNames.
 420
 421 Of course, equality is also done modulo alpha conversion.
 422
 423 \begin{code}
 424 data IfaceEq
 425   = Equal               -- Definitely exactly the same
 426   | NotEqual            -- Definitely different
 427   | EqBut OccSet        -- The same provided these local things have not changed
 428
 429 bool :: Bool -> IfaceEq
 430 bool True  = Equal
 431 bool False = NotEqual
 432
 433 toBool :: IfaceEq -> Bool
 434 toBool Equal     = True
 435 toBool (EqBut _) = True
 436 toBool NotEqual  = False
 437
 438 zapEq :: IfaceEq -> IfaceEq     -- Used to forget EqBut information
 439 zapEq (EqBut _) = Equal
 440 zapEq other     = other
 441
 442 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
 443 Equal       &&& x           = x
 444 NotEqual    &&& x           = NotEqual
 445 EqBut occs  &&& Equal       = EqBut occs
 446 EqBut occs  &&& NotEqual    = NotEqual
 447 EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
 448
 449 ---------------------
 450 eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
 451 -- This function is the core of the EqBut stuff
 452 eqIfExt (ExtPkg mod1 occ1)     (ExtPkg mod2 occ2)     = bool (mod1==mod2 && occ1==occ2)
 453 eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
 454 eqIfExt (LocalTop occ1)       (LocalTop occ2)      | occ1 == occ2 = EqBut (unitOccSet occ1)
 455 eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2)      | occ1 == occ2 = EqBut (unitOccSet p1)
 456 eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
 457 eqIfExt n1 n2 = NotEqual
 458 \end{code}
 459
 460
 461 \begin{code}
 462 ---------------------
 463 checkBootDecl :: IfaceDecl      -- The boot decl
 464               -> IfaceDecl      -- The real decl
 465               -> Bool           -- True <=> compatible
 466 checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
 467   = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
 468
 469 checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 470   = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
 471
 472 checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 473   = ASSERT( ifName d1 == ifName d2 )
 474     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 475           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 476
 477 checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
 478 -- We don't check the recursion flags because the boot-one is
 479 -- recursive, to be conservative, but the real one may not be.
 480 -- I'm not happy with the way recursive flags are dealt with.
 481   = ASSERT( ifName d1    == ifName d2 )
 482     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 483         eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 484         case ifCons d1 of
 485             IfAbstractTyCon -> Equal
 486             cons1           -> eq_hsCD env cons1 (ifCons d2)
 487
 488 checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 489   = ASSERT( ifName d1 == ifName d2 )
 490     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 491           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 492           case (ifCtxt d1, ifSigs d1) of
 493              ([], [])      -> Equal
 494              (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2)  &&&
 495                               eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
 496
 497 checkBootDecl _ _ = False       -- default case
 498
 499 ---------------------
 500 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
 501 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
 502   = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
 503
 504 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 505   = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
 506
 507 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
 508   = bool (ifName d1    == ifName d2 &&
 509           ifRec d1     == ifRec   d2 &&
 510           ifGadtSyntax d1 == ifGadtSyntax   d2 &&
 511           ifGeneric d1 == ifGeneric d2) &&&
 512     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 513             eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 514             eq_hsCD env (ifCons d1) (ifCons d2)
 515         )
 516         -- The type variables of the data type do not scope
 517         -- over the constructors (any more), but they do scope
 518         -- over the stupid context in the IfaceConDecls
 519
 520 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 521   = bool (ifName d1 == ifName d2) &&&
 522     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 523           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 524         )
 525
 526 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 527   = bool (ifName d1 == ifName d2 &&
 528           ifRec d1  == ifRec  d2) &&&
 529     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 530           eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
 531           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 532           eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
 533        )
 534
 535 eqIfDecl _ _ = NotEqual -- default case
 536
 537 -- Helper
 538 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
 539 eqWith = eq_ifTvBndrs emptyEqEnv
 540
 541 -----------------------
 542 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
 543 -- All other changes are handled via the version info on the dfun
 544
 545 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
 546          (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
 547        = bool (n1==n2 && a1==a2 && o1 == o2) &&&
 548          f1 `eqIfExt` f2 &&&
 549          eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
 550          zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
 551                 -- zapEq: for the LHSs, ignore the EqBut part
 552          eq_ifaceExpr env rhs1 rhs2)
 553
 554 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
 555   = eqListBy (eq_ConDecl env) c1 c2
 556
 557 eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
 558 eq_hsCD env IfAbstractTyCon  IfAbstractTyCon  = Equal
 559 eq_hsCD env d1               d2               = NotEqual
 560
 561 eq_ConDecl env c1 c2
 562   = bool (ifConOcc c1     == ifConOcc c2 &&
 563           ifConInfix c1   == ifConInfix c2 &&
 564           ifConStricts c1 == ifConStricts c2 &&
 565           ifConFields c1  == ifConFields c2) &&&
 566     eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
 567     eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
 568         eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
 569         eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
 570
 571 eq_hsFD env (ns1,ms1) (ns2,ms2)
 572   = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
 573
 574 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
 575   = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
 576 \end{code}
 577
 578
 579 \begin{code}
 580 -----------------
 581 eqIfIdInfo NoInfo        NoInfo        = Equal
 582 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
 583 eqIfIdInfo i1            i2 = NotEqual
 584
 585 eq_item (HsInline a1)      (HsInline a2)      = bool (a1 == a2)
 586 eq_item (HsArity a1)       (HsArity a2)       = bool (a1 == a2)
 587 eq_item (HsStrictness s1)  (HsStrictness s2)  = bool (s1 == s2)
 588 eq_item (HsUnfold u1)   (HsUnfold u2)         = eq_ifaceExpr emptyEqEnv u1 u2
 589 eq_item HsNoCafRefs        HsNoCafRefs        = Equal
 590 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
 591 eq_item _ _ = NotEqual
 592
 593 -----------------
 594 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
 595 eq_ifaceExpr env (IfaceLcl v1)        (IfaceLcl v2)        = eqIfOcc env v1 v2
 596 eq_ifaceExpr env (IfaceExt v1)        (IfaceExt v2)        = eqIfExt v1 v2
 597 eq_ifaceExpr env (IfaceLit l1)        (IfaceLit l2)        = bool (l1 == l2)
 598 eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
 599 eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)      = eq_ifType env ty1 ty2
 600 eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
 601 eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
 602 eq_ifaceExpr env (IfaceApp f1 a1)     (IfaceApp f2 a2)     = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
 603 eq_ifaceExpr env (IfaceCast e1 co1)   (IfaceCast e2 co2)   = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
 604 eq_ifaceExpr env (IfaceNote n1 r1)    (IfaceNote n2 r2)    = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
 605
 606 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
 607   = eq_ifaceExpr env s1 s2 &&&
 608     eq_ifType env ty1 ty2 &&&
 609     eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
 610   where
 611     eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
 612         = bool (eq_ifaceConAlt c1 c2) &&&
 613           eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
 614
 615 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
 616   = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
 617
 618 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
 619   = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
 620   where
 621     (bs1,rs1) = unzip as1
 622     (bs2,rs2) = unzip as2
 623
 624
 625 eq_ifaceExpr env _ _ = NotEqual
 626
 627 -----------------
 628 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
 629 eq_ifaceConAlt IfaceDefault       IfaceDefault          = True
 630 eq_ifaceConAlt (IfaceDataAlt n1)  (IfaceDataAlt n2)     = n1==n2
 631 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2)    = c1==c2
 632 eq_ifaceConAlt (IfaceLitAlt l1)   (IfaceLitAlt l2)      = l1==l2
 633 eq_ifaceConAlt _ _ = False
 634
 635 -----------------
 636 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
 637 eq_ifaceNote env (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
 638 eq_ifaceNote env IfaceInlineMe    IfaceInlineMe        = Equal
 639 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
 640 eq_ifaceNote env _ _ = NotEqual
 641 \end{code}
 642
 643 \begin{code}
 644 ---------------------
 645 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
 646
 647 -------------------
 648 eq_ifType env (IfaceTyVar n1)         (IfaceTyVar n2)         = eqIfOcc env n1 n2
 649 eq_ifType env (IfaceAppTy s1 t1)      (IfaceAppTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 650 eq_ifType env (IfacePredTy st1)       (IfacePredTy st2)       = eq_ifPredType env st1 st2
 651 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
 652 eq_ifType env (IfaceForAllTy tv1 t1)  (IfaceForAllTy tv2 t2)  = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
 653 eq_ifType env (IfaceFunTy s1 t1)      (IfaceFunTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 654 eq_ifType env _ _ = NotEqual
 655
 656 -------------------
 657 eq_ifTypes env = eqListBy (eq_ifType env)
 658
 659 -------------------
 660 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
 661
 662 -------------------
 663 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&&  eq_ifTypes env tys1 tys2
 664 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2)   = bool (n1 == n2) &&& eq_ifType env ty1 ty2
 665 eq_ifPredType env _ _ = NotEqual
 666
 667 -------------------
 668 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
 669 eqIfTc IfaceIntTc    IfaceIntTc    = Equal
 670 eqIfTc IfaceCharTc   IfaceCharTc   = Equal
 671 eqIfTc IfaceBoolTc   IfaceBoolTc   = Equal
 672 eqIfTc IfaceListTc   IfaceListTc   = Equal
 673 eqIfTc IfacePArrTc   IfacePArrTc   = Equal
 674 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
 675 eqIfTc _ _ = NotEqual
 676 \end{code}
 677
 678 -----------------------------------------------------------
 679         Support code for equality checking
 680 -----------------------------------------------------------
 681
 682 \begin{code}
 683 ------------------------------------
 684 type EqEnv = UniqFM FastString  -- Tracks the mapping from L-variables to R-variables
 685
 686 eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
 687 eqIfOcc env n1 n2 = case lookupUFM env n1 of
 688                         Just n1 -> bool (n1 == n2)
 689                         Nothing -> bool (n1 == n2)
 690
 691 extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
 692 extendEqEnv env n1 n2 | n1 == n2  = env
 693                       | otherwise = addToUFM env n1 n2
 694
 695 emptyEqEnv :: EqEnv
 696 emptyEqEnv = emptyUFM
 697
 698 ------------------------------------
 699 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
 700
 701 eq_ifNakedBndr :: ExtEnv FastString
 702 eq_ifBndr      :: ExtEnv IfaceBndr
 703 eq_ifTvBndr    :: ExtEnv IfaceTvBndr
 704 eq_ifIdBndr    :: ExtEnv IfaceIdBndr
 705
 706 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
 707
 708 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
 709 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
 710 eq_ifBndr _ _ _ _ = NotEqual
 711
 712 eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
 713 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
 714
 715 eq_ifBndrs      :: ExtEnv [IfaceBndr]
 716 eq_ifIdBndrs    :: ExtEnv [IfaceIdBndr]
 717 eq_ifTvBndrs    :: ExtEnv [IfaceTvBndr]
 718 eq_ifNakedBndrs :: ExtEnv [FastString]
 719 eq_ifBndrs      = eq_bndrs_with eq_ifBndr
 720 eq_ifIdBndrs    = eq_bndrs_with eq_ifIdBndr
 721 eq_ifTvBndrs    = eq_bndrs_with eq_ifTvBndr
 722 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
 723
 724 eq_bndrs_with eq env []       []       k = k env
 725 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
 726 eq_bndrs_with eq env _        _        _ = NotEqual
 727 \end{code}
 728
 729 \begin{code}
 730 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
 731 eqListBy eq []     []     = Equal
 732 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
 733 eqListBy eq xs     ys     = NotEqual
 734
 735 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
 736 eqMaybeBy eq Nothing Nothing   = Equal
 737 eqMaybeBy eq (Just x) (Just y) = eq x y
 738 eqMaybeBy eq x        y        = NotEqual
 739 \end{code}