ghc/compiler/main/MkIface.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[MkIface]{Print an interface for a module}
   5
   6 \begin{code}
   7 module MkIface (
   8         mkModDetails, mkModDetailsFromIface, completeIface,
   9         writeIface, pprIface
  10   ) where
  11
  12 #include "HsVersions.h"
  13
  14 import HsSyn
  15 import HsCore           ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
  16 import HsTypes          ( toHsTyVars )
  17 import BasicTypes       ( Fixity(..), NewOrData(..),
  18                           Version, initialVersion, bumpVersion, isLoopBreaker
  19                         )
  20 import RnMonad
  21 import RnHsSyn          ( RenamedInstDecl, RenamedTyClDecl )
  22 import TcHsSyn          ( TypecheckedRuleDecl )
  23 import HscTypes         ( VersionInfo(..), ModIface(..), ModDetails(..),
  24                           IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
  25                           TyThing(..), DFunId, TypeEnv, Avails,
  26                           WhatsImported(..), GenAvailInfo(..),
  27                           ImportVersion, AvailInfo, Deprecations(..),
  28                           extendTypeEnvList
  29                         )
  30
  31 import CmdLineOpts
  32 import Id               ( Id, idType, idInfo, omitIfaceSigForId, isDictFunId,
  33                           idSpecialisation, setIdInfo, isLocalId, idName, hasNoBinding
  34                         )
  35 import Var              ( isId )
  36 import VarSet
  37 import DataCon          ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
  38 import IdInfo           -- Lots
  39 import CoreSyn          ( CoreBind, CoreRule(..), IdCoreRule,
  40                           isBuiltinRule, rulesRules,
  41                           bindersOf, bindersOfBinds
  42                         )
  43 import CoreFVs          ( ruleSomeLhsFreeVars )
  44 import CoreUnfold       ( neverUnfold, unfoldingTemplate )
  45 import Name             ( getName, nameModule, Name, NamedThing(..) )
  46 import Name     -- Env
  47 import OccName          ( pprOccName )
  48 import TyCon            ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
  49                           tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
  50                         )
  51 import Class            ( classExtraBigSig, classTyCon, DefMeth(..) )
  52 import FieldLabel       ( fieldLabelType )
  53 import Type             ( splitSigmaTy, tidyTopType, deNoteType )
  54 import SrcLoc           ( noSrcLoc )
  55 import Outputable
  56 import Module           ( ModuleName )
  57
  58 import IO               ( IOMode(..), openFile, hClose )
  59 \end{code}
  60
  61
  62 %************************************************************************
  63 %*                                                                      *
  64 \subsection{Write a new interface file}
  65 %*                                                                      *
  66 %************************************************************************
  67
  68 \begin{code}
  69 mkModDetails :: TypeEnv         -- From typechecker
  70              -> [CoreBind]      -- Final bindings
  71              -> [Id]            -- Top-level Ids from the code generator;
  72                                 -- they have authoritative arity info
  73              -> [IdCoreRule]    -- Tidy orphan rules
  74              -> ModDetails
  75 mkModDetails type_env tidy_binds stg_ids orphan_rules
  76   = ModDetails { md_types = new_type_env,
  77                  md_rules = rule_dcls,
  78                  md_insts = filter isDictFunId final_ids }
  79   where
  80         -- The competed type environment is gotten from
  81         --      a) keeping the types and classes
  82         --      b) removing all Ids,
  83         --      c) adding Ids with correct IdInfo, including unfoldings,
  84         --              gotten from the bindings
  85         -- From (c) we keep only those Ids with Global names;
  86         --          the CoreTidy pass makes sure these are all and only
  87         --          the externally-accessible ones
  88         -- This truncates the type environment to include only the
  89         -- exported Ids and things needed from them, which saves space
  90         --
  91         -- However, we do keep things like constructors, which should not appear
  92         -- in interface files, because they are needed by importing modules when
  93         -- using the compilation manager
  94     new_type_env = extendTypeEnvList (filterNameEnv keep_it type_env)
  95                                      (map AnId final_ids)
  96
  97         -- We keep constructor workers, because they won't appear
  98         -- in the bindings from which final_ids are derived!
  99     keep_it (AnId id) = hasNoBinding id
 100     keep_it other     = True
 101
 102     stg_id_set = mkVarSet stg_ids
 103     final_ids  = [addStgInfo stg_id_set id | bind <- tidy_binds
 104                                            , id <- bindersOf bind
 105                                            , isGlobalName (idName id)]
 106
 107         -- The complete rules are gotten by combining
 108         --      a) the orphan rules
 109         --      b) rules embedded in the top-level Ids
 110     rule_dcls | opt_OmitInterfacePragmas = []
 111               | otherwise                = getRules orphan_rules tidy_binds (mkVarSet final_ids)
 112
 113 -- This version is used when we are re-linking a module
 114 -- so we've only run the type checker on its previous interface
 115 mkModDetailsFromIface :: TypeEnv
 116                       -> [TypecheckedRuleDecl]
 117                       -> ModDetails
 118 mkModDetailsFromIface type_env rules
 119   = ModDetails { md_types = type_env,
 120                  md_rules = rule_dcls,
 121                  md_insts = dfun_ids }
 122   where
 123     dfun_ids  = [dfun_id | AnId dfun_id <- nameEnvElts type_env, isDictFunId dfun_id]
 124     rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
 125         -- All the rules from an interface are of the IfaceRuleOut form
 126 \end{code}
 127
 128
 129 We have to add on the arity and CAF info computed by the code generator
 130 This is also the moment at which we may forget that this function has
 131 a worker: see the comments below
 132
 133 \begin{code}
 134 addStgInfo :: IdSet     -- Ids used at code-gen time; they have better pragma info!
 135            -> Id -> Id
 136 addStgInfo stg_ids id
 137   = id `setIdInfo` final_idinfo
 138   where
 139     idinfo  = idInfo id
 140     idinfo' = idinfo `setArityInfo` stg_arity
 141                      `setCafInfo`   cafInfo stg_idinfo
 142     final_idinfo | worker_ok = idinfo'
 143                  | otherwise = idinfo' `setWorkerInfo` NoWorker
 144
 145     stg_idinfo = case lookupVarSet stg_ids id of
 146                         Just id' -> idInfo id'
 147                         Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
 148                                     idInfo id
 149
 150     stg_arity = arityInfo stg_idinfo
 151
 152     ------------  Worker  --------------
 153         -- We only treat a function as having a worker if
 154         -- the exported arity (which is now the number of visible lambdas)
 155         -- is the same as the arity at the moment of the w/w split
 156         -- If so, we can safely omit the unfolding inside the wrapper, and
 157         -- instead re-generate it from the type/arity/strictness info
 158         -- But if the arity has changed, we just take the simple path and
 159         -- put the unfolding into the interface file, forgetting the fact
 160         -- that it's a wrapper.
 161         --
 162         -- How can this happen?  Sometimes we get
 163         --      f = coerce t (\x y -> $wf x y)
 164         -- at the moment of w/w split; but the eta reducer turns it into
 165         --      f = coerce t $wf
 166         -- which is perfectly fine except that the exposed arity so far as
 167         -- the code generator is concerned (zero) differs from the arity
 168         -- when we did the split (2).
 169         --
 170         -- All this arises because we use 'arity' to mean "exactly how many
 171         -- top level lambdas are there" in interface files; but during the
 172         -- compilation of this module it means "how many things can I apply
 173         -- this to".
 174     worker_ok = case workerInfo idinfo of
 175                      NoWorker                     -> True
 176                      HasWorker work_id wrap_arity -> wrap_arity == arityLowerBound stg_arity
 177 \end{code}
 178
 179
 180 \begin{code}
 181 getRules :: [IdCoreRule]        -- Orphan rules
 182          -> [CoreBind]          -- Bindings, with rules in the top-level Ids
 183          -> IdSet               -- Ids that are exported, so we need their rules
 184          -> [IdCoreRule]
 185 getRules orphan_rules binds emitted
 186   = orphan_rules ++ local_rules
 187   where
 188     local_rules  = [ (fn, rule)
 189                    | fn <- bindersOfBinds binds,
 190                      fn `elemVarSet` emitted,
 191                      rule <- rulesRules (idSpecialisation fn),
 192                      not (isBuiltinRule rule),
 193                                 -- We can't print builtin rules in interface files
 194                                 -- Since they are built in, an importing module
 195                                 -- will have access to them anyway
 196
 197                         -- Sept 00: I've disabled this test.  It doesn't stop many, if any, rules
 198                         -- from coming out, and to make it work properly we need to add ????
 199                         --      (put it back in for now)
 200                      all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
 201                                 -- Spit out a rule only if all its lhs free vars are emitted
 202                                 -- This is a good reason not to do it when we emit the Id itself
 203                    ]
 204
 205 interestingId id = isId id && isLocalId id
 206 \end{code}
 207
 208
 209 %************************************************************************
 210 %*                                                                      *
 211 \subsection{Completing an interface}
 212 %*                                                                      *
 213 %************************************************************************
 214
 215 \begin{code}
 216 completeIface :: Maybe ModIface         -- The old interface, if we have it
 217               -> ModIface               -- The new one, minus the decls and versions
 218               -> ModDetails             -- The ModDetails for this module
 219               -> (ModIface, Maybe SDoc) -- The new one, complete with decls and versions
 220                                         -- The SDoc is a debug document giving differences
 221                                         -- Nothing => no change
 222
 223         -- NB: 'Nothing' means that even the usages havn't changed, so there's no
 224         --     need to write a new interface file.  But even if the usages have
 225         --     changed, the module version may not have.
 226 completeIface maybe_old_iface new_iface mod_details
 227   = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
 228   where
 229      new_decls   = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
 230      inst_dcls   = map ifaceInstance (md_insts mod_details)
 231      ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types mod_details)
 232      rule_dcls   = map ifaceRule (md_rules mod_details)
 233 \end{code}
 234
 235
 236 \begin{code}
 237 ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
 238 ifaceTyCls (AClass clas) so_far
 239   = cls_decl : so_far
 240   where
 241     cls_decl = ClassDecl { tcdCtxt      = toHsContext sc_theta,
 242                            tcdName      = getName clas,
 243                            tcdTyVars    = toHsTyVars clas_tyvars,
 244                            tcdFDs       = toHsFDs clas_fds,
 245                            tcdSigs      = map toClassOpSig op_stuff,
 246                            tcdMeths     = Nothing,
 247                            tcdSysNames  = sys_names,
 248                            tcdLoc       = noSrcLoc }
 249
 250     (clas_tyvars, clas_fds, sc_theta, sc_sels, op_stuff) = classExtraBigSig clas
 251     tycon     = classTyCon clas
 252     data_con  = head (tyConDataCons tycon)
 253     sys_names = mkClassDeclSysNames (getName tycon, getName data_con,
 254                                      getName (dataConId data_con), map getName sc_sels)
 255
 256     toClassOpSig (sel_id, def_meth)
 257         = ASSERT(sel_tyvars == clas_tyvars)
 258           ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
 259         where
 260           (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
 261           def_meth' = case def_meth of
 262                          NoDefMeth  -> NoDefMeth
 263                          GenDefMeth -> GenDefMeth
 264                          DefMeth id -> DefMeth (getName id)
 265
 266 ifaceTyCls (ATyCon tycon) so_far
 267   | isClassTyCon tycon = so_far
 268   | otherwise          = ty_decl : so_far
 269   where
 270     ty_decl | isSynTyCon tycon
 271             = TySynonym { tcdName   = getName tycon,
 272                           tcdTyVars = toHsTyVars tyvars,
 273                           tcdSynRhs = toHsType syn_ty,
 274                           tcdLoc    = noSrcLoc }
 275
 276             | isAlgTyCon tycon
 277             = TyData {  tcdND     = new_or_data,
 278                         tcdCtxt   = toHsContext (tyConTheta tycon),
 279                         tcdName   = getName tycon,
 280                         tcdTyVars = toHsTyVars tyvars,
 281                         tcdCons   = map ifaceConDecl (tyConDataCons tycon),
 282                         tcdNCons  = tyConFamilySize tycon,
 283                         tcdDerivs = Nothing,
 284                         tcdSysNames  = map getName (tyConGenIds tycon),
 285                         tcdLoc       = noSrcLoc }
 286
 287             | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
 288
 289     tyvars      = tyConTyVars tycon
 290     (_, syn_ty) = getSynTyConDefn tycon
 291     new_or_data | isNewTyCon tycon = NewType
 292                 | otherwise        = DataType
 293
 294     ifaceConDecl data_con
 295         = ConDecl (getName data_con) (getName (dataConId data_con))
 296                   (toHsTyVars ex_tyvars)
 297                   (toHsContext ex_theta)
 298                   details noSrcLoc
 299         where
 300           (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
 301           field_labels   = dataConFieldLabels data_con
 302           strict_marks   = dataConStrictMarks data_con
 303           details | null field_labels
 304                   = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
 305                     VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
 306
 307                   | otherwise
 308                   = RecCon (zipWith mk_field strict_marks field_labels)
 309
 310     mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
 311     mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
 312     mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
 313
 314     mk_field strict_mark field_label
 315         = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
 316
 317 ifaceTyCls (AnId id) so_far
 318   | omitIfaceSigForId id = so_far
 319   | otherwise            = iface_sig : so_far
 320   where
 321     iface_sig = IfaceSig { tcdName   = getName id,
 322                            tcdType   = toHsType id_type,
 323                            tcdIdInfo = hs_idinfo,
 324                            tcdLoc    =  noSrcLoc }
 325
 326     id_type = idType id
 327     id_info = idInfo id
 328
 329     hs_idinfo | opt_OmitInterfacePragmas = []
 330               | otherwise                = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++
 331                                            strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
 332
 333     ------------  Arity  --------------
 334     arity_hsinfo = case arityInfo id_info of
 335                         a@(ArityExactly n) -> [HsArity a]
 336                         other              -> []
 337
 338     ------------ Caf Info --------------
 339     caf_hsinfo = case cafInfo id_info of
 340                    NoCafRefs -> [HsNoCafRefs]
 341                    otherwise -> []
 342
 343     ------------ CPR Info --------------
 344     cpr_hsinfo = case cprInfo id_info of
 345                    ReturnsCPR -> [HsCprInfo]
 346                    NoCPRInfo  -> []
 347
 348     ------------  Strictness  --------------
 349     strict_hsinfo = case strictnessInfo id_info of
 350                         NoStrictnessInfo -> []
 351                         info             -> [HsStrictness info]
 352
 353
 354     ------------  Worker  --------------
 355     work_info   = workerInfo id_info
 356     has_worker  = case work_info of { HasWorker _ _ -> True; other -> False }
 357     wrkr_hsinfo = case work_info of
 358                     HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
 359                     NoWorker                     -> []
 360
 361     ------------  Unfolding  --------------
 362         -- The unfolding is redundant if there is a worker
 363     unfold_info = unfoldingInfo id_info
 364     inline_prag = inlinePragInfo id_info
 365     rhs         = unfoldingTemplate unfold_info
 366     unfold_hsinfo |  neverUnfold unfold_info
 367                   || has_worker = []
 368                   | otherwise   = [HsUnfold inline_prag (toUfExpr rhs)]
 369 \end{code}
 370
 371 \begin{code}
 372 ifaceInstance :: DFunId -> RenamedInstDecl
 373 ifaceInstance dfun_id
 374   = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc
 375   where
 376     tidy_ty = tidyTopType (deNoteType (idType dfun_id))
 377                 -- The deNoteType is very important.   It removes all type
 378                 -- synonyms from the instance type in interface files.
 379                 -- That in turn makes sure that when reading in instance decls
 380                 -- from interface files that the 'gating' mechanism works properly.
 381                 -- Otherwise you could have
 382                 --      type Tibble = T Int
 383                 --      instance Foo Tibble where ...
 384                 -- and this instance decl wouldn't get imported into a module
 385                 -- that mentioned T but not Tibble.
 386
 387 ifaceRule (id, BuiltinRule _)
 388   = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
 389
 390 ifaceRule (id, Rule name bndrs args rhs)
 391   = IfaceRule name (map toUfBndr bndrs) (getName id)
 392               (map toUfExpr args) (toUfExpr rhs) noSrcLoc
 393
 394 bogusIfaceRule id
 395   = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
 396 \end{code}
 397
 398
 399 %************************************************************************
 400 %*                                                                      *
 401 \subsection{Checking if the new interface is up to date
 402 %*                                                                      *
 403 %************************************************************************
 404
 405 \begin{code}
 406 addVersionInfo :: Maybe ModIface                -- The old interface, read from M.hi
 407                -> ModIface                      -- The new interface decls
 408                -> (ModIface, Maybe SDoc)        -- Nothing => no change; no need to write new Iface
 409                                                 -- Just mi => Here is the new interface to write
 410                                                 --            with correct version numbers
 411
 412 -- NB: the fixities, declarations, rules are all assumed
 413 -- to be sorted by increasing order of hsDeclName, so that
 414 -- we can compare for equality
 415
 416 addVersionInfo Nothing new_iface
 417 -- No old interface, so definitely write a new one!
 418   = (new_iface, Just (text "No old interface available"))
 419
 420 addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
 421                                            mi_decls   = old_decls,
 422                                            mi_fixities = old_fixities }))
 423                new_iface@(ModIface { mi_decls = new_decls,
 424                                      mi_fixities = new_fixities })
 425
 426   | no_output_change && no_usage_change
 427   = (new_iface, Nothing)
 428         -- don't return the old iface because it may not have an
 429         -- mi_globals field set to anything reasonable.
 430
 431   | otherwise           -- Add updated version numbers
 432   = --pprTrace "completeIface" (ppr (dcl_tycl old_decls))
 433     (final_iface, Just pp_tc_diffs)
 434
 435   where
 436     final_iface = new_iface { mi_version = new_version }
 437     new_version = VersionInfo { vers_module  = bumpVersion no_output_change (vers_module  old_version),
 438                                 vers_exports = bumpVersion no_export_change (vers_exports old_version),
 439                                 vers_rules   = bumpVersion no_rule_change   (vers_rules   old_version),
 440                                 vers_decls   = tc_vers }
 441
 442     no_output_change = no_tc_change && no_rule_change && no_export_change
 443     no_usage_change  = mi_usages old_iface == mi_usages new_iface
 444
 445     no_export_change = mi_exports old_iface == mi_exports new_iface             -- Kept sorted
 446     no_rule_change   = dcl_rules old_decls  == dcl_rules  new_decls             -- Ditto
 447
 448         -- Fill in the version number on the new declarations by looking at the old declarations.
 449         -- Set the flag if anything changes.
 450         -- Assumes that the decls are sorted by hsDeclName.
 451     old_vers_decls = vers_decls old_version
 452     (no_tc_change,  pp_tc_diffs,  tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
 453                                                        (dcl_tycl old_decls) (dcl_tycl new_decls)
 454
 455
 456
 457 diffDecls :: NameEnv Version                            -- Old version map
 458           -> NameEnv Fixity -> NameEnv Fixity           -- Old and new fixities
 459           -> [RenamedTyClDecl] -> [RenamedTyClDecl]     -- Old and new decls
 460           -> (Bool,             -- True <=> no change
 461               SDoc,             -- Record of differences
 462               NameEnv Version)  -- New version
 463
 464 diffDecls old_vers old_fixities new_fixities old new
 465   = diff True empty emptyNameEnv old new
 466   where
 467         -- When seeing if two decls are the same,
 468         -- remember to check whether any relevant fixity has changed
 469     eq_tc  d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
 470     same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
 471
 472     diff ok_so_far pp new_vers []  []      = (ok_so_far, pp, new_vers)
 473     diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods []
 474     diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
 475     diff ok_so_far pp new_vers (od:ods) (nd:nds)
 476         = case od_name `compare` nd_name of
 477                 LT -> diff False (pp $$ only_old od) new_vers ods      (nd:nds)
 478                 GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
 479                 EQ | od `eq_tc` nd -> diff ok_so_far pp                    new_vers  ods nds
 480                    | otherwise     -> diff False     (pp $$ changed od nd) new_vers' ods nds
 481         where
 482           od_name = tyClDeclName od
 483           nd_name = tyClDeclName nd
 484           new_vers' = extendNameEnv new_vers nd_name
 485                                     (bumpVersion False (lookupNameEnv_NF old_vers od_name))
 486
 487     only_old d   = ptext SLIT("Only in old iface:") <+> ppr d
 488     only_new d   = ptext SLIT("Only in new iface:") <+> ppr d
 489     changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
 490                                                          (ptext SLIT("New:") <+> ppr nd))
 491 \end{code}
 492
 493
 494
 495 %************************************************************************
 496 %*                                                                      *
 497 \subsection{Writing an interface file}
 498 %*                                                                      *
 499 %************************************************************************
 500
 501 \begin{code}
 502 writeIface :: FilePath -> ModIface -> IO ()
 503 writeIface hi_path mod_iface
 504   = do  { if_hdl <- openFile hi_path WriteMode
 505         ; printForIface if_hdl from_this_mod (pprIface mod_iface)
 506         ; hClose if_hdl
 507         }
 508   where
 509         -- Print names unqualified if they are from this module
 510     from_this_mod n = nameModule n == this_mod
 511     this_mod = mi_module mod_iface
 512
 513 pprIface :: ModIface -> SDoc
 514 pprIface iface
 515  = vcat [ ptext SLIT("__interface")
 516                 <+> doubleQuotes (ptext opt_InPackage)
 517                 <+> ppr (mi_module iface) <+> ppr (vers_module version_info)
 518                 <+> pp_sub_vers
 519                 <+> (if mi_orphan iface then char '!' else empty)
 520                 <+> int opt_HiVersion
 521                 <+> ptext SLIT("where")
 522
 523         , vcat (map pprExport (mi_exports iface))
 524         , vcat (map pprUsage (mi_usages iface))
 525
 526         , pprFixities (mi_fixities iface) (dcl_tycl decls)
 527         , pprIfaceDecls (vers_decls version_info) decls
 528         , pprDeprecs (mi_deprecs iface)
 529         ]
 530   where
 531     version_info = mi_version iface
 532     decls        = mi_decls iface
 533     exp_vers     = vers_exports version_info
 534     rule_vers    = vers_rules version_info
 535
 536     pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
 537                 | otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
 538 \end{code}
 539
 540 When printing export lists, we print like this:
 541         Avail   f               f
 542         AvailTC C [C, x, y]     C(x,y)
 543         AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
 544
 545 \begin{code}
 546 pprExport :: (ModuleName, Avails) -> SDoc
 547 pprExport (mod, items)
 548  = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
 549   where
 550     pp_avail :: AvailInfo -> SDoc
 551     pp_avail (Avail name)                    = pprOcc name
 552     pp_avail (AvailTC n [])                  = empty
 553     pp_avail (AvailTC n (n':ns)) | n==n'     = pprOcc n             <> pp_export ns
 554                                  | otherwise = pprOcc n <> char '|' <> pp_export (n':ns)
 555
 556     pp_export []    = empty
 557     pp_export names = braces (hsep (map pprOcc names))
 558
 559 pprOcc :: Name -> SDoc  -- Print the occurrence name only
 560 pprOcc n = pprOccName (nameOccName n)
 561 \end{code}
 562
 563
 564 \begin{code}
 565 pprUsage :: ImportVersion Name -> SDoc
 566 pprUsage (m, has_orphans, is_boot, whats_imported)
 567   = hsep [ptext SLIT("import"), ppr m,
 568           pp_orphan, pp_boot,
 569           pp_versions whats_imported
 570     ] <> semi
 571   where
 572     pp_orphan | has_orphans = char '!'
 573               | otherwise   = empty
 574     pp_boot   | is_boot     = char '@'
 575               | otherwise   = empty
 576
 577         -- Importing the whole module is indicated by an empty list
 578     pp_versions NothingAtAll                = empty
 579     pp_versions (Everything v)              = dcolon <+> int v
 580     pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr
 581                                               <+> hsep [ pprOcc n <+> int v | (n,v) <- nvs ]
 582
 583     pp_export_version Nothing  = empty
 584     pp_export_version (Just v) = int v
 585 \end{code}
 586
 587 \begin{code}
 588 pprIfaceDecls version_map decls
 589   = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
 590          , vcat (map ppr_decl (dcl_tycl decls))
 591          , pprRules (dcl_rules decls)
 592          ]
 593   where
 594     ppr_decl d  = ppr_vers d <+> ppr d <> semi
 595
 596         -- Print the version for the decl
 597     ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of
 598                    Nothing -> empty
 599                    Just v  -> int v
 600 \end{code}
 601
 602 \begin{code}
 603 pprFixities fixity_map decls
 604   = hsep [ ppr fix <+> ppr n
 605          | d <- decls,
 606            (n,_) <- tyClDeclNames d,
 607            Just fix <- [lookupNameEnv fixity_map n]] <> semi
 608
 609 pprRules []    = empty
 610 pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]
 611
 612 pprDeprecs NoDeprecs = empty
 613 pprDeprecs deprecs   = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
 614                      where
 615                        guts = case deprecs of
 616                                 DeprecAll txt  -> doubleQuotes (ptext txt)
 617                                 DeprecSome env -> pp_deprecs env
 618
 619 pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
 620                where
 621                  pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ptext txt)
 622 \end{code}