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, occSetElts )
  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 pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
 388   = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
 389                         <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
 390                         <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
 391                   pprIfaceExpr noParens rhs <+> char '}'])
 392
 393 pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
 394   = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
 395                         <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
 396                         <+> ppr bndr <+> char '{',
 397                   nest 2 (sep (map ppr_alt alts)) <+> char '}'])
 398
 399 pprIfaceExpr add_par (IfaceCast expr co)
 400   = sep [pprIfaceExpr parens expr,
 401          nest 2 (ptext SLIT("`cast`")),
 402          pprParendIfaceType co]
 403
 404 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
 405   = add_par (sep [ptext SLIT("let {"),
 406                   nest 2 (ppr_bind (b, rhs)),
 407                   ptext SLIT("} in"),
 408                   pprIfaceExpr noParens body])
 409
 410 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
 411   = add_par (sep [ptext SLIT("letrec {"),
 412                   nest 2 (sep (map ppr_bind pairs)),
 413                   ptext SLIT("} in"),
 414                   pprIfaceExpr noParens body])
 415
 416 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
 417
 418 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
 419                               arrow <+> pprIfaceExpr noParens rhs]
 420
 421 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
 422 ppr_con_bs con bs                     = ppr con <+> hsep (map ppr bs)
 423
 424 ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
 425                              equals <+> pprIfaceExpr noParens rhs]
 426
 427 ------------------
 428 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
 429 pprIfaceApp fun                args = sep (pprIfaceExpr parens fun : args)
 430
 431 ------------------
 432 instance Outputable IfaceNote where
 433     ppr (IfaceSCC cc)     = pprCostCentreCore cc
 434     ppr IfaceInlineMe     = ptext SLIT("__inline_me")
 435     ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
 436
 437 instance Outputable IfaceConAlt where
 438     ppr IfaceDefault      = text "DEFAULT"
 439     ppr (IfaceLitAlt l)   = ppr l
 440     ppr (IfaceDataAlt d)  = ppr d
 441     ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
 442         -- IfaceTupleAlt is handled by the case-alternative printer
 443
 444 ------------------
 445 instance Outputable IfaceIdInfo where
 446    ppr NoInfo       = empty
 447    ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
 448
 449 ppr_hs_info (HsUnfold unf)      = ptext SLIT("Unfolding:") <+>
 450                                         parens (pprIfaceExpr noParens unf)
 451 ppr_hs_info (HsInline act)      = ptext SLIT("Inline:") <+> ppr act
 452 ppr_hs_info (HsArity arity)     = ptext SLIT("Arity:") <+> int arity
 453 ppr_hs_info (HsStrictness str)  = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
 454 ppr_hs_info HsNoCafRefs         = ptext SLIT("HasNoCafRefs")
 455 ppr_hs_info (HsWorker w a)      = ptext SLIT("Worker:") <+> ppr w <+> int a
 456 \end{code}
 457
 458
 459 %************************************************************************
 460 %*                                                                      *
 461         Equality, for interface file version generaion only
 462 %*                                                                      *
 463 %************************************************************************
 464
 465 Equality over IfaceSyn returns an IfaceEq, not a Bool.  The new constructor is
 466 EqBut, which gives the set of *locally-defined* things whose version must be equal
 467 for the whole thing to be equal.  So the key function is eqIfExt, which compares
 468 IfaceExtNames.
 469
 470 Of course, equality is also done modulo alpha conversion.
 471
 472 \begin{code}
 473 data IfaceEq
 474   = Equal               -- Definitely exactly the same
 475   | NotEqual            -- Definitely different
 476   | EqBut OccSet        -- The same provided these local things have not changed
 477
 478 instance Outputable IfaceEq where
 479   ppr Equal          = ptext SLIT("Equal")
 480   ppr NotEqual       = ptext SLIT("NotEqual")
 481   ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (occSetElts occset)
 482
 483 bool :: Bool -> IfaceEq
 484 bool True  = Equal
 485 bool False = NotEqual
 486
 487 toBool :: IfaceEq -> Bool
 488 toBool Equal     = True
 489 toBool (EqBut _) = True
 490 toBool NotEqual  = False
 491
 492 zapEq :: IfaceEq -> IfaceEq     -- Used to forget EqBut information
 493 zapEq (EqBut _) = Equal
 494 zapEq other     = other
 495
 496 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
 497 Equal       &&& x           = x
 498 NotEqual    &&& x           = NotEqual
 499 EqBut occs  &&& Equal       = EqBut occs
 500 EqBut occs  &&& NotEqual    = NotEqual
 501 EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
 502
 503 ---------------------
 504 eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
 505 -- This function is the core of the EqBut stuff
 506 eqIfExt (ExtPkg mod1 occ1)     (ExtPkg mod2 occ2)     = bool (mod1==mod2 && occ1==occ2)
 507 eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
 508 eqIfExt (LocalTop occ1)       (LocalTop occ2)      | occ1 == occ2 = EqBut (unitOccSet occ1)
 509 eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2)      | occ1 == occ2 = EqBut (unitOccSet p1)
 510 eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
 511 eqIfExt n1 n2 = NotEqual
 512 \end{code}
 513
 514
 515 \begin{code}
 516 ---------------------
 517 checkBootDecl :: IfaceDecl      -- The boot decl
 518               -> IfaceDecl      -- The real decl
 519               -> Bool           -- True <=> compatible
 520 checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
 521   = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
 522
 523 checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 524   = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
 525
 526 checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 527   = ASSERT( ifName d1 == ifName d2 )
 528     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 529           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 530
 531 checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
 532 -- We don't check the recursion flags because the boot-one is
 533 -- recursive, to be conservative, but the real one may not be.
 534 -- I'm not happy with the way recursive flags are dealt with.
 535   = ASSERT( ifName d1    == ifName d2 )
 536     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 537         eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 538         case ifCons d1 of
 539             IfAbstractTyCon -> Equal
 540             cons1           -> eq_hsCD env cons1 (ifCons d2)
 541
 542 checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 543   = ASSERT( ifName d1 == ifName d2 )
 544     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 545           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 546           case (ifCtxt d1, ifSigs d1) of
 547              ([], [])      -> Equal
 548              (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2)  &&&
 549                               eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
 550
 551 checkBootDecl _ _ = False       -- default case
 552
 553 ---------------------
 554 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
 555 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
 556   = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
 557
 558 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 559   = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
 560
 561 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
 562   = bool (ifName d1    == ifName d2 &&
 563           ifRec d1     == ifRec   d2 &&
 564           ifGadtSyntax d1 == ifGadtSyntax   d2 &&
 565           ifGeneric d1 == ifGeneric d2) &&&
 566     ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
 567     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 568             eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 569             eq_hsCD env (ifCons d1) (ifCons d2)
 570         )
 571         -- The type variables of the data type do not scope
 572         -- over the constructors (any more), but they do scope
 573         -- over the stupid context in the IfaceConDecls
 574   where
 575     Nothing             `eqIfTc_fam` Nothing                         = Equal
 576     (Just (IfaceFamInst fam1 tys1))
 577                         `eqIfTc_fam` (Just (IfaceFamInst fam2 tys2)) =
 578       fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
 579     _                   `eqIfTc_fam` _                               = NotEqual
 580
 581 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 582   = bool (ifName d1 == ifName d2) &&&
 583     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 584           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 585         )
 586
 587 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 588   = bool (ifName d1 == ifName d2 &&
 589           ifRec d1  == ifRec  d2) &&&
 590     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 591           eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
 592           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 593           eqListBy eqIfDecl         (ifATs d1)  (ifATs d2) &&&
 594           eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
 595        )
 596
 597 eqIfDecl _ _ = NotEqual -- default case
 598
 599 -- Helper
 600 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
 601 eqWith = eq_ifTvBndrs emptyEqEnv
 602
 603 -----------------------
 604 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
 605 -- All other changes are handled via the version info on the dfun
 606
 607 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
 608          (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
 609        = bool (n1==n2 && a1==a2 && o1 == o2) &&&
 610          f1 `eqIfExt` f2 &&&
 611          eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
 612          zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
 613                 -- zapEq: for the LHSs, ignore the EqBut part
 614          eq_ifaceExpr env rhs1 rhs2)
 615
 616 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
 617   = eqListBy (eq_ConDecl env) c1 c2
 618
 619 eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
 620 eq_hsCD env IfAbstractTyCon  IfAbstractTyCon  = Equal
 621 eq_hsCD env IfOpenDataTyCon  IfOpenDataTyCon  = Equal
 622 eq_hsCD env IfOpenNewTyCon   IfOpenNewTyCon   = Equal
 623 eq_hsCD env d1               d2               = NotEqual
 624
 625 eq_ConDecl env c1 c2
 626   = bool (ifConOcc c1     == ifConOcc c2 &&
 627           ifConInfix c1   == ifConInfix c2 &&
 628           ifConStricts c1 == ifConStricts c2 &&
 629           ifConFields c1  == ifConFields c2) &&&
 630     eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
 631     eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
 632         eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
 633         eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
 634
 635 eq_hsFD env (ns1,ms1) (ns2,ms2)
 636   = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
 637
 638 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
 639   = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
 640 \end{code}
 641
 642
 643 \begin{code}
 644 -----------------
 645 eqIfIdInfo NoInfo        NoInfo        = Equal
 646 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
 647 eqIfIdInfo i1            i2 = NotEqual
 648
 649 eq_item (HsInline a1)      (HsInline a2)      = bool (a1 == a2)
 650 eq_item (HsArity a1)       (HsArity a2)       = bool (a1 == a2)
 651 eq_item (HsStrictness s1)  (HsStrictness s2)  = bool (s1 == s2)
 652 eq_item (HsUnfold u1)   (HsUnfold u2)         = eq_ifaceExpr emptyEqEnv u1 u2
 653 eq_item HsNoCafRefs        HsNoCafRefs        = Equal
 654 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
 655 eq_item _ _ = NotEqual
 656
 657 -----------------
 658 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
 659 eq_ifaceExpr env (IfaceLcl v1)        (IfaceLcl v2)        = eqIfOcc env v1 v2
 660 eq_ifaceExpr env (IfaceExt v1)        (IfaceExt v2)        = eqIfExt v1 v2
 661 eq_ifaceExpr env (IfaceLit l1)        (IfaceLit l2)        = bool (l1 == l2)
 662 eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
 663 eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)      = eq_ifType env ty1 ty2
 664 eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
 665 eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
 666 eq_ifaceExpr env (IfaceApp f1 a1)     (IfaceApp f2 a2)     = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
 667 eq_ifaceExpr env (IfaceCast e1 co1)   (IfaceCast e2 co2)   = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
 668 eq_ifaceExpr env (IfaceNote n1 r1)    (IfaceNote n2 r2)    = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
 669
 670 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
 671   = eq_ifaceExpr env s1 s2 &&&
 672     eq_ifType env ty1 ty2 &&&
 673     eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
 674   where
 675     eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
 676         = bool (eq_ifaceConAlt c1 c2) &&&
 677           eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
 678
 679 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
 680   = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
 681
 682 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
 683   = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
 684   where
 685     (bs1,rs1) = unzip as1
 686     (bs2,rs2) = unzip as2
 687
 688
 689 eq_ifaceExpr env _ _ = NotEqual
 690
 691 -----------------
 692 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
 693 eq_ifaceConAlt IfaceDefault       IfaceDefault          = True
 694 eq_ifaceConAlt (IfaceDataAlt n1)  (IfaceDataAlt n2)     = n1==n2
 695 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2)    = c1==c2
 696 eq_ifaceConAlt (IfaceLitAlt l1)   (IfaceLitAlt l2)      = l1==l2
 697 eq_ifaceConAlt _ _ = False
 698
 699 -----------------
 700 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
 701 eq_ifaceNote env (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
 702 eq_ifaceNote env IfaceInlineMe    IfaceInlineMe        = Equal
 703 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
 704 eq_ifaceNote env _ _ = NotEqual
 705 \end{code}
 706
 707 \begin{code}
 708 ---------------------
 709 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
 710
 711 -------------------
 712 eq_ifType env (IfaceTyVar n1)         (IfaceTyVar n2)         = eqIfOcc env n1 n2
 713 eq_ifType env (IfaceAppTy s1 t1)      (IfaceAppTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 714 eq_ifType env (IfacePredTy st1)       (IfacePredTy st2)       = eq_ifPredType env st1 st2
 715 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
 716 eq_ifType env (IfaceForAllTy tv1 t1)  (IfaceForAllTy tv2 t2)  = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
 717 eq_ifType env (IfaceFunTy s1 t1)      (IfaceFunTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 718 eq_ifType env _ _ = NotEqual
 719
 720 -------------------
 721 eq_ifTypes env = eqListBy (eq_ifType env)
 722
 723 -------------------
 724 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
 725
 726 -------------------
 727 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&&  eq_ifTypes env tys1 tys2
 728 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2)   = bool (n1 == n2) &&& eq_ifType env ty1 ty2
 729 eq_ifPredType env _ _ = NotEqual
 730
 731 -------------------
 732 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
 733 eqIfTc IfaceIntTc    IfaceIntTc    = Equal
 734 eqIfTc IfaceCharTc   IfaceCharTc   = Equal
 735 eqIfTc IfaceBoolTc   IfaceBoolTc   = Equal
 736 eqIfTc IfaceListTc   IfaceListTc   = Equal
 737 eqIfTc IfacePArrTc   IfacePArrTc   = Equal
 738 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
 739 eqIfTc IfaceLiftedTypeKindTc   IfaceLiftedTypeKindTc   = Equal
 740 eqIfTc IfaceOpenTypeKindTc     IfaceOpenTypeKindTc     = Equal
 741 eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
 742 eqIfTc IfaceUbxTupleKindTc     IfaceUbxTupleKindTc     = Equal
 743 eqIfTc IfaceArgTypeKindTc      IfaceArgTypeKindTc      = Equal
 744 eqIfTc _                       _                       = NotEqual
 745 \end{code}
 746
 747 -----------------------------------------------------------
 748         Support code for equality checking
 749 -----------------------------------------------------------
 750
 751 \begin{code}
 752 ------------------------------------
 753 type EqEnv = UniqFM FastString  -- Tracks the mapping from L-variables to R-variables
 754
 755 eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
 756 eqIfOcc env n1 n2 = case lookupUFM env n1 of
 757                         Just n1 -> bool (n1 == n2)
 758                         Nothing -> bool (show n1 == show n2)
 759
 760 extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
 761 extendEqEnv env n1 n2 | n1 == n2  = env
 762                       | otherwise = addToUFM env n1 n2
 763
 764 emptyEqEnv :: EqEnv
 765 emptyEqEnv = emptyUFM
 766
 767 ------------------------------------
 768 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
 769
 770 eq_ifNakedBndr :: ExtEnv FastString
 771 eq_ifBndr      :: ExtEnv IfaceBndr
 772 eq_ifTvBndr    :: ExtEnv IfaceTvBndr
 773 eq_ifIdBndr    :: ExtEnv IfaceIdBndr
 774
 775 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
 776
 777 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
 778 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
 779 eq_ifBndr _ _ _ _ = NotEqual
 780
 781 eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
 782 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
 783
 784 eq_ifBndrs      :: ExtEnv [IfaceBndr]
 785 eq_ifIdBndrs    :: ExtEnv [IfaceIdBndr]
 786 eq_ifTvBndrs    :: ExtEnv [IfaceTvBndr]
 787 eq_ifNakedBndrs :: ExtEnv [FastString]
 788 eq_ifBndrs      = eq_bndrs_with eq_ifBndr
 789 eq_ifIdBndrs    = eq_bndrs_with eq_ifIdBndr
 790 eq_ifTvBndrs    = eq_bndrs_with eq_ifTvBndr
 791 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
 792
 793 eq_bndrs_with eq env []       []       k = k env
 794 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
 795 eq_bndrs_with eq env _        _        _ = NotEqual
 796 \end{code}
 797
 798 \begin{code}
 799 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
 800 eqListBy eq []     []     = Equal
 801 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
 802 eqListBy eq xs     ys     = NotEqual
 803
 804 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
 805 eqMaybeBy eq Nothing Nothing   = Equal
 806 eqMaybeBy eq (Just x) (Just y) = eq x y
 807 eqMaybeBy eq x        y        = NotEqual
 808 \end{code}