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