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