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 -- 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 instance Outputable IfaceEq where
 478   ppr Equal          = ptext SLIT("Equal")
 479   ppr NotEqual       = ptext SLIT("NotEqual")
 480   ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (occSetElts occset)
 481
 482 bool :: Bool -> IfaceEq
 483 bool True  = Equal
 484 bool False = NotEqual
 485
 486 toBool :: IfaceEq -> Bool
 487 toBool Equal     = True
 488 toBool (EqBut _) = True
 489 toBool NotEqual  = False
 490
 491 zapEq :: IfaceEq -> IfaceEq     -- Used to forget EqBut information
 492 zapEq (EqBut _) = Equal
 493 zapEq other     = other
 494
 495 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
 496 Equal       &&& x           = x
 497 NotEqual    &&& x           = NotEqual
 498 EqBut occs  &&& Equal       = EqBut occs
 499 EqBut occs  &&& NotEqual    = NotEqual
 500 EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
 501
 502 ---------------------
 503 eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
 504 -- This function is the core of the EqBut stuff
 505 eqIfExt (ExtPkg mod1 occ1)     (ExtPkg mod2 occ2)     = bool (mod1==mod2 && occ1==occ2)
 506 eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
 507 eqIfExt (LocalTop occ1)       (LocalTop occ2)      | occ1 == occ2 = EqBut (unitOccSet occ1)
 508 eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2)      | occ1 == occ2 = EqBut (unitOccSet p1)
 509 eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
 510 eqIfExt n1 n2 = NotEqual
 511 \end{code}
 512
 513
 514 \begin{code}
 515 ---------------------
 516 checkBootDecl :: IfaceDecl      -- The boot decl
 517               -> IfaceDecl      -- The real decl
 518               -> Bool           -- True <=> compatible
 519 checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
 520   = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
 521
 522 checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 523   = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
 524
 525 checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 526   = ASSERT( ifName d1 == ifName d2 )
 527     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 528           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 529
 530 checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
 531 -- We don't check the recursion flags because the boot-one is
 532 -- recursive, to be conservative, but the real one may not be.
 533 -- I'm not happy with the way recursive flags are dealt with.
 534   = ASSERT( ifName d1    == ifName d2 )
 535     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 536         eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 537         case ifCons d1 of
 538             IfAbstractTyCon -> Equal
 539             cons1           -> eq_hsCD env cons1 (ifCons d2)
 540
 541 checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 542   = ASSERT( ifName d1 == ifName d2 )
 543     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 544           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 545           case (ifCtxt d1, ifSigs d1) of
 546              ([], [])      -> Equal
 547              (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2)  &&&
 548                               eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
 549
 550 checkBootDecl _ _ = False       -- default case
 551
 552 ---------------------
 553 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
 554 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
 555   = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
 556
 557 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 558   = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
 559
 560 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
 561   = bool (ifName d1    == ifName d2 &&
 562           ifRec d1     == ifRec   d2 &&
 563           ifGadtSyntax d1 == ifGadtSyntax   d2 &&
 564           ifGeneric d1 == ifGeneric d2) &&&
 565     ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
 566     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 567             eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 568             eq_hsCD env (ifCons d1) (ifCons d2)
 569         )
 570         -- The type variables of the data type do not scope
 571         -- over the constructors (any more), but they do scope
 572         -- over the stupid context in the IfaceConDecls
 573   where
 574     Nothing             `eqIfTc_fam` Nothing                         = Equal
 575     (Just (IfaceFamInst fam1 tys1))
 576                         `eqIfTc_fam` (Just (IfaceFamInst fam2 tys2)) =
 577       fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
 578     _                   `eqIfTc_fam` _                               = NotEqual
 579
 580 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 581   = bool (ifName d1 == ifName d2) &&&
 582     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 583           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 584         )
 585
 586 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 587   = bool (ifName d1 == ifName d2 &&
 588           ifRec d1  == ifRec  d2) &&&
 589     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 590           eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
 591           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 592           eqListBy eqIfDecl         (ifATs d1)  (ifATs d2) &&&
 593           eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
 594        )
 595
 596 eqIfDecl _ _ = NotEqual -- default case
 597
 598 -- Helper
 599 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
 600 eqWith = eq_ifTvBndrs emptyEqEnv
 601
 602 -----------------------
 603 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
 604 -- All other changes are handled via the version info on the dfun
 605
 606 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
 607          (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
 608        = bool (n1==n2 && a1==a2 && o1 == o2) &&&
 609          f1 `eqIfExt` f2 &&&
 610          eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
 611          zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
 612                 -- zapEq: for the LHSs, ignore the EqBut part
 613          eq_ifaceExpr env rhs1 rhs2)
 614
 615 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
 616   = eqListBy (eq_ConDecl env) c1 c2
 617
 618 eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
 619 eq_hsCD env IfAbstractTyCon  IfAbstractTyCon  = Equal
 620 eq_hsCD env IfOpenDataTyCon  IfOpenDataTyCon  = Equal
 621 eq_hsCD env IfOpenNewTyCon   IfOpenNewTyCon   = Equal
 622 eq_hsCD env d1               d2               = NotEqual
 623
 624 eq_ConDecl env c1 c2
 625   = bool (ifConOcc c1     == ifConOcc c2 &&
 626           ifConInfix c1   == ifConInfix c2 &&
 627           ifConStricts c1 == ifConStricts c2 &&
 628           ifConFields c1  == ifConFields c2) &&&
 629     eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
 630     eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
 631         eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
 632         eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
 633
 634 eq_hsFD env (ns1,ms1) (ns2,ms2)
 635   = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
 636
 637 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
 638   = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
 639 \end{code}
 640
 641
 642 \begin{code}
 643 -----------------
 644 eqIfIdInfo NoInfo        NoInfo        = Equal
 645 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
 646 eqIfIdInfo i1            i2 = NotEqual
 647
 648 eq_item (HsInline a1)      (HsInline a2)      = bool (a1 == a2)
 649 eq_item (HsArity a1)       (HsArity a2)       = bool (a1 == a2)
 650 eq_item (HsStrictness s1)  (HsStrictness s2)  = bool (s1 == s2)
 651 eq_item (HsUnfold u1)   (HsUnfold u2)         = eq_ifaceExpr emptyEqEnv u1 u2
 652 eq_item HsNoCafRefs        HsNoCafRefs        = Equal
 653 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
 654 eq_item _ _ = NotEqual
 655
 656 -----------------
 657 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
 658 eq_ifaceExpr env (IfaceLcl v1)        (IfaceLcl v2)        = eqIfOcc env v1 v2
 659 eq_ifaceExpr env (IfaceExt v1)        (IfaceExt v2)        = eqIfExt v1 v2
 660 eq_ifaceExpr env (IfaceLit l1)        (IfaceLit l2)        = bool (l1 == l2)
 661 eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
 662 eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)      = eq_ifType env ty1 ty2
 663 eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
 664 eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
 665 eq_ifaceExpr env (IfaceApp f1 a1)     (IfaceApp f2 a2)     = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
 666 eq_ifaceExpr env (IfaceCast e1 co1)   (IfaceCast e2 co2)   = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
 667 eq_ifaceExpr env (IfaceNote n1 r1)    (IfaceNote n2 r2)    = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
 668
 669 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
 670   = eq_ifaceExpr env s1 s2 &&&
 671     eq_ifType env ty1 ty2 &&&
 672     eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
 673   where
 674     eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
 675         = bool (eq_ifaceConAlt c1 c2) &&&
 676           eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
 677
 678 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
 679   = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
 680
 681 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
 682   = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
 683   where
 684     (bs1,rs1) = unzip as1
 685     (bs2,rs2) = unzip as2
 686
 687
 688 eq_ifaceExpr env _ _ = NotEqual
 689
 690 -----------------
 691 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
 692 eq_ifaceConAlt IfaceDefault       IfaceDefault          = True
 693 eq_ifaceConAlt (IfaceDataAlt n1)  (IfaceDataAlt n2)     = n1==n2
 694 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2)    = c1==c2
 695 eq_ifaceConAlt (IfaceLitAlt l1)   (IfaceLitAlt l2)      = l1==l2
 696 eq_ifaceConAlt _ _ = False
 697
 698 -----------------
 699 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
 700 eq_ifaceNote env (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
 701 eq_ifaceNote env IfaceInlineMe    IfaceInlineMe        = Equal
 702 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
 703 eq_ifaceNote env _ _ = NotEqual
 704 \end{code}
 705
 706 \begin{code}
 707 ---------------------
 708 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
 709
 710 -------------------
 711 eq_ifType env (IfaceTyVar n1)         (IfaceTyVar n2)         = eqIfOcc env n1 n2
 712 eq_ifType env (IfaceAppTy s1 t1)      (IfaceAppTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 713 eq_ifType env (IfacePredTy st1)       (IfacePredTy st2)       = eq_ifPredType env st1 st2
 714 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
 715 eq_ifType env (IfaceForAllTy tv1 t1)  (IfaceForAllTy tv2 t2)  = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
 716 eq_ifType env (IfaceFunTy s1 t1)      (IfaceFunTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 717 eq_ifType env _ _ = NotEqual
 718
 719 -------------------
 720 eq_ifTypes env = eqListBy (eq_ifType env)
 721
 722 -------------------
 723 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
 724
 725 -------------------
 726 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&&  eq_ifTypes env tys1 tys2
 727 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2)   = bool (n1 == n2) &&& eq_ifType env ty1 ty2
 728 eq_ifPredType env _ _ = NotEqual
 729
 730 -------------------
 731 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
 732 eqIfTc IfaceIntTc    IfaceIntTc    = Equal
 733 eqIfTc IfaceCharTc   IfaceCharTc   = Equal
 734 eqIfTc IfaceBoolTc   IfaceBoolTc   = Equal
 735 eqIfTc IfaceListTc   IfaceListTc   = Equal
 736 eqIfTc IfacePArrTc   IfacePArrTc   = Equal
 737 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
 738 eqIfTc IfaceLiftedTypeKindTc   IfaceLiftedTypeKindTc   = Equal
 739 eqIfTc IfaceOpenTypeKindTc     IfaceOpenTypeKindTc     = Equal
 740 eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
 741 eqIfTc IfaceUbxTupleKindTc     IfaceUbxTupleKindTc     = Equal
 742 eqIfTc IfaceArgTypeKindTc      IfaceArgTypeKindTc      = Equal
 743 eqIfTc _                       _                       = NotEqual
 744 \end{code}
 745
 746 -----------------------------------------------------------
 747         Support code for equality checking
 748 -----------------------------------------------------------
 749
 750 \begin{code}
 751 ------------------------------------
 752 type EqEnv = UniqFM FastString  -- Tracks the mapping from L-variables to R-variables
 753
 754 eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
 755 eqIfOcc env n1 n2 = case lookupUFM env n1 of
 756                         Just n1 -> bool (n1 == n2)
 757                         Nothing -> bool (n1 == n2)
 758
 759 extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
 760 extendEqEnv env n1 n2 | n1 == n2  = env
 761                       | otherwise = addToUFM env n1 n2
 762
 763 emptyEqEnv :: EqEnv
 764 emptyEqEnv = emptyUFM
 765
 766 ------------------------------------
 767 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
 768
 769 eq_ifNakedBndr :: ExtEnv FastString
 770 eq_ifBndr      :: ExtEnv IfaceBndr
 771 eq_ifTvBndr    :: ExtEnv IfaceTvBndr
 772 eq_ifIdBndr    :: ExtEnv IfaceIdBndr
 773
 774 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
 775
 776 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
 777 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
 778 eq_ifBndr _ _ _ _ = NotEqual
 779
 780 eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
 781 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
 782
 783 eq_ifBndrs      :: ExtEnv [IfaceBndr]
 784 eq_ifIdBndrs    :: ExtEnv [IfaceIdBndr]
 785 eq_ifTvBndrs    :: ExtEnv [IfaceTvBndr]
 786 eq_ifNakedBndrs :: ExtEnv [FastString]
 787 eq_ifBndrs      = eq_bndrs_with eq_ifBndr
 788 eq_ifIdBndrs    = eq_bndrs_with eq_ifIdBndr
 789 eq_ifTvBndrs    = eq_bndrs_with eq_ifTvBndr
 790 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
 791
 792 eq_bndrs_with eq env []       []       k = k env
 793 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
 794 eq_bndrs_with eq env _        _        _ = NotEqual
 795 \end{code}
 796
 797 \begin{code}
 798 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
 799 eqListBy eq []     []     = Equal
 800 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
 801 eqListBy eq xs     ys     = NotEqual
 802
 803 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
 804 eqMaybeBy eq Nothing Nothing   = Equal
 805 eqMaybeBy eq (Just x) (Just y) = eq x y
 806 eqMaybeBy eq x        y        = NotEqual
 807 \end{code}