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