[commit: ghc] master: Simplify package dump for -v4 (b6352c9)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b6352c9912536929537dcebac9d02d4f995c1657/ghc

>---------------------------------------------------------------

commit b6352c9912536929537dcebac9d02d4f995c1657
Author: Edward Z. Yang <ezyang at cs.stanford.edu>
Date:   Sun Jun 22 08:42:56 2014 -0700

    Simplify package dump for -v4
    
    Summary:
    Previously, on -v4  and greater, we dumped out the entire package
    database, including lots of metadata that GHC doesn't really care about,
    and is guaranteed to correspond to the equivalent in the local/global
    package databases on disk.  So, to make this output more useful, on -v4
    we instead just print package IDs, and the exposed and trusted flags
    (E and T, which can be tweaked at runtime).
    
    Signed-off-by: Edward Z. Yang <ezyang at cs.stanford.edu>
    
    Test Plan: successful validate
    
    Reviewers: simonpj
    
    Subscribers: simonmar, relrod
    
    Differential Revision: https://phabricator.haskell.org/D24


>---------------------------------------------------------------

b6352c9912536929537dcebac9d02d4f995c1657
 compiler/main/Packages.lhs | 22 ++++++++++++++++++----
 ghc/Main.hs                |  8 +++++---
 2 files changed, 23 insertions(+), 7 deletions(-)

diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index bb37e44..bb2e048 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -10,7 +10,7 @@ module Packages (
 
         -- * The PackageConfigMap
         PackageConfigMap, emptyPackageConfigMap, lookupPackage,
-        extendPackageConfigMap, dumpPackages,
+        extendPackageConfigMap, dumpPackages, simpleDumpPackages,
 
         -- * Reading the package config, and processing cmdline args
         PackageState(..),
@@ -1080,12 +1080,26 @@ isDllName dflags _this_pkg this_mod name
 -- -----------------------------------------------------------------------------
 -- Displaying packages
 
--- | Show package info on console, if verbosity is >= 3
+-- | Show (very verbose) package info on console, if verbosity is >= 5
 dumpPackages :: DynFlags -> IO ()
-dumpPackages dflags
+dumpPackages = dumpPackages' showInstalledPackageInfo
+
+dumpPackages' :: (InstalledPackageInfo -> String) -> DynFlags -> IO ()
+dumpPackages' showIPI dflags
   = do let pkg_map = pkgIdMap (pkgState dflags)
        putMsg dflags $
-             vcat (map (text . showInstalledPackageInfo
+             vcat (map (text . showIPI
                              . packageConfigToInstalledPackageInfo)
                        (eltsUFM pkg_map))
+
+-- | Show simplified package info on console, if verbosity == 4.
+-- The idea is to only print package id, and any information that might
+-- be different from the package databases (exposure, trust)
+simpleDumpPackages :: DynFlags -> IO ()
+simpleDumpPackages = dumpPackages' showIPI
+    where showIPI ipi = let InstalledPackageId i = installedPackageId ipi
+                            e = if exposed ipi then "E" else " "
+                            t = if trusted ipi then "T" else " "
+                        in e ++ t ++ "  " ++ i
+
 \end{code}
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 86f1af3..2bb156c 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -33,7 +33,7 @@ import InteractiveUI    ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
 import Config
 import Constants
 import HscTypes
-import Packages         ( dumpPackages )
+import Packages         ( dumpPackages, simpleDumpPackages )
 import DriverPhases
 import BasicTypes       ( failed )
 import StaticFlags
@@ -209,8 +209,10 @@ main' postLoadMode dflags0 args flagWarnings = do
   hsc_env <- GHC.getSession
 
         ---------------- Display configuration -----------
-  when (verbosity dflags6 >= 4) $
-        liftIO $ dumpPackages dflags6
+  case verbosity dflags6 of
+    v | v == 4 -> liftIO $ simpleDumpPackages dflags6
+      | v >= 5 -> liftIO $ dumpPackages dflags6
+      | otherwise -> return ()
 
   when (verbosity dflags6 >= 3) $ do
         liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)