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_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     pp_diffs = vcat [pp_tc_diffs,
 455                      pp_change no_export_change "Export list",
 456                      pp_change no_rule_change   "Rules",
 457                      pp_change no_usage_change  "Usages"]
 458     pp_change True  what = empty
 459     pp_change False what = text what <+> ptext SLIT("changed")
 460
 461 diffDecls :: NameEnv Version                            -- Old version map
 462           -> NameEnv Fixity -> NameEnv Fixity           -- Old and new fixities
 463           -> [RenamedTyClDecl] -> [RenamedTyClDecl]     -- Old and new decls
 464           -> (Bool,             -- True <=> no change
 465               SDoc,             -- Record of differences
 466               NameEnv Version)  -- New version
 467
 468 diffDecls old_vers old_fixities new_fixities old new
 469   = diff True empty emptyNameEnv old new
 470   where
 471         -- When seeing if two decls are the same,
 472         -- remember to check whether any relevant fixity has changed
 473     eq_tc  d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
 474     same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
 475
 476     diff ok_so_far pp new_vers []  []      = (ok_so_far, pp, new_vers)
 477     diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods []
 478     diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
 479     diff ok_so_far pp new_vers (od:ods) (nd:nds)
 480         = case od_name `compare` nd_name of
 481                 LT -> diff False (pp $$ only_old od) new_vers ods      (nd:nds)
 482                 GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
 483                 EQ | od `eq_tc` nd -> diff ok_so_far pp                    new_vers  ods nds
 484                    | otherwise     -> diff False     (pp $$ changed od nd) new_vers' ods nds
 485         where
 486           od_name = tyClDeclName od
 487           nd_name = tyClDeclName nd
 488           new_vers' = extendNameEnv new_vers nd_name
 489                                     (bumpVersion False (lookupNameEnv_NF old_vers od_name))
 490
 491     only_old d    = ptext SLIT("Only in old iface:") <+> ppr d
 492     only_new d    = ptext SLIT("Only in new iface:") <+> ppr d
 493     changed od nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr od) $$
 494                                                          (ptext SLIT("New:")  <+> ppr nd))
 495 \end{code}
 496
 497
 498
 499 %************************************************************************
 500 %*                                                                      *
 501 \subsection{Writing an interface file}
 502 %*                                                                      *
 503 %************************************************************************
 504
 505 \begin{code}
 506 writeIface :: FilePath -> ModIface -> IO ()
 507 writeIface hi_path mod_iface
 508   = do  { if_hdl <- openFile hi_path WriteMode
 509         ; printForIface if_hdl from_this_mod (pprIface mod_iface)
 510         ; hClose if_hdl
 511         }
 512   where
 513         -- Print names unqualified if they are from this module
 514     from_this_mod n = nameModule n == this_mod
 515     this_mod = mi_module mod_iface
 516
 517 pprIface :: ModIface -> SDoc
 518 pprIface iface
 519  = vcat [ ptext SLIT("__interface")
 520                 <+> doubleQuotes (ptext opt_InPackage)
 521                 <+> ppr (mi_module iface) <+> ppr (vers_module version_info)
 522                 <+> pp_sub_vers
 523                 <+> (if mi_orphan iface then char '!' else empty)
 524                 <+> int opt_HiVersion
 525                 <+> ptext SLIT("where")
 526
 527         , vcat (map pprExport (mi_exports iface))
 528         , vcat (map pprUsage (mi_usages iface))
 529
 530         , pprFixities (mi_fixities iface) (dcl_tycl decls)
 531         , pprIfaceDecls (vers_decls version_info) decls
 532         , pprDeprecs (mi_deprecs iface)
 533         ]
 534   where
 535     version_info = mi_version iface
 536     decls        = mi_decls iface
 537     exp_vers     = vers_exports version_info
 538     rule_vers    = vers_rules version_info
 539
 540     pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
 541                 | otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
 542 \end{code}
 543
 544 When printing export lists, we print like this:
 545         Avail   f               f
 546         AvailTC C [C, x, y]     C(x,y)
 547         AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
 548
 549 \begin{code}
 550 pprExport :: (ModuleName, Avails) -> SDoc
 551 pprExport (mod, items)
 552  = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
 553   where
 554     pp_avail :: AvailInfo -> SDoc
 555     pp_avail (Avail name)                    = pprOcc name
 556     pp_avail (AvailTC n [])                  = empty
 557     pp_avail (AvailTC n (n':ns)) | n==n'     = pprOcc n             <> pp_export ns
 558                                  | otherwise = pprOcc n <> char '|' <> pp_export (n':ns)
 559
 560     pp_export []    = empty
 561     pp_export names = braces (hsep (map pprOcc names))
 562
 563 pprOcc :: Name -> SDoc  -- Print the occurrence name only
 564 pprOcc n = pprOccName (nameOccName n)
 565 \end{code}
 566
 567
 568 \begin{code}
 569 pprUsage :: ImportVersion Name -> SDoc
 570 pprUsage (m, has_orphans, is_boot, whats_imported)
 571   = hsep [ptext SLIT("import"), ppr m,
 572           pp_orphan, pp_boot,
 573           pp_versions whats_imported
 574     ] <> semi
 575   where
 576     pp_orphan | has_orphans = char '!'
 577               | otherwise   = empty
 578     pp_boot   | is_boot     = char '@'
 579               | otherwise   = empty
 580
 581         -- Importing the whole module is indicated by an empty list
 582     pp_versions NothingAtAll                = empty
 583     pp_versions (Everything v)              = dcolon <+> int v
 584     pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr
 585                                               <+> hsep [ pprOcc n <+> int v | (n,v) <- nvs ]
 586
 587     pp_export_version Nothing  = empty
 588     pp_export_version (Just v) = int v
 589 \end{code}
 590
 591 \begin{code}
 592 pprIfaceDecls version_map decls
 593   = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
 594          , vcat (map ppr_decl (dcl_tycl decls))
 595          , pprRules (dcl_rules decls)
 596          ]
 597   where
 598     ppr_decl d  = ppr_vers d <+> ppr d <> semi
 599
 600         -- Print the version for the decl
 601     ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of
 602                    Nothing -> empty
 603                    Just v  -> int v
 604 \end{code}
 605
 606 \begin{code}
 607 pprFixities fixity_map decls
 608   = hsep [ ppr fix <+> ppr n
 609          | d <- decls,
 610            (n,_) <- tyClDeclNames d,
 611            Just fix <- [lookupNameEnv fixity_map n]] <> semi
 612
 613 pprRules []    = empty
 614 pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]
 615
 616 pprDeprecs NoDeprecs = empty
 617 pprDeprecs deprecs   = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
 618                      where
 619                        guts = case deprecs of
 620                                 DeprecAll txt  -> doubleQuotes (ptext txt)
 621                                 DeprecSome env -> pp_deprecs env
 622
 623 pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
 624                where
 625                  pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ptext txt)
 626 \end{code}