ghc/compiler/iface/IfaceSyn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
  11 @TyVars@ as well.  Currently trying the former... MEGA SIGH.
  12
  13 \begin{code}
  14 module IfaceSyn (
  15         module IfaceType,               -- Re-export all this
  16
  17         IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
  18         IfaceExpr(..), IfaceAlt, IfaceNote(..),
  19         IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
  20         IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
  21
  22         -- Misc
  23         visibleIfConDecls,
  24
  25         -- Converting things to IfaceSyn
  26         tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule,
  27
  28         -- Equality
  29         IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
  30         eqIfDecl, eqIfInst, eqIfRule,
  31
  32         -- Pretty printing
  33         pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
  34     ) where
  35
  36 #include "HsVersions.h"
  37
  38 import CoreSyn
  39 import IfaceType
  40
  41 import FunDeps          ( pprFundeps )
  42 import NewDemand        ( StrictSig, pprIfaceStrictSig )
  43 import TcType           ( deNoteType )
  44 import Type             ( TyThing(..), splitForAllTys, funResultTy )
  45 import InstEnv          ( Instance(..), OverlapFlag )
  46 import Id               ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe )
  47 import NewDemand        ( isTopSig )
  48 import IdInfo           ( IdInfo, CafInfo(..), WorkerInfo(..),
  49                           arityInfo, cafInfo, newStrictnessInfo,
  50                           workerInfo, unfoldingInfo, inlinePragInfo )
  51 import TyCon            ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
  52                           isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
  53                           isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
  54                           tyConHasGenerics, tyConArgVrcs, getSynTyConDefn,
  55                           tyConArity, tyConTyVars, algTyConRhs, tyConExtName  )
  56 import DataCon          ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
  57                           dataConTyCon, dataConIsInfix, isVanillaDataCon )
  58 import Class            ( FunDep, DefMeth, classExtraBigSig, classTyCon )
  59 import OccName          ( OccName, OccEnv, emptyOccEnv,
  60                           lookupOccEnv, extendOccEnv, parenSymOcc,
  61                           OccSet, unionOccSets, unitOccSet )
  62 import Name             ( Name, NamedThing(..), nameOccName, isExternalName,
  63                           wiredInNameTyThing_maybe )
  64 import NameSet          ( NameSet, elemNameSet )
  65 import CostCentre       ( CostCentre, pprCostCentreCore )
  66 import Literal          ( Literal )
  67 import ForeignCall      ( ForeignCall )
  68 import TysPrim          ( alphaTyVars )
  69 import BasicTypes       ( Arity, Activation(..), StrictnessMark,
  70                           RecFlag(..), boolToRecFlag, Boxity(..),
  71                           tupleParens )
  72 import Outputable
  73 import FastString
  74 import Maybes           ( catMaybes )
  75 import Util             ( lengthIs )
  76
  77 infixl 3 &&&
  78 infix  4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
  79 \end{code}
  80
  81
  82 %************************************************************************
  83 %*                                                                      *
  84                 Data type declarations
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \begin{code}
  89 data IfaceDecl
  90   = IfaceId { ifName   :: OccName,
  91               ifType   :: IfaceType,
  92               ifIdInfo :: IfaceIdInfo }
  93
  94   | IfaceData { ifName     :: OccName,          -- Type constructor
  95                 ifTyVars   :: [IfaceTvBndr],    -- Type variables
  96                 ifCtxt     :: IfaceContext,     -- The "stupid theta"
  97                 ifCons     :: IfaceConDecls,    -- Includes new/data info
  98                 ifRec      :: RecFlag,          -- Recursive or not?
  99                 ifVrcs     :: ArgVrcs,
 100                 ifGeneric  :: Bool              -- True <=> generic converter functions available
 101     }                                           -- We need this for imported data decls, since the
 102                                                 -- imported modules may have been compiled with
 103                                                 -- different flags to the current compilation unit
 104
 105   | IfaceSyn  { ifName   :: OccName,            -- Type constructor
 106                 ifTyVars :: [IfaceTvBndr],      -- Type variables
 107                 ifVrcs   :: ArgVrcs,
 108                 ifSynRhs :: IfaceType           -- synonym expansion
 109     }
 110
 111   | IfaceClass { ifCtxt    :: IfaceContext,     -- Context...
 112                  ifName    :: OccName,          -- Name of the class
 113                  ifTyVars  :: [IfaceTvBndr],    -- Type variables
 114                  ifFDs     :: [FunDep OccName], -- Functional dependencies
 115                  ifSigs    :: [IfaceClassOp],   -- Method signatures
 116                  ifRec     :: RecFlag,          -- Is newtype/datatype associated with the class recursive?
 117                  ifVrcs    :: ArgVrcs           -- ... and what are its argument variances ...
 118     }
 119
 120   | IfaceForeign { ifName :: OccName,           -- Needs expanding when we move beyond .NET
 121                    ifExtName :: Maybe FastString }
 122
 123 data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
 124         -- Nothing    => no default method
 125         -- Just False => ordinary polymorphic default method
 126         -- Just True  => generic default method
 127
 128 data IfaceConDecls
 129   = IfAbstractTyCon             -- No info
 130   | IfDataTyCon [IfaceConDecl]  -- data type decls
 131   | IfNewTyCon  IfaceConDecl    -- newtype decls
 132
 133 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 134 visibleIfConDecls IfAbstractTyCon  = []
 135 visibleIfConDecls (IfDataTyCon cs) = cs
 136 visibleIfConDecls (IfNewTyCon c)   = [c]
 137
 138 data IfaceConDecl
 139   = IfVanillaCon {
 140         ifConOcc     :: OccName,                -- Constructor name
 141         ifConInfix   :: Bool,                   -- True <=> declared infix
 142         ifConArgTys  :: [IfaceType],            -- Arg types
 143         ifConStricts :: [StrictnessMark],       -- Empty (meaning all lazy), or 1-1 corresp with arg types
 144         ifConFields  :: [OccName] }             -- ...ditto... (field labels)
 145   | IfGadtCon {
 146         ifConOcc     :: OccName,                -- Constructor name
 147         ifConTyVars  :: [IfaceTvBndr],          -- All tyvars
 148         ifConCtxt    :: IfaceContext,           -- Non-stupid context
 149         ifConArgTys  :: [IfaceType],            -- Arg types
 150         ifConResTys  :: [IfaceType],            -- Result type args
 151         ifConStricts :: [StrictnessMark] }      -- Empty (meaning all lazy), or 1-1 corresp with arg types
 152
 153 data IfaceInst
 154   = IfaceInst { ifInstCls  :: IfaceExtName,             -- See comments with
 155                 ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of Instance
 156                 ifDFun     :: OccName,                  -- The dfun
 157                 ifOFlag    :: OverlapFlag,              -- Overlap flag
 158                 ifInstOrph :: Maybe OccName }           -- See is_orph in defn of Instance
 159         -- There's always a separate IfaceDecl for the DFun, which gives
 160         -- its IdInfo with its full type and version number.
 161         -- The instance declarations taken together have a version number,
 162         -- and we don't want that to wobble gratuitously
 163         -- If this instance decl is *used*, we'll record a usage on the dfun;
 164         -- and if the head does not change it won't be used if it wasn't before
 165
 166 data IfaceRule
 167   = IfaceRule {
 168         ifRuleName   :: RuleName,
 169         ifActivation :: Activation,
 170         ifRuleBndrs  :: [IfaceBndr],    -- Tyvars and term vars
 171         ifRuleHead   :: IfaceExtName,   -- Head of lhs
 172         ifRuleArgs   :: [IfaceExpr],    -- Args of LHS
 173         ifRuleRhs    :: IfaceExpr,
 174         ifRuleOrph   :: Maybe OccName   -- Just like IfaceInst
 175     }
 176
 177 data IfaceIdInfo
 178   = NoInfo                      -- When writing interface file without -O
 179   | HasInfo [IfaceInfoItem]     -- Has info, and here it is
 180
 181 -- Here's a tricky case:
 182 --   * Compile with -O module A, and B which imports A.f
 183 --   * Change function f in A, and recompile without -O
 184 --   * When we read in old A.hi we read in its IdInfo (as a thunk)
 185 --      (In earlier GHCs we used to drop IdInfo immediately on reading,
 186 --       but we do not do that now.  Instead it's discarded when the
 187 --       ModIface is read into the various decl pools.)
 188 --   * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
 189 --      and so gives a new version.
 190
 191 data IfaceInfoItem
 192   = HsArity      Arity
 193   | HsStrictness StrictSig
 194   | HsUnfold     Activation IfaceExpr
 195   | HsNoCafRefs
 196   | HsWorker     IfaceExtName Arity     -- Worker, if any see IdInfo.WorkerInfo
 197                                         -- for why we want arity here.
 198         -- NB: we need IfaceExtName (not just OccName) because the worker
 199         --     can simplify to a function in another module.
 200 -- NB: Specialisations and rules come in separately and are
 201 -- only later attached to the Id.  Partial reason: some are orphans.
 202
 203 --------------------------------
 204 data IfaceExpr
 205   = IfaceLcl    OccName
 206   | IfaceExt    IfaceExtName
 207   | IfaceType   IfaceType
 208   | IfaceTuple  Boxity [IfaceExpr]              -- Saturated; type arguments omitted
 209   | IfaceLam    IfaceBndr IfaceExpr
 210   | IfaceApp    IfaceExpr IfaceExpr
 211   | IfaceCase   IfaceExpr OccName IfaceType [IfaceAlt]
 212   | IfaceLet    IfaceBinding  IfaceExpr
 213   | IfaceNote   IfaceNote IfaceExpr
 214   | IfaceLit    Literal
 215   | IfaceFCall  ForeignCall IfaceType
 216
 217 data IfaceNote = IfaceSCC CostCentre
 218                | IfaceCoerce IfaceType
 219                | IfaceInlineCall
 220                | IfaceInlineMe
 221                | IfaceCoreNote String
 222
 223 type IfaceAlt = (IfaceConAlt, [OccName], IfaceExpr)
 224         -- Note: OccName, not IfaceBndr (and same with the case binder)
 225         -- We reconstruct the kind/type of the thing from the context
 226         -- thus saving bulk in interface files
 227
 228 data IfaceConAlt = IfaceDefault
 229                  | IfaceDataAlt OccName
 230                  | IfaceTupleAlt Boxity
 231                  | IfaceLitAlt Literal
 232
 233 data IfaceBinding
 234   = IfaceNonRec IfaceIdBndr IfaceExpr
 235   | IfaceRec    [(IfaceIdBndr, IfaceExpr)]
 236 \end{code}
 237
 238
 239 %************************************************************************
 240 %*                                                                      *
 241 \subsection[HsCore-print]{Printing Core unfoldings}
 242 %*                                                                      *
 243 %************************************************************************
 244
 245 ----------------------------- Printing IfaceDecl ------------------------------------
 246
 247 \begin{code}
 248 instance Outputable IfaceDecl where
 249   ppr = pprIfaceDecl
 250
 251 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
 252   = sep [ ppr var <+> dcolon <+> ppr ty,
 253           nest 2 (ppr info) ]
 254
 255 pprIfaceDecl (IfaceForeign {ifName = tycon})
 256   = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
 257
 258 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs})
 259   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
 260        4 (vcat [equals <+> ppr mono_ty,
 261                 pprVrcs vrcs])
 262
 263 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
 264                          ifTyVars = tyvars, ifCons = condecls,
 265                          ifRec = isrec, ifVrcs = vrcs})
 266   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
 267        4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls])
 268   where
 269     pp_nd = case condecls of
 270                 IfAbstractTyCon -> ptext SLIT("data")
 271                 IfDataTyCon _   -> ptext SLIT("data")
 272                 IfNewTyCon _    -> ptext SLIT("newtype")
 273
 274 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 275                           ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
 276   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
 277        4 (vcat [pprVrcs vrcs,
 278                 pprRec isrec,
 279                 sep (map ppr sigs)])
 280
 281 pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs
 282 pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
 283 pprGen True  = ptext SLIT("Generics: yes")
 284 pprGen False = ptext SLIT("Generics: no")
 285
 286 instance Outputable IfaceClassOp where
 287    ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
 288
 289 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
 290 pprIfaceDeclHead context thing tyvars
 291   = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
 292
 293 pp_condecls tc IfAbstractTyCon  = ptext SLIT("{- abstract -}")
 294 pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
 295 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
 296                                                      (map (pprIfaceConDecl tc) cs))
 297
 298 pprIfaceConDecl tc (IfVanillaCon {
 299                       ifConOcc = name, ifConInfix = is_infix,
 300                       ifConArgTys = arg_tys,
 301                       ifConStricts = strs, ifConFields = fields })
 302     = sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
 303            if is_infix then ptext SLIT("Infix") else empty,
 304            if null strs then empty
 305               else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
 306            if null fields then empty
 307               else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
 308
 309 pprIfaceConDecl tc (IfGadtCon {
 310                       ifConOcc = name,
 311                       ifConTyVars = tvs, ifConCtxt = ctxt,
 312                       ifConArgTys = arg_tys, ifConResTys = res_tys,
 313                       ifConStricts = strs })
 314     = sep [ppr name <+> dcolon <+> pprIfaceForAllPart tvs ctxt (ppr con_tau),
 315            if null strs then empty
 316               else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs))]
 317     where
 318       con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app])
 319       tc_app  = IfaceTyConApp (IfaceTc (LocalTop tc)) res_tys
 320         -- Gruesome, but jsut for debug print
 321
 322 instance Outputable IfaceRule where
 323   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
 324                    ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
 325     = sep [hsep [doubleQuotes (ftext name), ppr act,
 326                  ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
 327            nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
 328                         ptext SLIT("=") <+> ppr rhs])
 329       ]
 330
 331 instance Outputable IfaceInst where
 332   ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
 333                   ifInstCls = cls, ifInstTys = mb_tcs})
 334     = hang (ptext SLIT("instance") <+> ppr flag
 335                 <+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs))
 336          2 (equals <+> ppr dfun_id)
 337     where
 338       ppr_mb Nothing   = dot
 339       ppr_mb (Just tc) = ppr tc
 340 \end{code}
 341
 342
 343 ----------------------------- Printing IfaceExpr ------------------------------------
 344
 345 \begin{code}
 346 instance Outputable IfaceExpr where
 347     ppr e = pprIfaceExpr noParens e
 348
 349 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
 350         -- The function adds parens in context that need
 351         -- an atomic value (e.g. function args)
 352
 353 pprIfaceExpr add_par (IfaceLcl v)       = ppr v
 354 pprIfaceExpr add_par (IfaceExt v)       = ppr v
 355 pprIfaceExpr add_par (IfaceLit l)       = ppr l
 356 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 357 pprIfaceExpr add_par (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
 358
 359 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 360 pprIfaceExpr add_par (IfaceTuple c as)  = tupleParens c (interpp'SP as)
 361
 362 pprIfaceExpr add_par e@(IfaceLam _ _)
 363   = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
 364                   pprIfaceExpr noParens body])
 365   where
 366     (bndrs,body) = collect [] e
 367     collect bs (IfaceLam b e) = collect (b:bs) e
 368     collect bs e              = (reverse bs, e)
 369
 370 -- gaw 2004
 371 pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
 372 -- gaw 2004
 373   = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
 374                         <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
 375                   pprIfaceExpr noParens rhs <+> char '}'])
 376
 377 -- gaw 2004
 378 pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
 379 -- gaw 2004
 380   = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
 381                         <+> ppr bndr <+> char '{',
 382                   nest 2 (sep (map ppr_alt alts)) <+> char '}'])
 383
 384 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
 385   = add_par (sep [ptext SLIT("let {"),
 386                   nest 2 (ppr_bind (b, rhs)),
 387                   ptext SLIT("} in"),
 388                   pprIfaceExpr noParens body])
 389
 390 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
 391   = add_par (sep [ptext SLIT("letrec {"),
 392                   nest 2 (sep (map ppr_bind pairs)),
 393                   ptext SLIT("} in"),
 394                   pprIfaceExpr noParens body])
 395
 396 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
 397
 398 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
 399                               arrow <+> pprIfaceExpr noParens rhs]
 400
 401 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
 402 ppr_con_bs con bs                     = ppr con <+> hsep (map ppr bs)
 403
 404 ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
 405                              equals <+> pprIfaceExpr noParens rhs]
 406
 407 ------------------
 408 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
 409 pprIfaceApp fun                args = sep (pprIfaceExpr parens fun : args)
 410
 411 ------------------
 412 instance Outputable IfaceNote where
 413     ppr (IfaceSCC cc)     = pprCostCentreCore cc
 414     ppr (IfaceCoerce ty)  = ptext SLIT("__coerce") <+> pprParendIfaceType ty
 415     ppr IfaceInlineCall   = ptext SLIT("__inline_call")
 416     ppr IfaceInlineMe     = ptext SLIT("__inline_me")
 417     ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
 418
 419 instance Outputable IfaceConAlt where
 420     ppr IfaceDefault      = text "DEFAULT"
 421     ppr (IfaceLitAlt l)   = ppr l
 422     ppr (IfaceDataAlt d)  = ppr d
 423     ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
 424         -- IfaceTupleAlt is handled by the case-alternative printer
 425
 426 ------------------
 427 instance Outputable IfaceIdInfo where
 428    ppr NoInfo       = empty
 429    ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
 430
 431 ppr_hs_info (HsUnfold prag unf) = sep [ptext SLIT("Unfolding: ") <> ppr prag,
 432                                        parens (pprIfaceExpr noParens unf)]
 433 ppr_hs_info (HsArity arity)     = ptext SLIT("Arity:") <+> int arity
 434 ppr_hs_info (HsStrictness str)  = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
 435 ppr_hs_info HsNoCafRefs         = ptext SLIT("HasNoCafRefs")
 436 ppr_hs_info (HsWorker w a)      = ptext SLIT("Worker:") <+> ppr w <+> int a
 437 \end{code}
 438
 439
 440 %************************************************************************
 441 %*                                                                      *
 442         Converting things to their Iface equivalents
 443 %*                                                                      *
 444 %************************************************************************
 445
 446
 447 \begin{code}
 448 tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
 449 -- Assumption: the thing is already tidied, so that locally-bound names
 450 --             (lambdas, for-alls) already have non-clashing OccNames
 451 -- Reason: Iface stuff uses OccNames, and the conversion here does
 452 --         not do tidying on the way
 453 tyThingToIfaceDecl ext (AnId id)
 454   = IfaceId { ifName   = getOccName id,
 455               ifType   = toIfaceType ext (idType id),
 456               ifIdInfo = info }
 457   where
 458     info = case toIfaceIdInfo ext (idInfo id) of
 459                 []    -> NoInfo
 460                 items -> HasInfo items
 461
 462 tyThingToIfaceDecl ext (AClass clas)
 463   = IfaceClass { ifCtxt   = toIfaceContext ext sc_theta,
 464                  ifName   = getOccName clas,
 465                  ifTyVars = toIfaceTvBndrs clas_tyvars,
 466                  ifFDs    = map toIfaceFD clas_fds,
 467                  ifSigs   = map toIfaceClassOp op_stuff,
 468                  ifRec    = boolToRecFlag (isRecursiveTyCon tycon),
 469                  ifVrcs   = tyConArgVrcs tycon }
 470   where
 471     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
 472     tycon = classTyCon clas
 473
 474     toIfaceClassOp (sel_id, def_meth)
 475         = ASSERT(sel_tyvars == clas_tyvars)
 476           IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty)
 477         where
 478                 -- Be careful when splitting the type, because of things
 479                 -- like         class Foo a where
 480                 --                op :: (?x :: String) => a -> a
 481                 -- and          class Baz a where
 482                 --                op :: (Ord a) => a -> a
 483           (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
 484           op_ty                = funResultTy rho_ty
 485
 486     toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
 487
 488 tyThingToIfaceDecl ext (ATyCon tycon)
 489   | isSynTyCon tycon
 490   = IfaceSyn {  ifName   = getOccName tycon,
 491                 ifTyVars = toIfaceTvBndrs tyvars,
 492                 ifVrcs    = tyConArgVrcs tycon,
 493                 ifSynRhs = toIfaceType ext syn_ty }
 494
 495   | isAlgTyCon tycon
 496   = IfaceData { ifName    = getOccName tycon,
 497                 ifTyVars  = toIfaceTvBndrs tyvars,
 498                 ifCtxt    = toIfaceContext ext (tyConStupidTheta tycon),
 499                 ifCons    = ifaceConDecls (algTyConRhs tycon),
 500                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
 501                 ifVrcs    = tyConArgVrcs tycon,
 502                 ifGeneric = tyConHasGenerics tycon }
 503
 504   | isForeignTyCon tycon
 505   = IfaceForeign { ifName    = getOccName tycon,
 506                    ifExtName = tyConExtName tycon }
 507
 508   | isPrimTyCon tycon || isFunTyCon tycon
 509         -- Needed in GHCi for ':info Int#', for example
 510   = IfaceData { ifName    = getOccName tycon,
 511                 ifTyVars  = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
 512                 ifCtxt    = [],
 513                 ifCons    = IfAbstractTyCon,
 514                 ifGeneric = False,
 515                 ifRec     = NonRecursive,
 516                 ifVrcs    = tyConArgVrcs tycon }
 517
 518   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
 519   where
 520     tyvars      = tyConTyVars tycon
 521     (_, syn_ty) = getSynTyConDefn tycon
 522
 523     ifaceConDecls (NewTyCon con _ _) = IfNewTyCon  (ifaceConDecl con)
 524     ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons)
 525     ifaceConDecls AbstractTyCon      = IfAbstractTyCon
 526         -- The last case happens when a TyCon has been trimmed during tidying
 527         -- Furthermore, tyThingToIfaceDecl is also used
 528         -- in TcRnDriver for GHCi, when browsing a module, in which case the
 529         -- AbstractTyCon case is perfectly sensible.
 530
 531     ifaceConDecl data_con
 532         | isVanillaDataCon data_con
 533         = IfVanillaCon {ifConOcc = getOccName (dataConName data_con),
 534                         ifConInfix = dataConIsInfix data_con,
 535                         ifConArgTys = map (toIfaceType ext) arg_tys,
 536                         ifConStricts = strict_marks,
 537                         ifConFields = map getOccName field_labels }
 538         | otherwise
 539         = IfGadtCon   { ifConOcc = getOccName (dataConName data_con),
 540                         ifConTyVars = toIfaceTvBndrs tyvars,
 541                         ifConCtxt = toIfaceContext ext theta,
 542                         ifConArgTys = map (toIfaceType ext) arg_tys,
 543                         ifConResTys = map (toIfaceType ext) res_tys,
 544                         ifConStricts = strict_marks }
 545         where
 546           (tyvars, theta, arg_tys, _, res_tys) = dataConSig data_con
 547           field_labels = dataConFieldLabels data_con
 548           strict_marks = dataConStrictMarks data_con
 549
 550 tyThingToIfaceDecl ext (ADataCon dc)
 551  = pprPanic "toIfaceDecl" (ppr dc)      -- Should be trimmed out earlier
 552
 553
 554 --------------------------
 555 instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst
 556 instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag,
 557                                               is_cls = cls, is_tcs = mb_tcs,
 558                                               is_orph = orph })
 559   = IfaceInst { ifDFun    = getOccName dfun_id,
 560                 ifOFlag   = oflag,
 561                 ifInstCls = ext_lhs cls,
 562                 ifInstTys = map do_rough mb_tcs,
 563                 ifInstOrph = orph }
 564   where
 565     do_rough Nothing = Nothing
 566     do_rough (Just n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n
 567                       = Just (toIfaceTyCon ext_lhs tc)
 568                       | otherwise
 569                       = Just (IfaceTc (ext_lhs n))
 570
 571 --------------------------
 572 toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem]
 573 toIfaceIdInfo ext id_info
 574   = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
 575                wrkr_hsinfo,  unfold_hsinfo]
 576   where
 577     ------------  Arity  --------------
 578     arity_info = arityInfo id_info
 579     arity_hsinfo | arity_info == 0 = Nothing
 580                  | otherwise       = Just (HsArity arity_info)
 581
 582     ------------ Caf Info --------------
 583     caf_info   = cafInfo id_info
 584     caf_hsinfo = case caf_info of
 585                    NoCafRefs -> Just HsNoCafRefs
 586                    _other    -> Nothing
 587
 588     ------------  Strictness  --------------
 589         -- No point in explicitly exporting TopSig
 590     strict_hsinfo = case newStrictnessInfo id_info of
 591                         Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
 592                         _other                        -> Nothing
 593
 594     ------------  Worker  --------------
 595     work_info   = workerInfo id_info
 596     has_worker  = case work_info of { HasWorker _ _ -> True; other -> False }
 597     wrkr_hsinfo = case work_info of
 598                     HasWorker work_id wrap_arity ->
 599                         Just (HsWorker (ext (idName work_id)) wrap_arity)
 600                     NoWorker -> Nothing
 601
 602     ------------  Unfolding  --------------
 603     -- The unfolding is redundant if there is a worker
 604     unfold_info = unfoldingInfo id_info
 605     inline_prag = inlinePragInfo id_info
 606     rhs         = unfoldingTemplate unfold_info
 607     unfold_hsinfo |  neverUnfold unfold_info
 608                   || has_worker = Nothing
 609                   | otherwise   = Just (HsUnfold inline_prag (toIfaceExpr ext rhs))
 610
 611 --------------------------
 612 coreRuleToIfaceRule :: (Name -> IfaceExtName)   -- For the LHS names
 613                     -> (Name -> IfaceExtName)   -- For the RHS names
 614                     -> CoreRule -> IfaceRule
 615 coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn})
 616   = pprTrace "toHsRule: builtin" (ppr fn) $
 617     bogusIfaceRule (mkIfaceExtName fn)
 618
 619 coreRuleToIfaceRule ext_lhs ext_rhs
 620     (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs,
 621             ru_args = args, ru_rhs = rhs, ru_orph = orph })
 622   = IfaceRule { ifRuleName  = name, ifActivation = act,
 623                 ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs,
 624                 ifRuleHead  = ext_lhs fn,
 625                 ifRuleArgs  = map do_arg args,
 626                 ifRuleRhs   = toIfaceExpr ext_rhs rhs,
 627                 ifRuleOrph  = orph }
 628   where
 629         -- For type args we must remove synonyms from the outermost
 630         -- level.  Reason: so that when we read it back in we'll
 631         -- construct the same ru_rough field as we have right now;
 632         -- see tcIfaceRule
 633     do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty))
 634     do_arg arg       = toIfaceExpr ext_lhs arg
 635
 636 bogusIfaceRule :: IfaceExtName -> IfaceRule
 637 bogusIfaceRule id_name
 638   = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive,
 639         ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
 640         ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
 641
 642 ---------------------
 643 toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr
 644 toIfaceExpr ext (Var v)       = toIfaceVar ext v
 645 toIfaceExpr ext (Lit l)       = IfaceLit l
 646 toIfaceExpr ext (Type ty)     = IfaceType (toIfaceType ext ty)
 647 toIfaceExpr ext (Lam x b)     = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
 648 toIfaceExpr ext (App f a)     = toIfaceApp ext f [a]
 649 -- gaw 2004
 650 toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as)
 651 toIfaceExpr ext (Let b e)     = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
 652 toIfaceExpr ext (Note n e)    = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
 653
 654 ---------------------
 655 toIfaceNote ext (SCC cc)      = IfaceSCC cc
 656 toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1)
 657 toIfaceNote ext InlineCall    = IfaceInlineCall
 658 toIfaceNote ext InlineMe      = IfaceInlineMe
 659 toIfaceNote ext (CoreNote s)  = IfaceCoreNote s
 660
 661 ---------------------
 662 toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r)
 663 toIfaceBind ext (Rec prs)    = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
 664
 665 ---------------------
 666 toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r)
 667
 668 ---------------------
 669 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
 670                         | otherwise       = IfaceDataAlt (getOccName dc)
 671                         where
 672                           tc = dataConTyCon dc
 673
 674 toIfaceCon (LitAlt l) = IfaceLitAlt l
 675 toIfaceCon DEFAULT    = IfaceDefault
 676
 677 ---------------------
 678 toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as)
 679 toIfaceApp ext (Var v) as
 680   = case isDataConWorkId_maybe v of
 681         -- We convert the *worker* for tuples into IfaceTuples
 682         Just dc |  isTupleTyCon tc && saturated
 683                 -> IfaceTuple (tupleTyConBoxity tc) tup_args
 684           where
 685             val_args  = dropWhile isTypeArg as
 686             saturated = val_args `lengthIs` idArity v
 687             tup_args  = map (toIfaceExpr ext) val_args
 688             tc        = dataConTyCon dc
 689
 690         other -> mkIfaceApps ext (toIfaceVar ext v) as
 691
 692 toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as
 693
 694 mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as
 695
 696 ---------------------
 697 toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr
 698 toIfaceVar ext v
 699   | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
 700           -- Foreign calls have special syntax
 701   | isExternalName name             = IfaceExt (ext name)
 702   | otherwise                       = IfaceLcl (nameOccName name)
 703   where
 704     name = idName v
 705 \end{code}
 706
 707
 708 %************************************************************************
 709 %*                                                                      *
 710         Equality, for interface file version generaion only
 711 %*                                                                      *
 712 %************************************************************************
 713
 714 Equality over IfaceSyn returns an IfaceEq, not a Bool.  The new constructor is
 715 EqBut, which gives the set of *locally-defined* things whose version must be equal
 716 for the whole thing to be equal.  So the key function is eqIfExt, which compares
 717 IfaceExtNames.
 718
 719 Of course, equality is also done modulo alpha conversion.
 720
 721 \begin{code}
 722 data IfaceEq
 723   = Equal               -- Definitely exactly the same
 724   | NotEqual            -- Definitely different
 725   | EqBut OccSet        -- The same provided these local things have not changed
 726
 727 bool :: Bool -> IfaceEq
 728 bool True  = Equal
 729 bool False = NotEqual
 730
 731 zapEq :: IfaceEq -> IfaceEq     -- Used to forget EqBut information
 732 zapEq (EqBut _) = Equal
 733 zapEq other     = other
 734
 735 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
 736 Equal       &&& x           = x
 737 NotEqual    &&& x           = NotEqual
 738 EqBut occs  &&& Equal       = EqBut occs
 739 EqBut occs  &&& NotEqual    = NotEqual
 740 EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
 741
 742 ---------------------
 743 eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
 744 -- This function is the core of the EqBut stuff
 745 eqIfExt (ExtPkg mod1 occ1)     (ExtPkg mod2 occ2)     = bool (mod1==mod2 && occ1==occ2)
 746 eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
 747 eqIfExt (LocalTop occ1)       (LocalTop occ2)      | occ1 == occ2 = EqBut (unitOccSet occ1)
 748 eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2)      | occ1 == occ2 = EqBut (unitOccSet p1)
 749 eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
 750 eqIfExt n1 n2 = NotEqual
 751 \end{code}
 752
 753
 754 \begin{code}
 755 ---------------------
 756 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
 757 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
 758   = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
 759
 760 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 761   = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
 762
 763 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
 764   = bool (ifName d1    == ifName d2 &&
 765           ifRec d1     == ifRec   d2 &&
 766           ifVrcs d1    == ifVrcs   d2 &&
 767           ifGeneric d1 == ifGeneric d2) &&&
 768     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 769             eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 770             eq_hsCD env (ifCons d1) (ifCons d2)
 771         )
 772         -- The type variables of the data type do not scope
 773         -- over the constructors (any more), but they do scope
 774         -- over the stupid context in the IfaceConDecls
 775
 776 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 777   = bool (ifName d1 == ifName d2) &&&
 778     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 779           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 780         )
 781
 782 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 783   = bool (ifName d1 == ifName d2 &&
 784           ifRec d1  == ifRec  d2 &&
 785           ifVrcs d1 == ifVrcs d2) &&&
 786     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 787           eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
 788           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 789           eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
 790        )
 791
 792 eqIfDecl _ _ = NotEqual -- default case
 793
 794 -- Helper
 795 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
 796 eqWith = eq_ifTvBndrs emptyEqEnv
 797
 798 -----------------------
 799 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2)
 800 -- All other changes are handled via the version info on the dfun
 801
 802 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
 803          (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
 804        = bool (n1==n2 && a1==a2 && o1 == o2) &&&
 805          f1 `eqIfExt` f2 &&&
 806          eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
 807          zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
 808                 -- zapEq: for the LHSs, ignore the EqBut part
 809          eq_ifaceExpr env rhs1 rhs2)
 810
 811 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
 812   = eqListBy (eq_ConDecl env) c1 c2
 813
 814 eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
 815 eq_hsCD env IfAbstractTyCon  IfAbstractTyCon  = Equal
 816 eq_hsCD env d1               d2               = NotEqual
 817
 818 eq_ConDecl env c1@(IfVanillaCon {}) c2@(IfVanillaCon {})
 819   = bool (ifConOcc c1     == ifConOcc c2 &&
 820           ifConInfix c1   == ifConInfix c2 &&
 821           ifConStricts c1 == ifConStricts c2 &&
 822           ifConFields c1  == ifConFields c2) &&&
 823    eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)
 824
 825 eq_ConDecl env c1@(IfGadtCon {}) c2@(IfGadtCon {})
 826   = bool (ifConOcc c1     == ifConOcc c2 &&
 827           ifConStricts c1 == ifConStricts c2) &&&
 828     eq_ifTvBndrs env (ifConTyVars c1) (ifConTyVars c2) (\ env ->
 829         eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
 830         eq_ifTypes env (ifConResTys c1) (ifConResTys c2) &&&
 831         eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2))
 832
 833 eq_ConDecl env c1 c2 = NotEqual
 834
 835 eq_hsFD env (ns1,ms1) (ns2,ms2)
 836   = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
 837
 838 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
 839   = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
 840 \end{code}
 841
 842
 843 \begin{code}
 844 -----------------
 845 eqIfIdInfo NoInfo        NoInfo        = Equal
 846 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
 847 eqIfIdInfo i1 i2 = NotEqual
 848
 849 eq_item (HsArity a1)       (HsArity a2)       = bool (a1 == a2)
 850 eq_item (HsStrictness s1)  (HsStrictness s2)  = bool (s1 == s2)
 851 eq_item (HsUnfold a1 u1)   (HsUnfold a2 u2)   = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2
 852 eq_item HsNoCafRefs        HsNoCafRefs        = Equal
 853 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
 854 eq_item _ _ = NotEqual
 855
 856 -----------------
 857 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
 858 eq_ifaceExpr env (IfaceLcl v1)        (IfaceLcl v2)        = eqIfOcc env v1 v2
 859 eq_ifaceExpr env (IfaceExt v1)        (IfaceExt v2)        = eqIfExt v1 v2
 860 eq_ifaceExpr env (IfaceLit l1)        (IfaceLit l2)        = bool (l1 == l2)
 861 eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
 862 eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)      = eq_ifType env ty1 ty2
 863 eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
 864 eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
 865 eq_ifaceExpr env (IfaceApp f1 a1)     (IfaceApp f2 a2)     = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
 866 eq_ifaceExpr env (IfaceNote n1 r1)    (IfaceNote n2 r2)    = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
 867
 868 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
 869   = eq_ifaceExpr env s1 s2 &&&
 870     eq_ifType env ty1 ty2 &&&
 871     eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
 872   where
 873     eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
 874         = bool (eq_ifaceConAlt c1 c2) &&&
 875           eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
 876
 877 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
 878   = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
 879
 880 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
 881   = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
 882   where
 883     (bs1,rs1) = unzip as1
 884     (bs2,rs2) = unzip as2
 885
 886
 887 eq_ifaceExpr env _ _ = NotEqual
 888
 889 -----------------
 890 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
 891 eq_ifaceConAlt IfaceDefault       IfaceDefault          = True
 892 eq_ifaceConAlt (IfaceDataAlt n1)  (IfaceDataAlt n2)     = n1==n2
 893 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2)    = c1==c2
 894 eq_ifaceConAlt (IfaceLitAlt l1)   (IfaceLitAlt l2)      = l1==l2
 895 eq_ifaceConAlt _ _ = False
 896
 897 -----------------
 898 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
 899 eq_ifaceNote env (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
 900 eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2)     = eq_ifType env t1 t2
 901 eq_ifaceNote env IfaceInlineCall  IfaceInlineCall      = Equal
 902 eq_ifaceNote env IfaceInlineMe    IfaceInlineMe        = Equal
 903 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
 904 eq_ifaceNote env _ _ = NotEqual
 905 \end{code}
 906
 907 \begin{code}
 908 ---------------------
 909 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
 910
 911 -------------------
 912 eq_ifType env (IfaceTyVar n1)         (IfaceTyVar n2)         = eqIfOcc env n1 n2
 913 eq_ifType env (IfaceAppTy s1 t1)      (IfaceAppTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 914 eq_ifType env (IfacePredTy st1)       (IfacePredTy st2)       = eq_ifPredType env st1 st2
 915 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
 916 eq_ifType env (IfaceForAllTy tv1 t1)  (IfaceForAllTy tv2 t2)  = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
 917 eq_ifType env (IfaceFunTy s1 t1)      (IfaceFunTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 918 eq_ifType env _ _ = NotEqual
 919
 920 -------------------
 921 eq_ifTypes env = eqListBy (eq_ifType env)
 922
 923 -------------------
 924 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
 925
 926 -------------------
 927 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&&  eq_ifTypes env tys1 tys2
 928 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2)   = bool (n1 == n2) &&& eq_ifType env ty1 ty2
 929 eq_ifPredType env _ _ = NotEqual
 930
 931 -------------------
 932 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
 933 eqIfTc IfaceIntTc    IfaceIntTc    = Equal
 934 eqIfTc IfaceCharTc   IfaceCharTc   = Equal
 935 eqIfTc IfaceBoolTc   IfaceBoolTc   = Equal
 936 eqIfTc IfaceListTc   IfaceListTc   = Equal
 937 eqIfTc IfacePArrTc   IfacePArrTc   = Equal
 938 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
 939 eqIfTc _ _ = NotEqual
 940 \end{code}
 941
 942 -----------------------------------------------------------
 943         Support code for equality checking
 944 -----------------------------------------------------------
 945
 946 \begin{code}
 947 ------------------------------------
 948 type EqEnv = OccEnv OccName     -- Tracks the mapping from L-variables to R-variables
 949
 950 eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq
 951 eqIfOcc env n1 n2 = case lookupOccEnv env n1 of
 952                         Just n1 -> bool (n1 == n2)
 953                         Nothing -> bool (n1 == n2)
 954
 955 extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv
 956 extendEqEnv env n1 n2 | n1 == n2  = env
 957                       | otherwise = extendOccEnv env n1 n2
 958
 959 emptyEqEnv :: EqEnv
 960 emptyEqEnv = emptyOccEnv
 961
 962 ------------------------------------
 963 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
 964
 965 eq_ifNakedBndr :: ExtEnv OccName
 966 eq_ifBndr      :: ExtEnv IfaceBndr
 967 eq_ifTvBndr    :: ExtEnv IfaceTvBndr
 968 eq_ifIdBndr    :: ExtEnv IfaceIdBndr
 969
 970 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
 971
 972 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
 973 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
 974 eq_ifBndr _ _ _ _ = NotEqual
 975
 976 eq_ifTvBndr env (v1, k1) (v2, k2) k = bool (k1 == k2)     &&& k (extendEqEnv env v1 v2)
 977 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
 978
 979 eq_ifBndrs      :: ExtEnv [IfaceBndr]
 980 eq_ifIdBndrs    :: ExtEnv [IfaceIdBndr]
 981 eq_ifTvBndrs    :: ExtEnv [IfaceTvBndr]
 982 eq_ifNakedBndrs :: ExtEnv [OccName]
 983 eq_ifBndrs      = eq_bndrs_with eq_ifBndr
 984 eq_ifIdBndrs    = eq_bndrs_with eq_ifIdBndr
 985 eq_ifTvBndrs    = eq_bndrs_with eq_ifTvBndr
 986 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
 987
 988 eq_bndrs_with eq env []       []       k = k env
 989 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
 990 eq_bndrs_with eq env _        _        _ = NotEqual
 991 \end{code}
 992
 993 \begin{code}
 994 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
 995 eqListBy eq []     []     = Equal
 996 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
 997 eqListBy eq xs     ys     = NotEqual
 998
 999 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
1000 eqMaybeBy eq Nothing Nothing   = Equal
1001 eqMaybeBy eq (Just x) (Just y) = eq x y
1002 eqMaybeBy eq x        y        = NotEqual
1003 \end{code}