X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=bf5857eafdd09475dc638d5e1d626d42999e1dcd;hb=2ffefc1bfca0c8924825cd15750e7ced457f3c81;hp=2b64b83638565580ecbe0ce2998ac89a8174c842;hpb=b9827234d7a401a674981e3766b243affd70b14b;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 2b64b83..bf5857e 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -4,27 +4,29 @@ \section[GHC_Main]{Main driver for Glasgow Haskell compiler} \begin{code} -module HscMain ( hscMain ) where +module HscMain ( HscResult(..), hscMain, + initPersistentCompilerState ) where #include "HsVersions.h" -import Monad ( when ) -import IO ( hPutStr, hClose, stderr, openFile, IOMode(..) ) +import Maybe ( isJust ) +import IO ( hPutStr, hPutStrLn, stderr ) import HsSyn -import RdrHsSyn ( RdrNameHsModule ) -import FastString ( unpackFS ) import StringBuffer ( hGetStringBuffer ) import Parser ( parse ) import Lex ( PState(..), ParseResult(..) ) import SrcLoc ( mkSrcLoc ) -import Rename ( renameModule, checkOldIface ) - -import PrelInfo ( wiredInThings ) +import Rename ( renameModule, checkOldIface, closeIfaceDecls ) +import Rules ( emptyRuleBase ) +import PrelInfo ( wiredInThingEnv, wiredInThings ) +import PrelNames ( knownKeyNames ) import PrelRules ( builtinRules ) -import MkIface ( completeIface, mkModDetailsFromIface ) +import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails, + writeIface ) import TcModule ( TcResults(..), typecheckModule ) +import InstEnv ( emptyInstEnv ) import Desugar ( deSugar ) import SimplCore ( core2core ) import OccurAnal ( occurAnalyseBinds ) @@ -36,29 +38,29 @@ import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CodeOutput ( codeOutput ) -import Module ( ModuleName, moduleNameUserString, - moduleUserString, moduleName ) +import Module ( ModuleName, moduleName, mkModuleInThisPackage ) import CmdLineOpts -import ErrUtils ( ghcExit, doIfSet, dumpIfSet ) +import ErrUtils ( dumpIfSet_dyn ) +import Util ( unJust ) import UniqSupply ( mkSplitUniqSupply ) import Bag ( emptyBag ) import Outputable -import Char ( isSpace ) import StgInterp ( stgToInterpSyn ) import HscStats ( ppSourceStats ) -import HscTypes ( ModDetails, ModIface, PersistentCompilerState(..), - PersistentRenamerState(..), WhatsImported(..), - HomeSymbolTable, PackageSymbolTable, ImportVersion, - GenAvailInfo(..), RdrAvailInfo, OrigNameEnv(..), - PackageRuleBase ) -import RnMonad ( ExportItem, ParsedIface(..) ) -import CmSummarise ( ModSummary ) +import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), + PersistentRenamerState(..), ModuleLocation(..), + HomeSymbolTable, + OrigNameEnv(..), PackageRuleBase, HomeIfaceTable, + typeEnvClasses, typeEnvTyCons, emptyIfaceTable ) import InterpSyn ( UnlinkedIBind ) import StgInterp ( ItblEnv ) import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) -import OccName ( OccName, pprOccName ) -import Name ( Name, nameModule ) +import OccName ( OccName ) +import Name ( Name, nameModule, nameOccName, getName ) +import Name ( emptyNameEnv ) +import Module ( Module, lookupModuleEnvByName ) + \end{code} @@ -82,68 +84,66 @@ data HscResult -- (parse/rename/typecheck) print messages themselves hscMain - :: DynFlags - -> ModSummary -- summary, including source filename - -> Maybe ModIface -- old interface, if available - -> String -- file in which to put the output (.s, .hc, .java etc.) + :: DynFlags + -> Bool -- source unchanged? + -> ModuleLocation -- location info + -> Maybe ModIface -- old interface, if available -> HomeSymbolTable -- for home module ModDetails + -> HomeIfaceTable -> PersistentCompilerState -- IN: persistent compiler state -> IO HscResult -hscMain dflags core_cmds stg_cmds summary maybe_old_iface - output_filename mod_details pcs +hscMain dflags source_unchanged location maybe_old_iface hst hit pcs = do { - -- ????? source_unchanged :: Bool -- extracted from summary? - - (ch_pcs, check_errs, (recomp_reqd, maybe_checked_iface)) - <- checkOldIface dflags finder hit hst pcs mod source_unchanged - maybe_old_iface; + putStrLn "CHECKING OLD IFACE"; + (pcs_ch, check_errs, (recomp_reqd, maybe_checked_iface)) + <- checkOldIface dflags hit hst pcs (unJust (ml_hi_file location) "hscMain") + source_unchanged maybe_old_iface; if check_errs then - return (HscFail ch_pcs) + return (HscFail pcs_ch) else do { let no_old_iface = not (isJust maybe_checked_iface) what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp ; - return (what_next dflags core_cmds stg_cmds summary hit hst - pcs2 maybe_checked_iface) + what_next dflags location maybe_checked_iface + hst hit pcs_ch }} -hscNoRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface +hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch = do { + hPutStrLn stderr "COMPILATION NOT REQUIRED"; -- we definitely expect to have the old interface available - let old_iface = case maybe_old_iface of + let old_iface = case maybe_checked_iface of Just old_if -> old_if Nothing -> panic "hscNoRecomp:old_iface" + this_mod = mi_module old_iface ; -- CLOSURE (pcs_cl, closure_errs, cl_hs_decls) - <- closeIfaceDecls dflags finder hit hst pcs old_iface ; + <- closeIfaceDecls dflags hit hst pcs_ch old_iface ; if closure_errs then - return (HscFail cl_pcs) + return (HscFail pcs_cl) else do { -- TYPECHECK maybe_tc_result - <- typecheckModule dflags mod pcs_cl hst hit pit cl_hs_decls; + <- typecheckModule dflags this_mod pcs_cl hst hit cl_hs_decls; case maybe_tc_result of { - Nothing -> return (HscFail cl_pcs); + Nothing -> return (HscFail pcs_cl); Just tc_result -> do { - let pcs_tc = tc_pcs tc_result - env_tc = tc_env tc_result - binds_tc = tc_binds tc_result - local_tycons = tc_tycons tc_result - local_classes = tc_classes tc_result - local_insts = tc_insts tc_result - local_rules = tc_rules tc_result + let pcs_tc = tc_pcs tc_result + env_tc = tc_env tc_result + local_insts = tc_insts tc_result + local_rules = tc_rules tc_result ; -- create a new details from the closed, typechecked, old iface let new_details = mkModDetailsFromIface env_tc local_insts local_rules ; - return (HscOK final_details + return (HscOK new_details Nothing -- tells CM to use old iface and linkables Nothing Nothing -- foreign export stuff Nothing -- ibinds @@ -151,78 +151,93 @@ hscNoRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface }}}} -hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface +hscRecomp dflags location maybe_checked_iface hst hit pcs_ch = do { + hPutStrLn stderr "COMPILATION IS REQUIRED"; + -- what target are we shooting for? let toInterp = dopt_HscLang dflags == HscInterpreted ; -- PARSE - maybe_parsed <- myParseModule dflags summary; + maybe_parsed + <- myParseModule dflags (unJust (ml_hspp_file location) "hscRecomp:hspp"); case maybe_parsed of { - Nothing -> return (HscFail pcs); + Nothing -> return (HscFail pcs_ch); Just rdr_module -> do { -- RENAME + let this_mod = mkModuleInThisPackage (hsModuleName rdr_module) + ; + show_pass dflags "Renamer"; (pcs_rn, maybe_rn_result) - <- renameModule dflags finder hit hst pcs mod rdr_module; + <- renameModule dflags hit hst pcs_ch this_mod rdr_module; case maybe_rn_result of { Nothing -> return (HscFail pcs_rn); Just (new_iface, rn_hs_decls) -> do { -- TYPECHECK + show_pass dflags "Typechecker"; maybe_tc_result - <- typecheckModule dflags mod pcs_rn hst hit pit rn_hs_decls; + <- typecheckModule dflags this_mod pcs_rn hst hit rn_hs_decls; case maybe_tc_result of { - Nothing -> return (HscFail pcs_rn); + Nothing -> do { hPutStrLn stderr "Typechecked failed" + ; return (HscFail pcs_rn) } ; Just tc_result -> do { let pcs_tc = tc_pcs tc_result env_tc = tc_env tc_result - binds_tc = tc_binds tc_result - local_tycons = tc_tycons tc_result - local_classes = tc_classes tc_result local_insts = tc_insts tc_result ; -- DESUGAR, SIMPLIFY, TIDY-CORE -- We grab the the unfoldings at this point. (tidy_binds, orphan_rules, foreign_stuff) - <- dsThenSimplThenTidy dflags mod tc_result ds_uniqs + <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod tc_result hst ; -- CONVERT TO STG - (stg_binds, cost_centre_info, top_level_ids) - <- myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds + (stg_binds, oa_tidy_binds, cost_centre_info, top_level_ids) + <- myCoreToStg dflags this_mod tidy_binds ; -- cook up a new ModDetails now we (finally) have all the bits - let new_details = mkModDetails tc_env local_insts tidy_binds + let new_details = mkModDetails env_tc local_insts tidy_binds top_level_ids orphan_rules ; - -- and possibly create a new ModIface - let maybe_final_iface = completeIface maybe_old_iface new_iface new_details + -- and the final interface + final_iface + <- mkFinalIface dflags location maybe_checked_iface new_iface new_details ; -- do the rest of code generation/emission - (maybe_ibinds, maybe_stub_h_filename, maybe_stub_c_filename) - <- restOfCodeGeneration toInterp - this_mod imported_modules cost_centre_info - fe_binders tc_env stg_binds + (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds) + <- restOfCodeGeneration dflags toInterp this_mod + (map ideclName (hsModuleImports rdr_module)) + cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds + hit (pcs_PIT pcs_tc) ; -- and the answer is ... - return (HscOK new_details maybe_final_iface + return (HscOK new_details (Just final_iface) maybe_stub_h_filename maybe_stub_c_filename maybe_ibinds pcs_tc) }}}}}}} -myParseModule dflags summary - = do -------------------------- Reader ---------------- - show_pass "Parser" - -- _scc_ "Parser" - let src_filename -- name of the preprocessed source file - = case ms_ppsource summary of - Just (filename, fingerprint) -> filename - Nothing -> pprPanic - "myParseModule:summary is not of a source module" - (ppr summary) +mkFinalIface dflags location maybe_old_iface new_iface new_details + = case completeIface maybe_old_iface new_iface new_details of + (new_iface, Nothing) -- no change in the interfacfe + -> do if dopt Opt_D_dump_hi_diffs dflags then + printDump (text "INTERFACE UNCHANGED") + else return () + return new_iface + (new_iface, Just sdoc) + -> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "NEW INTERFACE" sdoc + -- Write the interface file + writeIface (unJust (ml_hi_file location) "hscRecomp:hi") new_iface + return new_iface + + +myParseModule dflags src_filename + = do -------------------------- Parser ---------------- + show_pass dflags "Parser" + -- _scc_ "Parser" buf <- hGetStringBuffer True{-expand tabs-} src_filename @@ -231,139 +246,113 @@ myParseModule dflags summary case parse buf PState{ bol = 0#, atbol = 1#, context = [], glasgow_exts = glaexts, - loc = mkSrcLoc src_filename 1 } of { + loc = mkSrcLoc (_PK_ src_filename) 1 } of { PFailed err -> do { hPutStrLn stderr (showSDoc err); return Nothing }; - POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> + POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do { - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; + dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" - (ppSourceStats False rdr_module) - + (ppSourceStats False rdr_module) ; + return (Just rdr_module) - } + }} -restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info - foreign_stuff tc_env stg_binds +restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_info + foreign_stuff env_tc stg_binds oa_tidy_binds + hit pit -- these last two for mapping ModNames to Modules | toInterp - = return (Nothing, Nothing, - Just (stgToInterpSyn stg_binds local_tycons local_classes)) + = do (ibinds,itbl_env) + <- stgToInterpSyn (map fst stg_binds) local_tycons local_classes + return (Nothing, Nothing, Just (ibinds,itbl_env)) + | otherwise = do -------------------------- Code generation ------------------------------- - show_pass "CodeGen" + show_pass dflags "CodeGen" -- _scc_ "CodeGen" - abstractC <- codeGen this_mod imported_modules + abstractC <- codeGen dflags this_mod imported_modules cost_centre_info fe_binders - local_tycons local_classes stg_binds + local_tycons stg_binds -------------------------- Code output ------------------------------- - show_pass "CodeOutput" + show_pass dflags "CodeOutput" -- _scc_ "CodeOutput" - let (fe_binders, h_code, c_code) = foreign_stuff (maybe_stub_h_name, maybe_stub_c_name) - <- codeOutput this_mod local_tycons local_classes - occ_anal_tidy_binds stg_binds2 - c_code h_code abstractC ncg_uniqs + <- codeOutput dflags this_mod local_tycons + oa_tidy_binds stg_binds + c_code h_code abstractC return (maybe_stub_h_name, maybe_stub_c_name, Nothing) where - local_tycons = tcEnvTyCons tc_env - local_classes = tcEnvClasses tc_env - - -dsThenSimplThenTidy dflags mod tc_result --- make up ds_uniqs here + local_tycons = typeEnvTyCons env_tc + local_classes = typeEnvClasses env_tc + imported_modules = map mod_name_to_Module imported_module_names + (fe_binders,h_code,c_code) = foreign_stuff + + mod_name_to_Module :: ModuleName -> Module + mod_name_to_Module nm + = let str_mi = case lookupModuleEnvByName hit nm of + Just mi -> mi + Nothing -> case lookupModuleEnvByName pit nm of + Just mi -> mi + Nothing -> barf nm + in mi_module str_mi + barf nm = pprPanic "mod_name_to_Module: no hst or pst mapping for" + (ppr nm) + + +dsThenSimplThenTidy dflags rule_base this_mod tc_result hst = do -------------------------- Desugaring ---------------- -- _scc_ "DeSugar" + show_pass dflags "DeSugar" + ds_uniqs <- mkSplitUniqSupply 'd' (desugared, rules, h_code, c_code, fe_binders) - <- deSugar this_mod ds_uniqs tc_result + <- deSugar dflags this_mod ds_uniqs hst tc_result -------------------------- Main Core-language transformations ---------------- -- _scc_ "Core2Core" - (simplified, orphan_rules) <- core2core core_cmds desugared rules + show_pass dflags "Core2Core" + (simplified, orphan_rules) + <- core2core dflags rule_base hst desugared rules -- Do the final tidy-up + show_pass dflags "CoreTidy" (tidy_binds, tidy_orphan_rules) - <- tidyCorePgm this_mod simplified orphan_rules + <- tidyCorePgm dflags this_mod simplified orphan_rules return (tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code)) -myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds - = do let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds +myCoreToStg dflags this_mod tidy_binds + = do + c2s_uniqs <- mkSplitUniqSupply 'c' + st_uniqs <- mkSplitUniqSupply 'g' + let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds () <- coreBindsSize occ_anal_tidy_binds `seq` return () -- TEMP: the above call zaps some space usage allocated by the -- simplifier, which for reasons I don't understand, persists -- thoroughout code generation - show_pass "Core2Stg" + show_pass dflags "Core2Stg" -- _scc_ "Core2Stg" let stg_binds = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds - show_pass "Stg2Stg" + show_pass dflags "Stg2Stg" -- _scc_ "Stg2Stg" - (stg_binds2, cost_centre_info) <- stg2stg stg_cmds this_mod st_uniqs stg_binds + (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod st_uniqs stg_binds let final_ids = collectFinalStgBinders (map fst stg_binds2) - return (stg_binds2, cost_centre_info, final_ids) - -#if 0 --- BEGIN old stuff - -- UniqueSupplies for later use (these are the only lower case uniques) - mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer - mkSplitUniqSupply 'r' >>= \ ru_uniqs -> -- rules - mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg - mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes - mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator - - -------------------------- Interface file ------------------------------- - -- Dump instance decls and type signatures into the interface file - _scc_ "Interface" - let - final_ids = collectFinalStgBinders (map fst stg_binds2) - in - writeIface this_mod old_iface new_iface - local_tycons local_classes inst_info - final_ids occ_anal_tidy_binds tidy_orphan_rules >> - - - -------------------------- Code generation ------------------------------- - show_pass "CodeGen" >> - _scc_ "CodeGen" - codeGen this_mod imported_modules - cost_centre_info - fe_binders - local_tycons local_classes - stg_binds2 >>= \ abstractC -> - - - -------------------------- Code output ------------------------------- - show_pass "CodeOutput" >> - _scc_ "CodeOutput" - codeOutput this_mod local_tycons local_classes - occ_anal_tidy_binds stg_binds2 - c_code h_code abstractC - ncg_uniqs >> - - - -------------------------- Final report ------------------------------- - reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >> - - ghcExit 0 - } } - where - ------------------------------------------------------------- - -- ****** help functions: - - show_pass - = if opt_D_show_passes - then \ what -> hPutStr stderr ("*** "++what++":\n") - else \ what -> return () --- END old stuff -#endif + return (stg_binds2, occ_anal_tidy_binds, cost_centre_info, final_ids) + + +show_pass dflags what + = if dopt Opt_D_show_passes dflags + then hPutStr stderr ("*** "++what++":\n") + else return () \end{code} @@ -378,16 +367,14 @@ initPersistentCompilerState :: IO PersistentCompilerState initPersistentCompilerState = do prs <- initPersistentRenamerState return ( - PCS { pcs_PST = initPackageDetails, + PCS { pcs_PIT = emptyIfaceTable, + pcs_PTE = wiredInThingEnv, pcs_insts = emptyInstEnv, - pcs_rules = emptyRuleEnv, + pcs_rules = emptyRuleBase, pcs_PRS = prs } ) -initPackageDetails :: PackageSymbolTable -initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings - initPersistentRenamerState :: IO PersistentRenamerState = do ns <- mkSplitUniqSupply 'r' return ( @@ -401,158 +388,20 @@ initPersistentRenamerState :: IO PersistentRenamerState ) initOrigNames :: FiniteMap (ModuleName,OccName) Name -initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings) - where - grab names = foldl add emptyFM names - add env name = addToFM env (moduleName (nameModule name), nameOccName name) name +initOrigNames + = grab knownKeyNames `plusFM` grab (map getName wiredInThings) + where + grab names = foldl add emptyFM names + add env name + = addToFM env (moduleName (nameModule name), nameOccName name) name initRules :: PackageRuleBase -initRules = foldl add emptyVarEnv builtinRules +initRules = emptyRuleBase +{- SHOULD BE (ish) + foldl add emptyVarEnv builtinRules where - add env (name,rule) = extendNameEnv_C add1 env name [rule] - add1 rules _ = rule : rules + add env (name,rule) + = extendRuleBase env name rule +-} \end{code} - - - -\begin{code} -writeIface this_mod old_iface new_iface - local_tycons local_classes inst_info - final_ids tidy_binds tidy_orphan_rules - = - if isNothing opt_HiDir && isNothing opt_HiFile - then return () -- not producing any .hi file - else - - let - hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf } - filename = case opt_HiFile of { - Just f -> f; - Nothing -> - case opt_HiDir of { - Just dir -> dir ++ '/':moduleUserString this_mod - ++ '.':hi_suf; - Nothing -> panic "writeIface" - }} - in - - do maybe_final_iface <- checkIface old_iface full_new_iface - case maybe_final_iface of { - Nothing -> when opt_D_dump_rn_trace $ - putStrLn "Interface file unchanged" ; -- No need to update .hi file - - Just final_iface -> - - do let mod_vers_unchanged = case old_iface of - Just iface -> pi_vers iface == pi_vers final_iface - Nothing -> False - when (mod_vers_unchanged && opt_D_dump_rn_trace) $ - putStrLn "Module version unchanged, but usages differ; hence need new hi file" - - if_hdl <- openFile filename WriteMode - printForIface if_hdl (pprIface final_iface) - hClose if_hdl - } - where - full_new_iface = completeIface new_iface local_tycons local_classes - inst_info final_ids tidy_binds - tidy_orphan_rules - isNothing = not . isJust -\end{code} - - -%************************************************************************ -%* * -\subsection{Printing the interface} -%* * -%************************************************************************ - -\begin{code} -pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan, - pi_usages = usages, pi_exports = exports, - pi_fixity = (fix_vers, fixities), - pi_insts = insts, pi_decls = decls, - pi_rules = (rule_vers, rules), pi_deprecs = deprecs }) - = vcat [ ptext SLIT("__interface") - <+> doubleQuotes (ptext opt_InPackage) - <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers - <+> (if orphan then char '!' else empty) - <+> int opt_HiVersion - <+> ptext SLIT("where") - , vcat (map pprExport exports) - , vcat (map pprUsage usages) - , pprFixities fixities - , vcat [ppr i <+> semi | i <- insts] - , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls] - , pprRules rules - , pprDeprecs deprecs - ] - where - ppr_vers v | v == initialVersion = empty - | otherwise = int v - pp_sub_vers - | fix_vers == initialVersion && rule_vers == initialVersion = empty - | otherwise = brackets (ppr fix_vers <+> ppr rule_vers) -\end{code} - -When printing export lists, we print like this: - Avail f f - AvailTC C [C, x, y] C(x,y) - AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C - -\begin{code} -pprExport :: ExportItem -> SDoc -pprExport (mod, items) - = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi - where - upp_avail :: RdrAvailInfo -> SDoc - upp_avail (Avail name) = pprOccName name - upp_avail (AvailTC name []) = empty - upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns'] - where - bang | name `elem` ns = empty - | otherwise = char '|' - ns' = filter (/= name) ns - - upp_export [] = empty - upp_export names = braces (hsep (map pprOccName names)) -\end{code} - - -\begin{code} -pprUsage :: ImportVersion OccName -> SDoc -pprUsage (m, has_orphans, is_boot, whats_imported) - = hsep [ptext SLIT("import"), ppr (moduleName m), - pp_orphan, pp_boot, - upp_import_versions whats_imported - ] <> semi - where - pp_orphan | has_orphans = char '!' - | otherwise = empty - pp_boot | is_boot = char '@' - | otherwise = empty - - -- Importing the whole module is indicated by an empty list - upp_import_versions NothingAtAll = empty - upp_import_versions (Everything v) = dcolon <+> int v - upp_import_versions (Specifically vm vf vr nvs) - = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ] -\end{code} - - -\begin{code} -pprFixities [] = empty -pprFixities fixes = hsep (map ppr fixes) <> semi - -pprRules [] = empty -pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")] - -pprDeprecs [] = empty -pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")] - where - guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi - | Deprecation ie txt _ <- deps ] -\end{code} - -