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