compiler/iface/IfaceSyn.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   4 %
   5
   6 \begin{code}
   7 module IfaceSyn (
   8         module IfaceType,               -- Re-export all this
   9
  10         IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
  11         IfaceExpr(..), IfaceAlt, IfaceNote(..),
  12         IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
  13         IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
  14
  15         -- Misc
  16         ifaceDeclSubBndrs, visibleIfConDecls,
  17
  18         -- Equality
  19         GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy,
  20         eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl,
  21
  22         -- Pretty printing
  23         pprIfaceExpr, pprIfaceDeclHead
  24     ) where
  25
  26 #include "HsVersions.h"
  27
  28 import CoreSyn
  29 import IfaceType
  30
  31 import NewDemand
  32 import Class
  33 import UniqFM
  34 import Unique
  35 import NameSet
  36 import Name
  37 import CostCentre
  38 import Literal
  39 import ForeignCall
  40 import SrcLoc
  41 import BasicTypes
  42 import Outputable
  43 import FastString
  44 import Module
  45
  46 import Data.List
  47 import Data.Maybe
  48
  49 infixl 3 &&&
  50 infix  4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
  51 \end{code}
  52
  53
  54 %************************************************************************
  55 %*                                                                      *
  56                 Data type declarations
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 data IfaceDecl
  62   = IfaceId { ifName   :: OccName,
  63               ifType   :: IfaceType,
  64               ifIdInfo :: IfaceIdInfo }
  65
  66   | IfaceData { ifName       :: OccName,        -- Type constructor
  67                 ifTyVars     :: [IfaceTvBndr],  -- Type variables
  68                 ifCtxt       :: IfaceContext,   -- The "stupid theta"
  69                 ifCons       :: IfaceConDecls,  -- Includes new/data info
  70                 ifRec        :: RecFlag,        -- Recursive or not?
  71                 ifGadtSyntax :: Bool,           -- True <=> declared using
  72                                                 -- GADT syntax
  73                 ifGeneric    :: Bool,           -- True <=> generic converter
  74                                                 --          functions available
  75                                                 -- We need this for imported
  76                                                 -- data decls, since the
  77                                                 -- imported modules may have
  78                                                 -- been compiled with
  79                                                 -- different flags to the
  80                                                 -- current compilation unit
  81                 ifFamInst    :: Maybe (IfaceTyCon, [IfaceType])
  82                                                 -- Just <=> instance of family
  83     }
  84
  85   | IfaceSyn  { ifName    :: OccName,           -- Type constructor
  86                 ifTyVars  :: [IfaceTvBndr],     -- Type variables
  87                 ifOpenSyn :: Bool,              -- Is an open family?
  88                 ifSynRhs  :: IfaceType          -- Type for an ordinary
  89                                                 -- synonym and kind for an
  90                                                 -- open family
  91     }
  92
  93   | IfaceClass { ifCtxt    :: IfaceContext,     -- Context...
  94                  ifName    :: OccName,          -- Name of the class
  95                  ifTyVars  :: [IfaceTvBndr],    -- Type variables
  96                  ifFDs     :: [FunDep FastString], -- Functional dependencies
  97                  ifATs     :: [IfaceDecl],      -- Associated type families
  98                  ifSigs    :: [IfaceClassOp],   -- Method signatures
  99                  ifRec     :: RecFlag           -- Is newtype/datatype associated with the class recursive?
 100     }
 101
 102   | IfaceForeign { ifName :: OccName,           -- Needs expanding when we move
 103                                                 -- beyond .NET
 104                    ifExtName :: Maybe FastString }
 105
 106 data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
 107         -- Nothing    => no default method
 108         -- Just False => ordinary polymorphic default method
 109         -- Just True  => generic default method
 110
 111 data IfaceConDecls
 112   = IfAbstractTyCon             -- No info
 113   | IfOpenDataTyCon             -- Open data family
 114   | IfOpenNewTyCon              -- Open newtype family
 115   | IfDataTyCon [IfaceConDecl]  -- data type decls
 116   | IfNewTyCon  IfaceConDecl    -- newtype decls
 117
 118 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 119 visibleIfConDecls IfAbstractTyCon  = []
 120 visibleIfConDecls IfOpenDataTyCon  = []
 121 visibleIfConDecls IfOpenNewTyCon   = []
 122 visibleIfConDecls (IfDataTyCon cs) = cs
 123 visibleIfConDecls (IfNewTyCon c)   = [c]
 124
 125 data IfaceConDecl
 126   = IfCon {
 127         ifConOcc     :: OccName,                -- Constructor name
 128         ifConInfix   :: Bool,                   -- True <=> declared infix
 129         ifConUnivTvs :: [IfaceTvBndr],          -- Universal tyvars
 130         ifConExTvs   :: [IfaceTvBndr],          -- Existential tyvars
 131         ifConEqSpec  :: [(OccName,IfaceType)],  -- Equality contraints
 132         ifConCtxt    :: IfaceContext,           -- Non-stupid context
 133         ifConArgTys  :: [IfaceType],            -- Arg types
 134         ifConFields  :: [OccName],              -- ...ditto... (field labels)
 135         ifConStricts :: [StrictnessMark]}       -- Empty (meaning all lazy),
 136                                                 -- or 1-1 corresp with arg tys
 137
 138 data IfaceInst
 139   = IfaceInst { ifInstCls  :: Name,                     -- See comments with
 140                 ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of Instance
 141                 ifDFun     :: Name,                     -- The dfun
 142                 ifOFlag    :: OverlapFlag,              -- Overlap flag
 143                 ifInstOrph :: Maybe OccName }           -- See is_orph in defn of Instance
 144         -- There's always a separate IfaceDecl for the DFun, which gives
 145         -- its IdInfo with its full type and version number.
 146         -- The instance declarations taken together have a version number,
 147         -- and we don't want that to wobble gratuitously
 148         -- If this instance decl is *used*, we'll record a usage on the dfun;
 149         -- and if the head does not change it won't be used if it wasn't before
 150
 151 data IfaceFamInst
 152   = IfaceFamInst { ifFamInstFam   :: Name                -- Family tycon
 153                  , ifFamInstTys   :: [Maybe IfaceTyCon]  -- Rough match types
 154                  , ifFamInstTyCon :: IfaceTyCon          -- Instance decl
 155                  }
 156
 157 data IfaceRule
 158   = IfaceRule {
 159         ifRuleName   :: RuleName,
 160         ifActivation :: Activation,
 161         ifRuleBndrs  :: [IfaceBndr],    -- Tyvars and term vars
 162         ifRuleHead   :: Name,           -- Head of lhs
 163         ifRuleArgs   :: [IfaceExpr],    -- Args of LHS
 164         ifRuleRhs    :: IfaceExpr,
 165         ifRuleOrph   :: Maybe OccName   -- Just like IfaceInst
 166     }
 167
 168 data IfaceIdInfo
 169   = NoInfo                      -- When writing interface file without -O
 170   | HasInfo [IfaceInfoItem]     -- Has info, and here it is
 171
 172 -- Here's a tricky case:
 173 --   * Compile with -O module A, and B which imports A.f
 174 --   * Change function f in A, and recompile without -O
 175 --   * When we read in old A.hi we read in its IdInfo (as a thunk)
 176 --      (In earlier GHCs we used to drop IdInfo immediately on reading,
 177 --       but we do not do that now.  Instead it's discarded when the
 178 --       ModIface is read into the various decl pools.)
 179 --   * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
 180 --      and so gives a new version.
 181
 182 data IfaceInfoItem
 183   = HsArity      Arity
 184   | HsStrictness StrictSig
 185   | HsInline     Activation
 186   | HsUnfold     IfaceExpr
 187   | HsNoCafRefs
 188   | HsWorker     Name Arity     -- Worker, if any see IdInfo.WorkerInfo
 189                                         -- for why we want arity here.
 190         -- NB: we need IfaceExtName (not just OccName) because the worker
 191         --     can simplify to a function in another module.
 192 -- NB: Specialisations and rules come in separately and are
 193 -- only later attached to the Id.  Partial reason: some are orphans.
 194
 195 --------------------------------
 196 data IfaceExpr
 197   = IfaceLcl    FastString
 198   | IfaceExt    Name
 199   | IfaceType   IfaceType
 200   | IfaceTuple  Boxity [IfaceExpr]              -- Saturated; type arguments omitted
 201   | IfaceLam    IfaceBndr IfaceExpr
 202   | IfaceApp    IfaceExpr IfaceExpr
 203   | IfaceCase   IfaceExpr FastString IfaceType [IfaceAlt]
 204   | IfaceLet    IfaceBinding  IfaceExpr
 205   | IfaceNote   IfaceNote IfaceExpr
 206   | IfaceCast   IfaceExpr IfaceCoercion
 207   | IfaceLit    Literal
 208   | IfaceFCall  ForeignCall IfaceType
 209
 210 data IfaceNote = IfaceSCC CostCentre
 211                | IfaceInlineMe
 212                | IfaceCoreNote String
 213
 214 type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
 215         -- Note: FastString, not IfaceBndr (and same with the case binder)
 216         -- We reconstruct the kind/type of the thing from the context
 217         -- thus saving bulk in interface files
 218
 219 data IfaceConAlt = IfaceDefault
 220                  | IfaceDataAlt Name
 221                  | IfaceTupleAlt Boxity
 222                  | IfaceLitAlt Literal
 223
 224 data IfaceBinding
 225   = IfaceNonRec IfaceIdBndr IfaceExpr
 226   | IfaceRec    [(IfaceIdBndr, IfaceExpr)]
 227
 228 -- -----------------------------------------------------------------------------
 229 -- Utils on IfaceSyn
 230
 231 ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
 232 --  *Excludes* the 'main' name, but *includes* the implicitly-bound names
 233 -- Deeply revolting, because it has to predict what gets bound,
 234 -- especially the question of whether there's a wrapper for a datacon
 235
 236 ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
 237                                ifSigs = sigs, ifATs = ats })
 238   = co_occs ++
 239     [tc_occ, dc_occ, dcww_occ] ++
 240     [op | IfaceClassOp op  _ _ <- sigs] ++
 241     [ifName at | at <- ats ] ++
 242     [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
 243   where
 244     n_ctxt = length sc_ctxt
 245     n_sigs = length sigs
 246     tc_occ  = mkClassTyConOcc cls_occ
 247     dc_occ  = mkClassDataConOcc cls_occ
 248     co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
 249             | otherwise  = []
 250     dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ       -- Newtypes have wrapper but no worker
 251              | otherwise  = mkDataConWorkerOcc dc_occ   -- Otherwise worker but no wrapper
 252     is_newtype = n_sigs + n_ctxt == 1                   -- Sigh
 253
 254 ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}
 255   = []
 256 -- Newtype
 257 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
 258                               ifCons = IfNewTyCon (
 259                                          IfCon { ifConOcc = con_occ,
 260                                                            ifConFields = fields
 261                                                          }),
 262                               ifFamInst = famInst})
 263   = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ]
 264     ++ famInstCo famInst tc_occ
 265
 266 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
 267                               ifCons = IfDataTyCon cons,
 268                               ifFamInst = famInst})
 269   = nub (concatMap ifConFields cons)    -- Eliminate duplicate fields
 270     ++ concatMap dc_occs cons
 271     ++ famInstCo famInst tc_occ
 272   where
 273     dc_occs con_decl
 274         | has_wrapper = [con_occ, work_occ, wrap_occ]
 275         | otherwise   = [con_occ, work_occ]
 276         where
 277           con_occ = ifConOcc con_decl
 278           strs    = ifConStricts con_decl
 279           wrap_occ = mkDataConWrapperOcc con_occ
 280           work_occ = mkDataConWorkerOcc con_occ
 281           has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
 282                         || not (null . ifConEqSpec $ con_decl)
 283                         || isJust famInst
 284                 -- ToDo: may miss strictness in existential dicts
 285
 286 ifaceDeclSubBndrs _other = []
 287
 288 -- coercion for data/newtype family instances
 289 famInstCo Nothing  baseOcc = []
 290 famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
 291
 292 ----------------------------- Printing IfaceDecl ------------------------------
 293
 294 instance Outputable IfaceDecl where
 295   ppr = pprIfaceDecl
 296
 297 pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
 298   = sep [ ppr var <+> dcolon <+> ppr ty,
 299           nest 2 (ppr info) ]
 300
 301 pprIfaceDecl (IfaceForeign {ifName = tycon})
 302   = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
 303
 304 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
 305                         ifOpenSyn = False, ifSynRhs = mono_ty})
 306   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
 307        4 (equals <+> ppr mono_ty)
 308
 309 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
 310                         ifOpenSyn = True, ifSynRhs = mono_ty})
 311   = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
 312        4 (dcolon <+> ppr mono_ty)
 313
 314 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
 315                          ifTyVars = tyvars, ifCons = condecls,
 316                          ifRec = isrec, ifFamInst = mbFamInst})
 317   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
 318        4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
 319                 pprFamily mbFamInst])
 320   where
 321     pp_nd = case condecls of
 322                 IfAbstractTyCon -> ptext SLIT("data")
 323                 IfOpenDataTyCon -> ptext SLIT("data family")
 324                 IfDataTyCon _   -> ptext SLIT("data")
 325                 IfNewTyCon _    -> ptext SLIT("newtype")
 326                 IfOpenNewTyCon  -> ptext SLIT("newtype family")
 327
 328 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
 329                           ifFDs = fds, ifATs = ats, ifSigs = sigs,
 330                           ifRec = isrec})
 331   = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
 332        4 (vcat [pprRec isrec,
 333                 sep (map ppr ats),
 334                 sep (map ppr sigs)])
 335
 336 pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
 337 pprGen True  = ptext SLIT("Generics: yes")
 338 pprGen False = ptext SLIT("Generics: no")
 339
 340 pprFamily Nothing        = ptext SLIT("FamilyInstance: none")
 341 pprFamily (Just famInst) = ptext SLIT("FamilyInstance:") <+> ppr famInst
 342
 343 instance Outputable IfaceClassOp where
 344    ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
 345
 346 pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
 347 pprIfaceDeclHead context thing tyvars
 348   = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
 349           pprIfaceTvBndrs tyvars]
 350
 351 pp_condecls tc IfAbstractTyCon  = ptext SLIT("{- abstract -}")
 352 pp_condecls tc IfOpenNewTyCon   = empty
 353 pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
 354 pp_condecls tc IfOpenDataTyCon  = empty
 355 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
 356                                                              (map (pprIfaceConDecl tc) cs))
 357
 358 pprIfaceConDecl tc
 359         (IfCon { ifConOcc = name, ifConInfix = is_infix,
 360                  ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
 361                  ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
 362                  ifConStricts = strs, ifConFields = fields })
 363   = sep [main_payload,
 364          if is_infix then ptext SLIT("Infix") else empty,
 365          if null strs then empty
 366               else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
 367          if null fields then empty
 368               else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
 369   where
 370     main_payload = ppr name <+> dcolon <+>
 371                    pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) (ppr con_tau)
 372
 373     eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
 374               | (tv,ty) <- eq_spec]
 375     con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app])
 376     tc_app  = IfaceTyConApp (IfaceTc tc_name)
 377                             [IfaceTyVar tv | (tv,_) <- univ_tvs]
 378     tc_name = mkInternalName (mkBuiltinUnique 1) tc noSrcLoc
 379         -- Really Gruesome, but just for debug print
 380
 381 instance Outputable IfaceRule where
 382   ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
 383                    ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
 384     = sep [hsep [doubleQuotes (ftext name), ppr act,
 385                  ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
 386            nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
 387                         ptext SLIT("=") <+> ppr rhs])
 388       ]
 389
 390 instance Outputable IfaceInst where
 391   ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
 392                   ifInstCls = cls, ifInstTys = mb_tcs})
 393     = hang (ptext SLIT("instance") <+> ppr flag
 394                 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
 395          2 (equals <+> ppr dfun_id)
 396
 397 instance Outputable IfaceFamInst where
 398   ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
 399                      ifFamInstTyCon = tycon_id})
 400     = hang (ptext SLIT("family instance") <+>
 401             ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
 402          2 (equals <+> ppr tycon_id)
 403
 404 ppr_rough :: Maybe IfaceTyCon -> SDoc
 405 ppr_rough Nothing   = dot
 406 ppr_rough (Just tc) = ppr tc
 407 \end{code}
 408
 409
 410 ----------------------------- Printing IfaceExpr ------------------------------------
 411
 412 \begin{code}
 413 instance Outputable IfaceExpr where
 414     ppr e = pprIfaceExpr noParens e
 415
 416 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
 417         -- The function adds parens in context that need
 418         -- an atomic value (e.g. function args)
 419
 420 pprIfaceExpr add_par (IfaceLcl v)       = ppr v
 421 pprIfaceExpr add_par (IfaceExt v)       = ppr v
 422 pprIfaceExpr add_par (IfaceLit l)       = ppr l
 423 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 424 pprIfaceExpr add_par (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
 425
 426 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 427 pprIfaceExpr add_par (IfaceTuple c as)  = tupleParens c (interpp'SP as)
 428
 429 pprIfaceExpr add_par e@(IfaceLam _ _)
 430   = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
 431                   pprIfaceExpr noParens body])
 432   where
 433     (bndrs,body) = collect [] e
 434     collect bs (IfaceLam b e) = collect (b:bs) e
 435     collect bs e              = (reverse bs, e)
 436
 437 pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
 438   = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
 439                         <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
 440                         <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
 441                   pprIfaceExpr noParens rhs <+> char '}'])
 442
 443 pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
 444   = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
 445                         <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
 446                         <+> ppr bndr <+> char '{',
 447                   nest 2 (sep (map ppr_alt alts)) <+> char '}'])
 448
 449 pprIfaceExpr add_par (IfaceCast expr co)
 450   = sep [pprIfaceExpr parens expr,
 451          nest 2 (ptext SLIT("`cast`")),
 452          pprParendIfaceType co]
 453
 454 pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
 455   = add_par (sep [ptext SLIT("let {"),
 456                   nest 2 (ppr_bind (b, rhs)),
 457                   ptext SLIT("} in"),
 458                   pprIfaceExpr noParens body])
 459
 460 pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
 461   = add_par (sep [ptext SLIT("letrec {"),
 462                   nest 2 (sep (map ppr_bind pairs)),
 463                   ptext SLIT("} in"),
 464                   pprIfaceExpr noParens body])
 465
 466 pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
 467
 468 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
 469                               arrow <+> pprIfaceExpr noParens rhs]
 470
 471 ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
 472 ppr_con_bs con bs                     = ppr con <+> hsep (map ppr bs)
 473
 474 ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
 475                              equals <+> pprIfaceExpr noParens rhs]
 476
 477 ------------------
 478 pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
 479 pprIfaceApp fun                args = sep (pprIfaceExpr parens fun : args)
 480
 481 ------------------
 482 instance Outputable IfaceNote where
 483     ppr (IfaceSCC cc)     = pprCostCentreCore cc
 484     ppr IfaceInlineMe     = ptext SLIT("__inline_me")
 485     ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
 486
 487
 488 instance Outputable IfaceConAlt where
 489     ppr IfaceDefault      = text "DEFAULT"
 490     ppr (IfaceLitAlt l)   = ppr l
 491     ppr (IfaceDataAlt d)  = ppr d
 492     ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
 493         -- IfaceTupleAlt is handled by the case-alternative printer
 494
 495 ------------------
 496 instance Outputable IfaceIdInfo where
 497    ppr NoInfo       = empty
 498    ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
 499
 500 ppr_hs_info (HsUnfold unf)      = ptext SLIT("Unfolding:") <+>
 501                                         parens (pprIfaceExpr noParens unf)
 502 ppr_hs_info (HsInline act)      = ptext SLIT("Inline:") <+> ppr act
 503 ppr_hs_info (HsArity arity)     = ptext SLIT("Arity:") <+> int arity
 504 ppr_hs_info (HsStrictness str)  = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
 505 ppr_hs_info HsNoCafRefs         = ptext SLIT("HasNoCafRefs")
 506 ppr_hs_info (HsWorker w a)      = ptext SLIT("Worker:") <+> ppr w <+> int a
 507 \end{code}
 508
 509
 510 %************************************************************************
 511 %*                                                                      *
 512         Equality, for interface file version generaion only
 513 %*                                                                      *
 514 %************************************************************************
 515
 516 Equality over IfaceSyn returns an IfaceEq, not a Bool.  The new
 517 constructor is EqBut, which gives the set of things whose version must
 518 be equal for the whole thing to be equal.  So the key function is
 519 eqIfExt, which compares Names.
 520
 521 Of course, equality is also done modulo alpha conversion.
 522
 523 \begin{code}
 524 data GenIfaceEq a
 525   = Equal               -- Definitely exactly the same
 526   | NotEqual            -- Definitely different
 527   | EqBut a       -- The same provided these Names have not changed
 528
 529 type IfaceEq = GenIfaceEq NameSet
 530
 531 instance Outputable IfaceEq where
 532   ppr Equal          = ptext SLIT("Equal")
 533   ppr NotEqual       = ptext SLIT("NotEqual")
 534   ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset)
 535
 536 bool :: Bool -> IfaceEq
 537 bool True  = Equal
 538 bool False = NotEqual
 539
 540 toBool :: IfaceEq -> Bool
 541 toBool Equal     = True
 542 toBool (EqBut _) = True
 543 toBool NotEqual  = False
 544
 545 zapEq :: IfaceEq -> IfaceEq     -- Used to forget EqBut information
 546 zapEq (EqBut _) = Equal
 547 zapEq other     = other
 548
 549 (&&&) :: IfaceEq -> IfaceEq -> IfaceEq
 550 Equal       &&& x           = x
 551 NotEqual    &&& x           = NotEqual
 552 EqBut nms   &&& Equal       = EqBut nms
 553 EqBut nms   &&& NotEqual    = NotEqual
 554 EqBut nms1  &&& EqBut nms2  = EqBut (nms1 `unionNameSets` nms2)
 555
 556 -- This function is the core of the EqBut stuff
 557 -- ASSUMPTION: The left-hand argument is the NEW CODE, and hence
 558 -- any Names in the left-hand arg have the correct parent in them.
 559 eqIfExt :: Name -> Name -> IfaceEq
 560 eqIfExt name1 name2
 561   | name1 == name2 = EqBut (unitNameSet name1)
 562   | otherwise      = NotEqual
 563
 564 ---------------------
 565 checkBootDecl :: IfaceDecl      -- The boot decl
 566               -> IfaceDecl      -- The real decl
 567               -> Bool           -- True <=> compatible
 568 checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
 569   = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
 570
 571 checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 572   = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
 573
 574 checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 575   = ASSERT( ifName d1 == ifName d2 )
 576     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 577           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 578
 579 checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
 580 -- We don't check the recursion flags because the boot-one is
 581 -- recursive, to be conservative, but the real one may not be.
 582 -- I'm not happy with the way recursive flags are dealt with.
 583   = ASSERT( ifName d1    == ifName d2 )
 584     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 585         eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 586         case ifCons d1 of
 587             IfAbstractTyCon -> Equal
 588             cons1           -> eq_hsCD env cons1 (ifCons d2)
 589
 590 checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 591   = ASSERT( ifName d1 == ifName d2 )
 592     toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
 593           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 594           case (ifCtxt d1, ifSigs d1) of
 595              ([], [])      -> Equal
 596              (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2)  &&&
 597                               eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
 598
 599 checkBootDecl _ _ = False       -- default case
 600
 601 ---------------------
 602 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
 603 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
 604   = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
 605
 606 eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
 607   = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
 608
 609 eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
 610   = bool (ifName d1    == ifName d2 &&
 611           ifRec d1     == ifRec   d2 &&
 612           ifGadtSyntax d1 == ifGadtSyntax   d2 &&
 613           ifGeneric d1 == ifGeneric d2) &&&
 614     ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
 615     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 616             eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
 617             eq_hsCD env (ifCons d1) (ifCons d2)
 618         )
 619         -- The type variables of the data type do not scope
 620         -- over the constructors (any more), but they do scope
 621         -- over the stupid context in the IfaceConDecls
 622   where
 623     Nothing             `eqIfTc_fam` Nothing             = Equal
 624     (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
 625       fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
 626     _                   `eqIfTc_fam` _                   = NotEqual
 627
 628 eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
 629   = bool (ifName d1 == ifName d2) &&&
 630     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 631           eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
 632         )
 633
 634 eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
 635   = bool (ifName d1 == ifName d2 &&
 636           ifRec d1  == ifRec  d2) &&&
 637     eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
 638           eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
 639           eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
 640           eqListBy eqIfDecl         (ifATs d1)  (ifATs d2) &&&
 641           eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
 642        )
 643
 644 eqIfDecl _ _ = NotEqual -- default case
 645
 646 -- Helper
 647 eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
 648 eqWith = eq_ifTvBndrs emptyEqEnv
 649
 650 -----------------------
 651 eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
 652 -- All other changes are handled via the version info on the dfun
 653
 654 eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
 655 -- All other changes are handled via the version info on the tycon
 656
 657 eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
 658          (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
 659        = bool (n1==n2 && a1==a2 && o1 == o2) &&&
 660          f1 `eqIfExt` f2 &&&
 661          eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
 662          zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
 663                 -- zapEq: for the LHSs, ignore the EqBut part
 664          eq_ifaceExpr env rhs1 rhs2)
 665
 666 eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
 667   = eqListBy (eq_ConDecl env) c1 c2
 668
 669 eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
 670 eq_hsCD env IfAbstractTyCon  IfAbstractTyCon  = Equal
 671 eq_hsCD env IfOpenDataTyCon  IfOpenDataTyCon  = Equal
 672 eq_hsCD env IfOpenNewTyCon   IfOpenNewTyCon   = Equal
 673 eq_hsCD env d1               d2               = NotEqual
 674
 675 eq_ConDecl env c1 c2
 676   = bool (ifConOcc c1     == ifConOcc c2 &&
 677           ifConInfix c1   == ifConInfix c2 &&
 678           ifConStricts c1 == ifConStricts c2 &&
 679           ifConFields c1  == ifConFields c2) &&&
 680     eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
 681     eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
 682         eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
 683         eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
 684
 685 eq_hsFD env (ns1,ms1) (ns2,ms2)
 686   = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
 687
 688 eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
 689   = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
 690 \end{code}
 691
 692
 693 \begin{code}
 694 -----------------
 695 eqIfIdInfo NoInfo        NoInfo        = Equal
 696 eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
 697 eqIfIdInfo i1            i2 = NotEqual
 698
 699 eq_item (HsInline a1)      (HsInline a2)      = bool (a1 == a2)
 700 eq_item (HsArity a1)       (HsArity a2)       = bool (a1 == a2)
 701 eq_item (HsStrictness s1)  (HsStrictness s2)  = bool (s1 == s2)
 702 eq_item (HsUnfold u1)   (HsUnfold u2)         = eq_ifaceExpr emptyEqEnv u1 u2
 703 eq_item HsNoCafRefs        HsNoCafRefs        = Equal
 704 eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
 705 eq_item _ _ = NotEqual
 706
 707 -----------------
 708 eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
 709 eq_ifaceExpr env (IfaceLcl v1)        (IfaceLcl v2)        = eqIfOcc env v1 v2
 710 eq_ifaceExpr env (IfaceExt v1)        (IfaceExt v2)        = eqIfExt v1 v2
 711 eq_ifaceExpr env (IfaceLit l1)        (IfaceLit l2)        = bool (l1 == l2)
 712 eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
 713 eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)      = eq_ifType env ty1 ty2
 714 eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
 715 eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
 716 eq_ifaceExpr env (IfaceApp f1 a1)     (IfaceApp f2 a2)     = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
 717 eq_ifaceExpr env (IfaceCast e1 co1)   (IfaceCast e2 co2)   = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
 718 eq_ifaceExpr env (IfaceNote n1 r1)    (IfaceNote n2 r2)    = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
 719
 720 eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
 721   = eq_ifaceExpr env s1 s2 &&&
 722     eq_ifType env ty1 ty2 &&&
 723     eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
 724   where
 725     eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
 726         = bool (eq_ifaceConAlt c1 c2) &&&
 727           eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
 728
 729 eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
 730   = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
 731
 732 eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
 733   = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
 734   where
 735     (bs1,rs1) = unzip as1
 736     (bs2,rs2) = unzip as2
 737
 738
 739 eq_ifaceExpr env _ _ = NotEqual
 740
 741 -----------------
 742 eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
 743 eq_ifaceConAlt IfaceDefault       IfaceDefault          = True
 744 eq_ifaceConAlt (IfaceDataAlt n1)  (IfaceDataAlt n2)     = n1==n2
 745 eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2)    = c1==c2
 746 eq_ifaceConAlt (IfaceLitAlt l1)   (IfaceLitAlt l2)      = l1==l2
 747 eq_ifaceConAlt _ _ = False
 748
 749 -----------------
 750 eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
 751 eq_ifaceNote env (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
 752 eq_ifaceNote env IfaceInlineMe    IfaceInlineMe        = Equal
 753 eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
 754 eq_ifaceNote env _ _ = NotEqual
 755 \end{code}
 756
 757 \begin{code}
 758 ---------------------
 759 eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
 760
 761 -------------------
 762 eq_ifType env (IfaceTyVar n1)         (IfaceTyVar n2)         = eqIfOcc env n1 n2
 763 eq_ifType env (IfaceAppTy s1 t1)      (IfaceAppTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 764 eq_ifType env (IfacePredTy st1)       (IfacePredTy st2)       = eq_ifPredType env st1 st2
 765 eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
 766 eq_ifType env (IfaceForAllTy tv1 t1)  (IfaceForAllTy tv2 t2)  = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
 767 eq_ifType env (IfaceFunTy s1 t1)      (IfaceFunTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
 768 eq_ifType env _ _ = NotEqual
 769
 770 -------------------
 771 eq_ifTypes env = eqListBy (eq_ifType env)
 772
 773 -------------------
 774 eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
 775
 776 -------------------
 777 eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&&  eq_ifTypes env tys1 tys2
 778 eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2)   = bool (n1 == n2) &&& eq_ifType env ty1 ty2
 779 eq_ifPredType env _ _ = NotEqual
 780
 781 -------------------
 782 eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
 783 eqIfTc IfaceIntTc    IfaceIntTc    = Equal
 784 eqIfTc IfaceCharTc   IfaceCharTc   = Equal
 785 eqIfTc IfaceBoolTc   IfaceBoolTc   = Equal
 786 eqIfTc IfaceListTc   IfaceListTc   = Equal
 787 eqIfTc IfacePArrTc   IfacePArrTc   = Equal
 788 eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
 789 eqIfTc IfaceLiftedTypeKindTc   IfaceLiftedTypeKindTc   = Equal
 790 eqIfTc IfaceOpenTypeKindTc     IfaceOpenTypeKindTc     = Equal
 791 eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
 792 eqIfTc IfaceUbxTupleKindTc     IfaceUbxTupleKindTc     = Equal
 793 eqIfTc IfaceArgTypeKindTc      IfaceArgTypeKindTc      = Equal
 794 eqIfTc _                       _                       = NotEqual
 795 \end{code}
 796
 797 -----------------------------------------------------------
 798         Support code for equality checking
 799 -----------------------------------------------------------
 800
 801 \begin{code}
 802 ------------------------------------
 803 type EqEnv = UniqFM FastString  -- Tracks the mapping from L-variables to R-variables
 804
 805 eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
 806 eqIfOcc env n1 n2 = case lookupUFM env n1 of
 807                         Just n1 -> bool (n1 == n2)
 808                         Nothing -> bool (n1 == n2)
 809
 810 extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
 811 extendEqEnv env n1 n2 | n1 == n2  = env
 812                       | otherwise = addToUFM env n1 n2
 813
 814 emptyEqEnv :: EqEnv
 815 emptyEqEnv = emptyUFM
 816
 817 ------------------------------------
 818 type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
 819
 820 eq_ifNakedBndr :: ExtEnv FastString
 821 eq_ifBndr      :: ExtEnv IfaceBndr
 822 eq_ifTvBndr    :: ExtEnv IfaceTvBndr
 823 eq_ifIdBndr    :: ExtEnv IfaceIdBndr
 824
 825 eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
 826
 827 eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
 828 eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
 829 eq_ifBndr _ _ _ _ = NotEqual
 830
 831 eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
 832 eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
 833
 834 eq_ifBndrs      :: ExtEnv [IfaceBndr]
 835 eq_ifIdBndrs    :: ExtEnv [IfaceIdBndr]
 836 eq_ifTvBndrs    :: ExtEnv [IfaceTvBndr]
 837 eq_ifNakedBndrs :: ExtEnv [FastString]
 838 eq_ifBndrs      = eq_bndrs_with eq_ifBndr
 839 eq_ifIdBndrs    = eq_bndrs_with eq_ifIdBndr
 840 eq_ifTvBndrs    = eq_bndrs_with eq_ifTvBndr
 841 eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
 842
 843 eq_bndrs_with eq env []       []       k = k env
 844 eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
 845 eq_bndrs_with eq env _        _        _ = NotEqual
 846 \end{code}
 847
 848 \begin{code}
 849 eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
 850 eqListBy eq []     []     = Equal
 851 eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
 852 eqListBy eq xs     ys     = NotEqual
 853
 854 eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
 855 eqMaybeBy eq Nothing Nothing   = Equal
 856 eqMaybeBy eq (Just x) (Just y) = eq x y
 857 eqMaybeBy eq x        y        = NotEqual
 858 \end{code}