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