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