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, 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") <+> pp_decl_head [] 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 <+> pp_decl_head 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") <+> pp_decl_head 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 pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
 282 pp_decl_head 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         -- This case only happens in the call to ifaceThing in InteractiveUI
 509         -- Otherwise DataCons are filtered out in ifaceThing_acc
 510 tyThingToIfaceDecl _ _ ext (ADataCon dc)
 511  = IfaceId { ifName   = getOccName dc,
 512              ifType   = toIfaceType ext full_ty,
 513              ifIdInfo = NoInfo }
 514  where
 515     (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc
 516
 517         -- The "stupid context" isn't part of the wrapper-Id type
 518         -- (for better or worse -- see note in DataCon.lhs), so we
 519         -- have to make it up here
 520     full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta)
 521                         (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs)))
 522
 523 --------------------------
 524 dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst
 525 dfunToIfaceInst mod dfun_id
 526   = IfaceInst { ifDFun     = getOccName dfun_id,
 527                 ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty }
 528   where
 529     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
 530     head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys))
 531         -- No need to record the instance context;
 532         -- it's in the dfun anyway
 533
 534     tidy_ty = tidyTopType (deNoteType head_ty)
 535                 -- The deNoteType is very important.   It removes all type
 536                 -- synonyms from the instance type in interface files.
 537                 -- That in turn makes sure that when reading in instance decls
 538                 -- from interface files that the 'gating' mechanism works properly.
 539                 -- Otherwise you could have
 540                 --      type Tibble = T Int
 541                 --      instance Foo Tibble where ...
 542                 -- and this instance decl wouldn't get imported into a module
 543                 -- that mentioned T but not Tibble.
 544
 545
 546 --------------------------
 547 toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem]
 548 toIfaceIdInfo ext id_info
 549   = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
 550                wrkr_hsinfo,  unfold_hsinfo]
 551   where
 552     ------------  Arity  --------------
 553     arity_info = arityInfo id_info
 554     arity_hsinfo | arity_info == 0 = Nothing
 555                  | otherwise       = Just (HsArity arity_info)
 556
 557     ------------ Caf Info --------------
 558     caf_info   = cafInfo id_info
 559     caf_hsinfo = case caf_info of
 560                    NoCafRefs -> Just HsNoCafRefs
 561                    _other    -> Nothing
 562
 563     ------------  Strictness  --------------
 564         -- No point in explicitly exporting TopSig
 565     strict_hsinfo = case newStrictnessInfo id_info of
 566                         Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
 567                         _other                        -> Nothing
 568
 569     ------------  Worker  --------------
 570     work_info   = workerInfo id_info
 571     has_worker  = case work_info of { HasWorker _ _ -> True; other -> False }
 572     wrkr_hsinfo = case work_info of
 573                     HasWorker work_id wrap_arity ->
 574                         Just (HsWorker (ext (idName work_id)) wrap_arity)
 575                     NoWorker -> Nothing
 576
 577     ------------  Unfolding  --------------
 578     -- The unfolding is redundant if there is a worker
 579     unfold_info = unfoldingInfo id_info
 580     inline_prag = inlinePragInfo id_info
 581     rhs         = unfoldingTemplate unfold_info
 582     unfold_hsinfo |  neverUnfold unfold_info
 583                   || has_worker = Nothing
 584                   | otherwise   = Just (HsUnfold inline_prag (toIfaceExpr ext rhs))
 585
 586 --------------------------
 587 coreRuleToIfaceRule :: ModuleName -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule
 588 coreRuleToIfaceRule mod ext (id, BuiltinRule _ _)
 589   = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id)))
 590
 591 coreRuleToIfaceRule mod ext (id, Rule name act bndrs args rhs)
 592   = IfaceRule { ifRuleName = name, ifActivation = act,
 593                 ifRuleBndrs = map (toIfaceBndr ext) bndrs,
 594                 ifRuleHead = ext (idName id),
 595                 ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args,
 596                         -- Use LHS name-fn for the args
 597                 ifRuleRhs = toIfaceExpr ext rhs }
 598
 599 bogusIfaceRule :: IfaceExtName -> IfaceRule
 600 bogusIfaceRule id_name
 601   = IfaceRule FSLIT("bogus") NeverActive [] id_name [] (IfaceExt id_name)
 602
 603 ---------------------
 604 toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr
 605 toIfaceExpr ext (Var v)       = toIfaceVar ext v
 606 toIfaceExpr ext (Lit l)       = IfaceLit l
 607 toIfaceExpr ext (Type ty)     = IfaceType (toIfaceType ext ty)
 608 toIfaceExpr ext (Lam x b)     = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
 609 toIfaceExpr ext (App f a)     = toIfaceApp ext f [a]
 610 toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as)
 611 toIfaceExpr ext (Let b e)     = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
 612 toIfaceExpr ext (Note n e)    = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
 613
 614 ---------------------
 615 toIfaceNote ext (SCC cc)      = IfaceSCC cc
 616 toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1)
 617 toIfaceNote ext InlineCall    = IfaceInlineCall
 618 toIfaceNote ext InlineMe      = IfaceInlineMe
 619 toIfaceNote ext (CoreNote s)  = IfaceCoreNote s
 620
 621 ---------------------
 622 toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r)
 623 toIfaceBind ext (Rec prs)    = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
 624
 625 ---------------------
 626 toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r)
 627
 628 ---------------------
 629 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
 630                         | otherwise       = IfaceDataAlt (getOccName dc)
 631                         where
 632                           tc = dataConTyCon dc
 633
 634 toIfaceCon (LitAlt l) = IfaceLitAlt l
 635 toIfaceCon DEFAULT    = IfaceDefault
 636
 637 ---------------------
 638 toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as)
 639 toIfaceApp ext (Var v) as
 640   = case isDataConWorkId_maybe v of
 641         -- We convert the *worker* for tuples into IfaceTuples
 642         Just dc |  isTupleTyCon tc && saturated
 643                 -> IfaceTuple (tupleTyConBoxity tc) tup_args
 644           where
 645             val_args  = dropWhile isTypeArg as
 646             saturated = val_args `lengthIs` idArity v
 647             tup_args  = map (toIfaceExpr ext) val_args
 648             tc        = dataConTyCon dc
 649
 650         other -> mkIfaceApps ext (toIfaceVar ext v) as
 651
 652 toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as
 653
 654 mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as
 655
 656 ---------------------
 657 toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr
 658 toIfaceVar ext v
 659   | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
 660           -- Foreign calls have special syntax
 661   | isExternalName name             = IfaceExt (ext name)
 662   | otherwise                       = IfaceLcl (nameOccName name)
 663   where
 664     name = idName v
 665
 666 ---------------------
 667 -- mkLhsNameFn ignores versioning info altogether
 668 -- Used for the LHS of instance decls and rules, where we
 669 -- there's no point in recording version info
 670 mkLhsNameFn :: ModuleName -> Name -> IfaceExtName
 671 mkLhsNameFn this_mod name
 672   | mod == this_mod = LocalTop occ
 673   | otherwise       = ExtPkg mod occ
 674   where
 675     mod = nameModuleName name
 676     occ = nameOccName name
 677 \end{code}
 678
 679
 680 %************************************************************************
 681 %*                                                                      *
 682         Equality, for interface file version generaion only
 683 %*                                                                      *
 684 %************************************************************************
 685
 686 Equality over IfaceSyn returns an IfaceEq, not a Bool.  The new constructor is
 687 EqBut, which gives the set of *locally-defined* things whose version must be equal
 688 for the whole thing to be equal.  So the key function is eqIfExt, which compares
 689 IfaceExtNames.
 690
 691 Of course, equality is also done modulo alpha conversion.
 692
 693 \begin{code}
 694 data IfaceEq
 695   = Equal               -- Definitely exactly the same
 696   | NotEqual            -- Definitely different
 697   | EqBut OccSet        -- The same provided these local things have not changed
 698
 699 bool :: Bool -> IfaceEq
 700 bool True  = Equal
 701 bool False = NotEqual
 702
 703 zapEq :: IfaceEq -> IfaceEq     -- Used to forget EqBut information
 704 zapEq (EqBut _) = Equal
 705 zapEq other     = other
 706
 707 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
 708 Equal       &&& x           = x
 709 NotEqual    &&& x           = NotEqual
 710 EqBut occs  &&& Equal       = EqBut occs
 711 EqBut occs  &&& NotEqual    = NotEqual
 712 EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
 713
 714 ---------------------
 715 eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
 716 -- This function is the core of the EqBut stuff
 717 eqIfExt (ExtPkg mod1 occ1)     (ExtPkg mod2 occ2)     = bool (mod1==mod2 && occ1==occ2)
 718 eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
 719 eqIfExt (LocalTop occ1)       (LocalTop occ2)      | occ1 == occ2 = EqBut (unitOccSet occ1)
 720 eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2)      | occ1 == occ2 = EqBut (unitOccSet p1)
 721 eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
 722 eqIfExt n1 n2 = NotEqual
 723 \end{code}
 724
 725
 726 \begin{code}
 727 ---------------------
 728 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
 729 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
 730   = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
 731
 732 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 733   = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
 734
 735 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
 736   = bool (ifName d1    == ifName d2 &&
 737           ifRec d1     == ifRec   d2 &&
 738           ifVrcs d1    == ifVrcs   d2 &&
 739           ifGeneric d1 == ifGeneric d2) &&&
 740     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 741           eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
 742           eq_hsCD      env (ifCons d1) (ifCons d2)
 743         )
 744
 745 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 746   = bool (ifName d1 == ifName d2) &&&
 747     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 748           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 749         )
 750
 751 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 752   = bool (ifName d1 == ifName d2 &&
 753           ifRec d1  == ifRec  d2 &&
 754           ifVrcs d1 == ifVrcs d2) &&&
 755     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 756           eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
 757           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 758           eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
 759        )
 760
 761 eqIfDecl _ _ = NotEqual -- default case
 762
 763 -- Helper
 764 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
 765 eqWith = eq_ifTvBndrs emptyEqEnv
 766
 767 -----------------------
 768 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) &&&
 769                  zapEq (ifInstHead d1 `eqIfType` ifInstHead d2)
 770                 -- zapEq: for instances, ignore the EqBut part
 771
 772 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1)
 773          (IfaceRule n2 a2 bs2 f2 es2 rhs2)
 774        = bool (n1==n2 && a1==a2) &&&
 775          f1 `eqIfExt` f2 &&&
 776          eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
 777          zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
 778                 -- zapEq: for the LHSs, ignore the EqBut part
 779          eq_ifaceExpr env rhs1 rhs2)
 780 eqIfRule _ _ = NotEqual
 781
 782 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) = eqListBy (eq_ConDecl env) c1 c2
 783 eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
 784 eq_hsCD env IfAbstractTyCon  IfAbstractTyCon  = Equal
 785 eq_hsCD env d1               d2               = NotEqual
 786
 787 eq_ConDecl env (IfaceConDecl n1 inf1 tvs1 cxt1 args1 ss1 lbls1)
 788                (IfaceConDecl n2 inf2 tvs2 cxt2 args2 ss2 lbls2)
 789   = bool (n1 == n2 && inf1 == inf2 && ss1 == ss2 && lbls1 == lbls2) &&&
 790     eq_ifTvBndrs env tvs1 tvs2 (\ env ->
 791         eq_ifContext env cxt1 cxt2 &&&
 792         eq_ifTypes env args1 args2)
 793
 794 eq_hsFD env (ns1,ms1) (ns2,ms2)
 795   = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
 796
 797 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
 798   = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
 799 \end{code}
 800
 801
 802 \begin{code}
 803 -----------------
 804 eqIfIdInfo NoInfo        NoInfo        = Equal
 805 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
 806 eqIfIdInfo i1 i2 = NotEqual
 807
 808 eq_item (HsArity a1)       (HsArity a2)       = bool (a1 == a2)
 809 eq_item (HsStrictness s1)  (HsStrictness s2)  = bool (s1 == s2)
 810 eq_item (HsUnfold a1 u1)   (HsUnfold a2 u2)   = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2
 811 eq_item HsNoCafRefs        HsNoCafRefs        = Equal
 812 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
 813 eq_item _ _ = NotEqual
 814
 815 -----------------
 816 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
 817 eq_ifaceExpr env (IfaceLcl v1)        (IfaceLcl v2)        = eqIfOcc env v1 v2
 818 eq_ifaceExpr env (IfaceExt v1)        (IfaceExt v2)        = eqIfExt v1 v2
 819 eq_ifaceExpr env (IfaceLit l1)        (IfaceLit l2)        = bool (l1 == l2)
 820 eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
 821 eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)      = eq_ifType env ty1 ty2
 822 eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
 823 eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
 824 eq_ifaceExpr env (IfaceApp f1 a1)     (IfaceApp f2 a2)     = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
 825 eq_ifaceExpr env (IfaceNote n1 r1)    (IfaceNote n2 r2)    = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
 826
 827 eq_ifaceExpr env (IfaceCase s1 b1 as1) (IfaceCase s2 b2 as2)
 828   = eq_ifaceExpr env s1 s2 &&&
 829     eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
 830   where
 831     eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
 832         = bool (eq_ifaceConAlt c1 c2) &&&
 833           eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
 834
 835 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
 836   = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
 837
 838 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
 839   = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
 840   where
 841     (bs1,rs1) = unzip as1
 842     (bs2,rs2) = unzip as2
 843
 844
 845 eq_ifaceExpr env _ _ = NotEqual
 846
 847 -----------------
 848 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
 849 eq_ifaceConAlt IfaceDefault       IfaceDefault          = True
 850 eq_ifaceConAlt (IfaceDataAlt n1)  (IfaceDataAlt n2)     = n1==n2
 851 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2)    = c1==c2
 852 eq_ifaceConAlt (IfaceLitAlt l1)   (IfaceLitAlt l2)      = l1==l2
 853 eq_ifaceConAlt _ _ = False
 854
 855 -----------------
 856 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
 857 eq_ifaceNote env (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
 858 eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2)     = eq_ifType env t1 t2
 859 eq_ifaceNote env IfaceInlineCall  IfaceInlineCall      = Equal
 860 eq_ifaceNote env IfaceInlineMe    IfaceInlineMe        = Equal
 861 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
 862 eq_ifaceNote env _ _ = NotEqual
 863 \end{code}
 864
 865 \begin{code}
 866 ---------------------
 867 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
 868
 869 -------------------
 870 eq_ifType env (IfaceTyVar n1)         (IfaceTyVar n2)         = eqIfOcc env n1 n2
 871 eq_ifType env (IfaceAppTy s1 t1)      (IfaceAppTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 872 eq_ifType env (IfacePredTy st1)       (IfacePredTy st2)       = eq_ifPredType env st1 st2
 873 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
 874 eq_ifType env (IfaceForAllTy tv1 t1)  (IfaceForAllTy tv2 t2)  = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
 875 eq_ifType env (IfaceFunTy s1 t1)      (IfaceFunTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 876 eq_ifType env _ _ = NotEqual
 877
 878 -------------------
 879 eq_ifTypes env = eqListBy (eq_ifType env)
 880
 881 -------------------
 882 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
 883
 884 -------------------
 885 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&&  eq_ifTypes env tys1 tys2
 886 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2)   = bool (n1 == n2) &&& eq_ifType env ty1 ty2
 887 eq_ifPredType env _ _ = NotEqual
 888
 889 -------------------
 890 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
 891 eqIfTc IfaceIntTc    IfaceIntTc    = Equal
 892 eqIfTc IfaceCharTc   IfaceCharTc   = Equal
 893 eqIfTc IfaceBoolTc   IfaceBoolTc   = Equal
 894 eqIfTc IfaceListTc   IfaceListTc   = Equal
 895 eqIfTc IfacePArrTc   IfacePArrTc   = Equal
 896 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
 897 eqIfTc _ _ = NotEqual
 898 \end{code}
 899
 900 -----------------------------------------------------------
 901         Support code for equality checking
 902 -----------------------------------------------------------
 903
 904 \begin{code}
 905 ------------------------------------
 906 type EqEnv = OccEnv OccName     -- Tracks the mapping from L-variables to R-variables
 907
 908 eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq
 909 eqIfOcc env n1 n2 = case lookupOccEnv env n1 of
 910                         Just n1 -> bool (n1 == n2)
 911                         Nothing -> bool (n1 == n2)
 912
 913 extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv
 914 extendEqEnv env n1 n2 | n1 == n2  = env
 915                       | otherwise = extendOccEnv env n1 n2
 916
 917 emptyEqEnv :: EqEnv
 918 emptyEqEnv = emptyOccEnv
 919
 920 ------------------------------------
 921 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
 922
 923 eq_ifNakedBndr :: ExtEnv OccName
 924 eq_ifBndr      :: ExtEnv IfaceBndr
 925 eq_ifTvBndr    :: ExtEnv IfaceTvBndr
 926 eq_ifIdBndr    :: ExtEnv IfaceIdBndr
 927
 928 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
 929
 930 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
 931 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
 932 eq_ifBndr _ _ _ _ = NotEqual
 933
 934 eq_ifTvBndr env (v1, k1) (v2, k2) k = bool (k1 == k2)     &&& k (extendEqEnv env v1 v2)
 935 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
 936
 937 eq_ifBndrs      :: ExtEnv [IfaceBndr]
 938 eq_ifIdBndrs    :: ExtEnv [IfaceIdBndr]
 939 eq_ifTvBndrs    :: ExtEnv [IfaceTvBndr]
 940 eq_ifNakedBndrs :: ExtEnv [OccName]
 941 eq_ifBndrs      = eq_bndrs_with eq_ifBndr
 942 eq_ifIdBndrs    = eq_bndrs_with eq_ifIdBndr
 943 eq_ifTvBndrs    = eq_bndrs_with eq_ifTvBndr
 944 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
 945
 946 eq_bndrs_with eq env []       []       k = k env
 947 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
 948 eq_bndrs_with eq env _        _        _ = NotEqual
 949 \end{code}
 950
 951 \begin{code}
 952 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
 953 eqListBy eq []     []     = Equal
 954 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
 955 eqListBy eq xs     ys     = NotEqual
 956
 957 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
 958 eqMaybeBy eq Nothing Nothing   = Equal
 959 eqMaybeBy eq (Just x) (Just y) = eq x y
 960 eqMaybeBy eq x        y        = NotEqual
 961 \end{code}