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