ghc/compiler/main/HscMain.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
   3 %
   4 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
   5
   6 \begin{code}
   7 module HscMain ( hscMain ) where
   8
   9 #include "HsVersions.h"
  10
  11 import IO               ( hPutStr, stderr )
  12 import HsSyn
  13
  14 import RdrHsSyn         ( RdrNameHsModule )
  15 import FastString       ( unpackFS )
  16 import StringBuffer     ( hGetStringBuffer )
  17 import Parser           ( parse )
  18 import Lex              ( PState(..), ParseResult(..) )
  19 import SrcLoc           ( mkSrcLoc )
  20
  21 import Rename           ( renameModule )
  22
  23 import PrelInfo         ( wiredInThings )
  24 import PrelRules        ( builtinRules )
  25 import MkIface          ( writeIface )
  26 import TcModule         ( TcResults(..), typecheckModule )
  27 import Desugar          ( deSugar )
  28 import SimplCore        ( core2core )
  29 import OccurAnal        ( occurAnalyseBinds )
  30 import CoreUtils        ( coreBindsSize )
  31 import CoreTidy         ( tidyCorePgm )
  32 import CoreToStg        ( topCoreBindsToStg )
  33 import StgSyn           ( collectFinalStgBinders )
  34 import SimplStg         ( stg2stg )
  35 import CodeGen          ( codeGen )
  36 import CodeOutput       ( codeOutput )
  37
  38 import Module           ( ModuleName, moduleNameUserString )
  39 import CmdLineOpts
  40 import ErrUtils         ( ghcExit, doIfSet, dumpIfSet )
  41 import UniqSupply       ( mkSplitUniqSupply )
  42
  43 import Outputable
  44 import Char             ( isSpace )
  45 import StgInterp        ( runStgI )
  46 import HscStats         ( ppSourceStats )
  47 \end{code}
  48
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection{The main compiler pipeline}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 \begin{code}
  57 data HscResult
  58    = HscOK   ModDetails              -- new details (HomeSymbolTable additions)
  59              (Maybe ModIface)        -- new iface (if any compilation was done)
  60              (Maybe String)          -- generated stub_h filename (in /tmp)
  61              (Maybe String)          -- generated stub_c filename (in /tmp)
  62              (Maybe ([UnlinkedIBind],ItblEnv)) -- interpreted code, if any
  63              PersistentCompilerState -- updated PCS
  64
  65    | HscFail PersistentCompilerState -- updated PCS
  66         -- no errors or warnings; the individual passes
  67         -- (parse/rename/typecheck) print messages themselves
  68
  69 hscMain
  70   :: DynFlags
  71   -> ModSummary       -- summary, including source filename
  72   -> Maybe ModIFace   -- old interface, if available
  73   -> String           -- file in which to put the output (.s, .hc, .java etc.)
  74   -> HomeSymbolTable            -- for home module ModDetails
  75   -> PersistentCompilerState    -- IN: persistent compiler state
  76   -> IO HscResult
  77
  78 hscMain dflags core_cmds stg_cmds summary maybe_old_iface
  79         output_filename mod_details pcs
  80  = do {
  81       -- ????? source_unchanged :: Bool -- extracted from summary?
  82
  83       (ch_pcs, check_errs, (recomp_reqd, maybe_checked_iface))
  84          <- checkOldIface dflags finder hit hst pcs mod source_unchanged
  85                           maybe_old_iface;
  86       if check_errs then
  87          return (HscFail ch_pcs)
  88       else do {
  89
  90       let no_old_iface = not (isJust maybe_checked_iface)
  91           what_next | recomp_reqd || no_old_iface = hscRecomp
  92                     | otherwise                   = hscNoRecomp
  93
  94       return (what_next dflags core_cmds stg_cmds summary hit hst
  95                         pcs2 maybe_checked_iface)
  96       }}
  97
  98
  99 hscNoRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
 100  = do {
 101       -- we definitely expect to have the old interface available
 102       old_iface = case maybe_old_iface of
 103                      Just old_if -> old_if
 104                      Nothing -> panic "hscNoRecomp:old_iface"
 105
 106       -- CLOSURE
 107       (pcs_cl, closure_errs, cl_hs_decls)
 108          <- closeIfaceDecls dflags finder hit hst pcs old_iface
 109       if closure_errs then
 110          return (HscFail cl_pcs)
 111       else do {
 112
 113       -- TYPECHECK
 114       maybe_tc_result
 115          <- typecheckModule dflags mod pcs_cl hst hit pit cl_hs_decls;
 116       case maybe_tc_result of {
 117          Nothing -> return (HscFail cl_pcs);
 118          Just tc_result -> do {
 119
 120       let pcs_tc        = tc_pcs tc_result
 121           env_tc        = tc_env tc_result
 122           binds_tc      = tc_binds tc_result
 123           local_tycons  = tc_tycons tc_result
 124           local_classes = tc_classes tc_result
 125           local_insts   = tc_insts tc_result
 126           local_rules   = tc_rules tc_result
 127
 128       -- create a new details from the closed, typechecked, old iface
 129       let new_details = mkModDetailsFromIface env_tc local_insts local_rules
 130
 131       return (HscOK final_details
 132                     Nothing -- tells CM to use old iface and linkables
 133                     Nothing Nothing -- foreign export stuff
 134                     Nothing -- ibinds
 135                     pcs_tc)
 136       }}}}
 137
 138
 139 hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
 140  = do {
 141       -- what target are we shooting for?
 142       let toInterp = dopt_HscLang dflags == HscInterpreted;
 143
 144       -- PARSE
 145       maybe_parsed <- myParseModule dflags summary;
 146       case maybe_parsed of {
 147          Nothing -> return (HscFail pcs);
 148          Just rdr_module -> do {
 149
 150       -- RENAME
 151       (pcs_rn, maybe_rn_result)
 152          <- renameModule dflags finder hit hst pcs mod rdr_module;
 153       case maybe_rn_result of {
 154          Nothing -> return (HscFail pcs_rn);
 155          Just (new_iface, rn_hs_decls) -> do {
 156
 157       -- TYPECHECK
 158       maybe_tc_result
 159          <- typecheckModule dflags mod pcs_rn hst hit pit rn_hs_decls;
 160       case maybe_tc_result of {
 161          Nothing -> return (HscFail pcs_rn);
 162          Just tc_result -> do {
 163
 164       let pcs_tc        = tc_pcs tc_result
 165           env_tc        = tc_env tc_result
 166           binds_tc      = tc_binds tc_result
 167           local_tycons  = tc_tycons tc_result
 168           local_classes = tc_classes tc_result
 169           local_insts   = tc_insts tc_result
 170
 171       -- DESUGAR, SIMPLIFY, TIDY-CORE
 172       -- We grab the the unfoldings at this point.
 173       (tidy_binds, orphan_rules, foreign_stuff)
 174          <- dsThenSimplThenTidy dflags mod tc_result ds_uniqs
 175
 176       -- CONVERT TO STG
 177       (stg_binds, cost_centre_info, top_level_ids)
 178          <- myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
 179
 180       -- cook up a new ModDetails now we (finally) have all the bits
 181       let new_details = mkModDetails tc_env local_insts tidy_binds
 182                                      top_level_ids orphan_rules
 183
 184       -- and possibly create a new ModIface
 185       let maybe_final_iface = completeIface maybe_old_iface new_iface new_details
 186
 187       -- do the rest of code generation/emission
 188       (maybe_ibinds, maybe_stub_h_filename, maybe_stub_c_filename)
 189          <- restOfCodeGeneration toInterp
 190                                  this_mod imported_modules cost_centre_info
 191                                  fe_binders tc_env stg_binds
 192
 193       -- and the answer is ...
 194       return (HscOK new_details maybe_final_iface
 195                     maybe_stub_h_filename maybe_stub_c_filename
 196                     maybe_ibinds pcs_tc)
 197       }}}}}}}
 198
 199
 200 myParseModule dflags summary
 201  = do --------------------------  Reader  ----------------
 202       show_pass "Parser"
 203       -- _scc_     "Parser"
 204
 205       let src_filename -- name of the preprocessed source file
 206          = case ms_ppsource summary of
 207               Just (filename, fingerprint) -> filename
 208               Nothing -> pprPanic "myParseModule:summary is not of a source module"
 209                                   (ppr summary)
 210
 211       buf <- hGetStringBuffer True{-expand tabs-} src_filename
 212
 213       let glaexts | dopt Opt_GlasgowExts dflags = 1#
 214                   | otherwise                 = 0#
 215
 216       case parse buf PState{ bol = 0#, atbol = 1#,
 217                              context = [], glasgow_exts = glaexts,
 218                              loc = mkSrcLoc src_filename 1 } of {
 219
 220         PFailed err -> do hPutStrLn stderr (showSDoc err)
 221                           return Nothing
 222         POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) ->
 223
 224       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module)
 225       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 226                            (ppSourceStats False rdr_module)
 227
 228       return (Just rdr_module)
 229
 230
 231 restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info
 232                      foreign_stuff tc_env stg_binds
 233  | toInterp
 234  = return (Nothing, Nothing,
 235            Just (stgToInterpSyn stg_binds local_tycons local_classes))
 236  | otherwise
 237  = do --------------------------  Code generation -------------------------------
 238       show_pass "CodeGen"
 239       -- _scc_     "CodeGen"
 240       abstractC <- codeGen this_mod imported_modules
 241                            cost_centre_info fe_binders
 242                            local_tycons local_classes stg_binds
 243
 244       --------------------------  Code output -------------------------------
 245       show_pass "CodeOutput"
 246       -- _scc_     "CodeOutput"
 247       let (fe_binders, h_code, c_code) = foreign_stuff
 248       (maybe_stub_h_name, maybe_stub_c_name)
 249          <- codeOutput this_mod local_tycons local_classes
 250                        occ_anal_tidy_binds stg_binds2
 251                        c_code h_code abstractC ncg_uniqs
 252
 253       return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
 254  where
 255     local_tycons  = tcEnvTyCons tc_env
 256     local_classes = tcEnvClasses tc_env
 257
 258
 259 dsThenSimplThenTidy dflags mod tc_result
 260 -- make up ds_uniqs here
 261  = do --------------------------  Desugaring ----------------
 262       -- _scc_     "DeSugar"
 263       (desugared, rules, h_code, c_code, fe_binders)
 264          <- deSugar this_mod ds_uniqs tc_result
 265
 266       --------------------------  Main Core-language transformations ----------------
 267       -- _scc_     "Core2Core"
 268       (simplified, orphan_rules)  <- core2core core_cmds desugared rules
 269
 270       -- Do the final tidy-up
 271       (tidy_binds, tidy_orphan_rules)
 272          <- tidyCorePgm this_mod simplified orphan_rules
 273
 274       return (tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
 275
 276
 277 myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
 278  = do let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds
 279
 280       () <- coreBindsSize occ_anal_tidy_binds `seq` return ()
 281       -- TEMP: the above call zaps some space usage allocated by the
 282       -- simplifier, which for reasons I don't understand, persists
 283       -- thoroughout code generation
 284
 285       show_pass "Core2Stg"
 286       -- _scc_     "Core2Stg"
 287       let stg_binds   = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
 288
 289       show_pass "Stg2Stg"
 290       -- _scc_     "Stg2Stg"
 291       (stg_binds2, cost_centre_info) <- stg2stg stg_cmds this_mod st_uniqs stg_binds
 292       let final_ids = collectFinalStgBinders (map fst stg_binds2)
 293
 294       return (stg_binds2, cost_centre_info, final_ids)
 295
 296 #if 0
 297 -- BEGIN old stuff
 298         --------------------------  Reader  ----------------
 299     show_pass "Parser"  >>
 300     _scc_     "Parser"
 301
 302     let src_filename -- name of the preprocessed source file
 303        = case ms_ppsource summary of
 304             Just (filename, fingerprint) -> filename
 305             Nothing -> pprPanic "hscMain:summary is not of a source module"
 306                                 (ppr summary)
 307
 308     buf <- hGetStringBuffer True{-expand tabs-} src_filename
 309
 310     let glaexts | dopt Opt_GlasgowExts dflags = 1#
 311                 | otherwise                   = 0#
 312
 313     case parse buf PState{ bol = 0#, atbol = 1#,
 314                            context = [], glasgow_exts = glaexts,
 315                            loc = mkSrcLoc src_filename 1 } of {
 316
 317         PFailed err -> return (HscErrs pcs (unitBag err) emptyBag)
 318
 319         POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) ->
 320
 321     dumpIfSet (dopt_D_dump_parsed flags) "Parser" (ppr rdr_module) >>
 322
 323     dumpIfSet (dopt_D_source_stats flags) "Source Statistics"
 324         (ppSourceStats False rdr_module)                >>
 325
 326     -- UniqueSupplies for later use (these are the only lower case uniques)
 327     mkSplitUniqSupply 'd'       >>= \ ds_uniqs  -> -- desugarer
 328     mkSplitUniqSupply 'r'       >>= \ ru_uniqs  -> -- rules
 329     mkSplitUniqSupply 'c'       >>= \ c2s_uniqs -> -- core-to-stg
 330     mkSplitUniqSupply 'g'       >>= \ st_uniqs  -> -- stg-to-stg passes
 331     mkSplitUniqSupply 'n'       >>= \ ncg_uniqs -> -- native-code generator
 332
 333         --------------------------  Rename  ----------------
 334     show_pass "Renamer"                         >>
 335     _scc_     "Renamer"
 336
 337     renameModule dflags finder pcs hst rdr_module
 338                                                 >>= \ (pcs_rn, maybe_rn_stuff) ->
 339     case maybe_rn_stuff of {
 340         Nothing ->      -- Hurrah!  Renamer reckons that there's no need to
 341                         -- go any further
 342                         reportCompile mod_name "Compilation NOT required!" >>
 343                         return ();
 344
 345         Just (this_mod, rn_mod,
 346               old_iface, new_iface,
 347               rn_name_supply, fixity_env,
 348               imported_modules) ->
 349                         -- Oh well, we've got to recompile for real
 350
 351
 352         --------------------------  Typechecking ----------------
 353     show_pass "TypeCheck"                               >>
 354     _scc_     "TypeCheck"
 355     typecheckModule dflags mod pcs hst hit pit rn_mod
 356     --                tc_uniqs rn_name_supply
 357     --              fixity_env rn_mod
 358                                                 >>= \ maybe_tc_stuff ->
 359     case maybe_tc_stuff of {
 360         Nothing -> ghcExit 1;   -- Type checker failed
 361
 362         Just (tc_results@(TcResults {tc_tycons  = local_tycons,
 363                                      tc_classes = local_classes,
 364                                      tc_insts   = inst_info })) ->
 365
 366
 367         --------------------------  Desugaring ----------------
 368     _scc_     "DeSugar"
 369     deSugar this_mod ds_uniqs tc_results        >>= \ (desugared, rules, h_code, c_code, fe_binders) ->
 370
 371
 372         --------------------------  Main Core-language transformations ----------------
 373     _scc_     "Core2Core"
 374     core2core core_cmds desugared rules         >>= \ (simplified, orphan_rules) ->
 375
 376         -- Do the final tidy-up
 377     tidyCorePgm this_mod
 378                 simplified orphan_rules         >>= \ (tidy_binds, tidy_orphan_rules) ->
 379
 380         -- Run the occurrence analyser one last time, so that
 381         -- dead binders get dead-binder info.  This is exploited by
 382         -- code generators to avoid spitting out redundant bindings.
 383         -- The occurrence-zapping in Simplify.simplCaseBinder means
 384         -- that the Simplifier nukes useful dead-var stuff especially
 385         -- in case patterns.
 386     let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds in
 387
 388     coreBindsSize occ_anal_tidy_binds `seq`
 389 --      TEMP: the above call zaps some space usage allocated by the
 390 --      simplifier, which for reasons I don't understand, persists
 391 --      thoroughout code generation
 392
 393
 394
 395         --------------------------  Convert to STG code -------------------------------
 396     show_pass "Core2Stg"                        >>
 397     _scc_     "Core2Stg"
 398     let
 399         stg_binds   = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
 400     in
 401
 402         --------------------------  Simplify STG code -------------------------------
 403     show_pass "Stg2Stg"                          >>
 404     _scc_     "Stg2Stg"
 405     stg2stg stg_cmds this_mod st_uniqs stg_binds >>= \ (stg_binds2, cost_centre_info) ->
 406
 407 #ifdef GHCI
 408     runStgI local_tycons local_classes
 409                          (map fst stg_binds2)    >>= \ i_result ->
 410     putStr ("\nANSWER = " ++ show i_result ++ "\n\n")
 411     >>
 412
 413 #else
 414         --------------------------  Interface file -------------------------------
 415         -- Dump instance decls and type signatures into the interface file
 416     _scc_     "Interface"
 417     let
 418         final_ids = collectFinalStgBinders (map fst stg_binds2)
 419     in
 420     writeIface this_mod old_iface new_iface
 421                local_tycons local_classes inst_info
 422                final_ids occ_anal_tidy_binds tidy_orphan_rules          >>
 423
 424
 425         --------------------------  Code generation -------------------------------
 426     show_pass "CodeGen"                         >>
 427     _scc_     "CodeGen"
 428     codeGen this_mod imported_modules
 429             cost_centre_info
 430             fe_binders
 431             local_tycons local_classes
 432             stg_binds2                          >>= \ abstractC ->
 433
 434
 435         --------------------------  Code output -------------------------------
 436     show_pass "CodeOutput"                              >>
 437     _scc_     "CodeOutput"
 438     codeOutput this_mod local_tycons local_classes
 439                occ_anal_tidy_binds stg_binds2
 440                c_code h_code abstractC
 441                ncg_uniqs                                >>
 442
 443
 444         --------------------------  Final report -------------------------------
 445     reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >>
 446
 447 #endif
 448
 449
 450     ghcExit 0
 451     } }
 452   where
 453     -------------------------------------------------------------
 454     -- ****** help functions:
 455
 456     show_pass
 457       = if opt_D_show_passes
 458         then \ what -> hPutStr stderr ("*** "++what++":\n")
 459         else \ what -> return ()
 460 -- END old stuff
 461 #endif
 462 \end{code}
 463
 464
 465 %************************************************************************
 466 %*                                                                      *
 467 \subsection{Initial persistent state}
 468 %*                                                                      *
 469 %************************************************************************
 470
 471 \begin{code}
 472 initPersistentCompilerState :: IO PersistentCompilerState
 473 initPersistentCompilerState
 474 <<<<<<< HscMain.lhs
 475   = do prs <- initPersistentRenamerState
 476        return (
 477         PCS { pcs_PST   = initPackageDetails,
 478               pcs_insts = emptyInstEnv,
 479               pcs_rules = emptyRuleEnv,
 480               pcs_PRS   = initPersistentRenamerState
 481             }
 482         )
 483 =======
 484   = PCS { pcs_PST   = initPackageDetails,
 485           pcs_insts = emptyInstEnv,
 486           pcs_rules = initRules,
 487           pcs_PRS   = initPersistentRenamerState }
 488 >>>>>>> 1.12
 489
 490 initPackageDetails :: PackageSymbolTable
 491 initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings
 492
 493 initPersistentRenamerState :: IO PersistentRenamerState
 494   = do ns <- mkSplitUniqSupply 'r'
 495        return (
 496         PRS { prsOrig  = Orig { origNames  = initOrigNames,
 497                                origIParam = emptyFM },
 498               prsDecls = emptyNameEnv,
 499               prsInsts = emptyBag,
 500               prsRules = emptyBag,
 501               prsNS    = ns
 502             }
 503         )
 504
 505 initOrigNames :: FiniteMap (ModuleName,OccName) Name
 506 initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
 507               where
 508                 grab names   = foldl add emptyFM names
 509                 add env name = addToFM env (moduleName (nameModule name), nameOccName name) name
 510
 511
 512 initRules :: RuleEnv
 513 initRules = foldl add emptyVarEnv builtinRules
 514           where
 515             add env (name,rule) = extendNameEnv_C add1 env name [rule]
 516             add1 rules _        = rule : rules
 517 \end{code}
 518
 519
 520
 521 \begin{code}
 522 writeIface this_mod old_iface new_iface
 523            local_tycons local_classes inst_info
 524            final_ids tidy_binds tidy_orphan_rules
 525   =
 526     if isNothing opt_HiDir && isNothing opt_HiFile
 527         then return ()  -- not producing any .hi file
 528         else
 529
 530     let
 531         hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
 532         filename = case opt_HiFile of {
 533                         Just f  -> f;
 534                         Nothing ->
 535                    case opt_HiDir of {
 536                         Just dir -> dir ++ '/':moduleUserString this_mod
 537                                         ++ '.':hi_suf;
 538                         Nothing  -> panic "writeIface"
 539                 }}
 540     in
 541
 542     do maybe_final_iface <- checkIface old_iface full_new_iface
 543        case maybe_final_iface of {
 544           Nothing -> when opt_D_dump_rn_trace $
 545                      putStrLn "Interface file unchanged" ;  -- No need to update .hi file
 546
 547           Just final_iface ->
 548
 549        do  let mod_vers_unchanged = case old_iface of
 550                                       Just iface -> pi_vers iface == pi_vers final_iface
 551                                       Nothing -> False
 552            when (mod_vers_unchanged && opt_D_dump_rn_trace) $
 553                 putStrLn "Module version unchanged, but usages differ; hence need new hi file"
 554
 555            if_hdl <- openFile filename WriteMode
 556            printForIface if_hdl (pprIface final_iface)
 557            hClose if_hdl
 558     }
 559   where
 560     full_new_iface = completeIface new_iface local_tycons local_classes
 561                                              inst_info final_ids tidy_binds
 562                                              tidy_orphan_rules
 563 \end{code}
 564
 565
 566 %************************************************************************
 567 %*                                                                      *
 568 \subsection{Printing the interface}
 569 %*                                                                      *
 570 %************************************************************************
 571
 572 \begin{code}
 573 pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
 574                         pi_usages = usages, pi_exports = exports,
 575                         pi_fixity = (fix_vers, fixities),
 576                         pi_insts = insts, pi_decls = decls,
 577                         pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
 578  = vcat [ ptext SLIT("__interface")
 579                 <+> doubleQuotes (ptext opt_InPackage)
 580                 <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
 581                 <+> (if orphan then char '!' else empty)
 582                 <+> int opt_HiVersion
 583                 <+> ptext SLIT("where")
 584         , vcat (map pprExport exports)
 585         , vcat (map pprUsage usages)
 586         , pprFixities fixities
 587         , vcat [ppr i <+> semi | i <- insts]
 588         , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
 589         , pprRules rules
 590         , pprDeprecs deprecs
 591         ]
 592   where
 593     ppr_vers v | v == initialVersion = empty
 594                | otherwise           = int v
 595     pp_sub_vers
 596         | fix_vers == initialVersion && rule_vers == initialVersion = empty
 597         | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
 598 \end{code}
 599
 600 When printing export lists, we print like this:
 601         Avail   f               f
 602         AvailTC C [C, x, y]     C(x,y)
 603         AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
 604
 605 \begin{code}
 606 pprExport :: ExportItem -> SDoc
 607 pprExport (mod, items)
 608  = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
 609   where
 610     upp_avail :: RdrAvailInfo -> SDoc
 611     upp_avail (Avail name)      = pprOccName name
 612     upp_avail (AvailTC name []) = empty
 613     upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
 614                                 where
 615                                   bang | name `elem` ns = empty
 616                                        | otherwise      = char '|'
 617                                   ns' = filter (/= name) ns
 618
 619     upp_export []    = empty
 620     upp_export names = braces (hsep (map pprOccName names))
 621 \end{code}
 622
 623
 624 \begin{code}
 625 pprUsage :: ImportVersion OccName -> SDoc
 626 pprUsage (m, has_orphans, is_boot, whats_imported)
 627   = hsep [ptext SLIT("import"), pprModuleName m,
 628           pp_orphan, pp_boot,
 629           upp_import_versions whats_imported
 630     ] <> semi
 631   where
 632     pp_orphan | has_orphans = char '!'
 633               | otherwise   = empty
 634     pp_boot   | is_boot     = char '@'
 635               | otherwise   = empty
 636
 637         -- Importing the whole module is indicated by an empty list
 638     upp_import_versions NothingAtAll   = empty
 639     upp_import_versions (Everything v) = dcolon <+> int v
 640     upp_import_versions (Specifically vm vf vr nvs)
 641       = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
 642 \end{code}
 643
 644
 645 \begin{code}
 646 pprFixities []    = empty
 647 pprFixities fixes = hsep (map ppr fixes) <> semi
 648
 649 pprRules []    = empty
 650 pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
 651
 652 pprDeprecs []   = empty
 653 pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
 654                 where
 655                   guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
 656                               | Deprecation ie txt _ <- deps ]
 657 \end{code}
 658
 659