Add "status" command

    The "status" command prints a summary over several
    aspects of a cabal environment, such as the cabal
    and ghc versions, the package and its components,
    the package-databases, the sandbox etc.

Author: Lennart Spitzner

Cabal/Distribution/Simple/Configure.hs

@@ -40,6 +40,7 @@ module Distribution.Simple.Configure (configure,
                                       computeComponentId,
                                       localBuildInfoFile,
                                       getInstalledPackages, getPackageDBContents,
+                                      checkPackageDBs,
                                       configCompiler, configCompilerAux,
                                       configCompilerEx, configCompilerAuxEx,
                                       ccLdOptionsBuildInfo,
@@ -105,7 +106,7 @@ import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.BuildPaths
     ( autogenModulesDir )
 import Distribution.Simple.Utils
-    ( die, warn, info, setupMessage
+    ( die, warn, info, debug, setupMessage
     , createDirectoryIfMissingVerbose, moreRecentFile
     , intercalate, cabalVersion
     , writeFileAtomic
@@ -928,6 +929,29 @@ getInstalledPackages verbosity comp packageDBs progconf = do
     flv -> die $ "don't know how to find the installed packages for "
               ++ display flv
 
+-- | Check the consistency of the given package databases.
+checkPackageDBs :: Verbosity -> Compiler
+                -> PackageDBStack -- ^ The stack of package databases.
+                -> ProgramConfiguration
+                -> IO [(PackageDB, [String])]
+checkPackageDBs verbosity comp packageDBs progconf = do
+  when (null packageDBs) $
+    die $ "No package databases have been specified. If you use "
+       ++ "--package-db=clear, you must follow it with --package-db= "
+       ++ "with 'global', 'user' or a specific file."
+
+  debug verbosity "checking package-db..."
+  case compilerFlavor comp of
+    GHC   -> GHC.checkPackageDBs verbosity comp packageDBs progconf
+    -- GHCJS -> GHCJS.checkPackageDBs verbosity packageDBs progconf
+    -- JHC   -> JHC.checkPackageDBs verbosity packageDBs progconf
+    -- LHC   -> LHC.checkPackageDBs verbosity packageDBs progconf
+    -- UHC   -> UHC.checkPackageDBs verbosity comp packageDBs progconf
+    -- HaskellSuite {} ->
+    --   HaskellSuite.checkPackageDBs verbosity packageDBs progconf
+    flv -> die $ "don't know how to check the packages database for "
+              ++ display flv
+
 -- | Like 'getInstalledPackages', but for a single package DB.
 getPackageDBContents :: Verbosity -> Compiler
                      -> PackageDB -> ProgramConfiguration

Cabal/Distribution/Simple/GHC.hs

@@ -32,7 +32,7 @@
 
 module Distribution.Simple.GHC (
         getGhcInfo,
-        configure, getInstalledPackages, getPackageDBContents,
+        configure, getInstalledPackages, checkPackageDBs, getPackageDBContents,
         buildLib, buildExe,
         replLib, replExe,
         startInterpreter,
@@ -287,6 +287,17 @@ getInstalledPackages verbosity comp packagedbs conf = do
         _  -> index -- No (or multiple) ghc rts package is registered!!
                     -- Feh, whatever, the ghc test suite does some crazy stuff.
 
+-- | Check the consistency of the given package databases.
+checkPackageDBs :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration
+                     -> IO [(PackageDB, [String])]
+checkPackageDBs verbosity comp packagedbs conf = do
+  checkPackageDbEnvVar
+  checkPackageDbStack comp packagedbs
+  sequence
+    [ do strs <- HcPkg.check (hcPkgInfo conf) verbosity packagedb
+         return (packagedb, strs)
+    | packagedb <- packagedbs ]
+
 -- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a
 -- @PackageIndex@. Helper function used by 'getPackageDBContents' and
 -- 'getInstalledPackages'.

Cabal/Distribution/Simple/Program/HcPkg.hs

@@ -21,6 +21,7 @@ module Distribution.Simple.Program.HcPkg (
     hide,
     dump,
     describe,
+    check,
     list,
 
     -- * Program invocations
@@ -57,7 +58,7 @@ import Distribution.Simple.Utils
 import Distribution.Verbosity
          ( Verbosity, deafening, silent )
 import Distribution.Compat.Exception
-         ( catchIO )
+         ( catchIO, catchExit )
 
 import Data.Char
          ( isSpace )
@@ -209,6 +210,14 @@ splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines
                        _:ws -> splitWith p ws
       where (ys,zs) = break p xs
 
+-- | Call @hc-pkg@ to check the consistency of the specified package db.
+check :: HcPkgInfo -> Verbosity -> PackageDB -> IO [String]
+check hpi verbosity packagedb = do
+  fmap lines $ getProgramInvocationOutput
+    verbosity
+    (checkInvocation hpi verbosity packagedb)
+    `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"
+
 mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
 -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
 -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
@@ -373,6 +382,17 @@ dumpInvocation hpi _verbosity packagedb =
            -- We use verbosity level 'silent' because it is important that we
            -- do not contaminate the output with info/debug messages.
 
+checkInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
+checkInvocation hpi _verbosity packagedb =
+    (programInvocation (hcPkgProgram hpi) args) {
+      progInvokeOutputEncoding = IOEncodingUTF8
+    }
+  where
+    args = ["check", packageDbOpts hpi packagedb]
+        ++ verbosityOpts hpi silent
+           -- We use verbosity level 'silent' because it is important that we
+           -- do not contaminate the output with info/debug messages.
+
 listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
 listInvocation hpi _verbosity packagedb =
     (programInvocation (hcPkgProgram hpi) args) {

Cabal/Distribution/Simple/Utils.hs

@@ -98,6 +98,7 @@ module Distribution.Simple.Utils (
         -- * .cabal and .buildinfo files
         defaultPackageDesc,
         findPackageDesc,
+        listPackageDescs,
         tryFindPackageDesc,
         defaultHookedPackageDesc,
         findHookedPackageDesc,
@@ -1183,30 +1184,37 @@ defaultPackageDesc _verbosity = tryFindPackageDesc currentDir
 -- @.cabal@ files.
 findPackageDesc :: FilePath                    -- ^Where to look
                 -> IO (Either String FilePath) -- ^<pkgname>.cabal
-findPackageDesc dir
- = do files <- getDirectoryContents dir
-      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
-      -- file we filter to exclude dirs and null base file names:
-      cabalFiles <- filterM doesFileExist
-                       [ dir </> file
-                       | file <- files
-                       , let (name, ext) = splitExtension file
-                       , not (null name) && ext == ".cabal" ]
-      case cabalFiles of
-        []          -> return (Left  noDesc)
-        [cabalFile] -> return (Right cabalFile)
-        multiple    -> return (Left  $ multiDesc multiple)
-
+findPackageDesc dir = do
+  cabalFiles <- listPackageDescs dir
+  case cabalFiles of
+    []          -> return (Left  noDesc)
+    [cabalFile] -> return (Right cabalFile)
+    multiple    -> return (Left  $ multiDesc multiple)
   where
     noDesc :: String
     noDesc = "No cabal file found.\n"
              ++ "Please create a package description file <pkgname>.cabal"
-
     multiDesc :: [String] -> String
     multiDesc l = "Multiple cabal files found.\n"
                   ++ "Please use only one of: "
                   ++ intercalate ", " l
 
+-- | List all package descriptions in the given directory.
+-- 
+-- In contrast to 'findPackageDesc', finding more than one
+-- package description is possible and does not lead
+-- to an error/'Left' value.
+listPackageDescs :: FilePath -> IO [FilePath]
+listPackageDescs dir = do
+  files <- getDirectoryContents dir
+  -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
+  -- file we filter to exclude dirs and null base file names:
+  filterM doesFileExist
+    [ dir </> file
+    | file <- files
+    , let (name, ext) = splitExtension file
+    , not (null name) && ext == ".cabal" ]
+
 -- |Like 'findPackageDesc', but calls 'die' in case of error.
 tryFindPackageDesc :: FilePath -> IO FilePath
 tryFindPackageDesc dir = either die return =<< findPackageDesc dir

Cabal/Distribution/Text.hs

@@ -15,6 +15,8 @@ module Distribution.Text (
   Text(..),
   display,
   simpleParse,
+  render,
+  brokenString
   ) where
 
 import qualified Distribution.Compat.ReadP as Parse
@@ -27,13 +29,27 @@ class Text a where
   disp  :: a -> Disp.Doc
   parse :: Parse.ReadP r a
 
+-- | Display a 'Text' value with the Cabal default style.
 display :: Text a => a -> String
-display = Disp.renderStyle style . disp
-  where style = Disp.Style {
-          Disp.mode            = Disp.PageMode,
-          Disp.lineLength      = 79,
-          Disp.ribbonsPerLine  = 1.0
-        }
+display = Disp.renderStyle defaultStyle . disp
+
+-- | similar to Disp.render, but using the Cabal default style
+--   (which is different from Text.Prettyprint default).
+render :: Disp.Doc -> String
+render = Disp.renderStyle defaultStyle
+
+-- | Takes a string, and turns it into a paragraph-like
+--   Doc, i.e. an fsep of the words in it. Main purpose is
+--   to produce indented paragraphs.
+brokenString :: String -> Disp.Doc
+brokenString s = Disp.fsep $ fmap Disp.text $ words s
+
+defaultStyle :: Disp.Style
+defaultStyle = Disp.Style
+  { Disp.mode            = Disp.PageMode
+  , Disp.lineLength      = 79  -- Disp default: 100
+  , Disp.ribbonsPerLine  = 1.0 -- Disp default: 1.5
+  }
 
 simpleParse :: Text a => String -> Maybe a
 simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str

Cabal/changelog

@@ -17,6 +17,7 @@
 	  program to detect that is connected to a terminal, and works
 	  reliable with a non-threaded runtime (#2911, and serves as a
 	  work-around for #2398)
+	* Add command 'status'
 
 1.22.0.0 Johan Tibell <[email protected]> January 2015
 	* Support GHC 7.10.

cabal-install/Distribution/Client/Freeze.hs

@@ -14,6 +14,7 @@
 -----------------------------------------------------------------------------
 module Distribution.Client.Freeze (
     freeze,
+    planPackages
   ) where
 
 import Distribution.Client.Config ( SavedConfig(..) )

cabal-install/Distribution/Client/Sandbox.hs

@@ -20,6 +20,7 @@ module Distribution.Client.Sandbox (
     withSandboxBinDirOnSearchPath,
 
     getSandboxConfigFilePath,
+    tryLoadSandboxConfig,
     loadConfigOrSandboxConfig,
     findSavedDistPref,
     initPackageDBIfNeeded,

cabal-install/Distribution/Client/Setup.hs

@@ -19,13 +19,15 @@ module Distribution.Client.Setup
     , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)
     , replCommand, testCommand, benchmarkCommand
     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
+    , defaultFreezeFlags
     , listCommand, ListFlags(..)
     , updateCommand
     , upgradeCommand
     , uninstallCommand
     , infoCommand, InfoFlags(..)
     , fetchCommand, FetchFlags(..)
     , freezeCommand, FreezeFlags(..)
+    , statusCommand, StatusFlags(..)
     , getCommand, unpackCommand, GetFlags(..)
     , checkCommand
     , formatCommand
@@ -196,6 +198,7 @@ globalCommand commands = CommandUI {
           , "register"
           , "sandbox"
           , "exec"
+          , "status"
           ]
         maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
         align str = str ++ replicate (maxlen - length str) ' '
@@ -216,6 +219,7 @@ globalCommand commands = CommandUI {
         , addCmd "install"
         , par
         , addCmd "help"
+        , addCmd "status"
         , addCmd "info"
         , addCmd "list"
         , addCmd "fetch"
@@ -810,6 +814,105 @@ freezeCommand = CommandUI {
 
   }
 
+-- ------------------------------------------------------------
+-- * Status command
+-- ------------------------------------------------------------
+
+data StatusFlags = StatusFlags {
+    statusVersion       :: Flag Bool,
+    statusProgVersions  :: Flag Bool,
+    statusCompiler      :: Flag Bool,
+    statusPackage       :: Flag Bool,
+    statusPlan          :: Flag Bool,
+    statusSandbox       :: Flag Bool,
+    statusPkgDbs        :: Flag Bool,
+    statusCheckDb       :: Flag Bool,
+    statusAll           :: Flag Bool,
+    statusVerbosity     :: Flag Verbosity
+  }
+
+defaultStatusFlags :: StatusFlags
+defaultStatusFlags = StatusFlags {
+    statusVersion      = toFlag False,
+    statusProgVersions = toFlag False,
+    statusCompiler     = toFlag False,
+    statusPackage      = toFlag False,
+    statusPlan         = toFlag False,
+    statusSandbox      = toFlag False,
+    statusPkgDbs       = toFlag False,
+    statusCheckDb      = toFlag False,
+    statusAll          = toFlag False,
+    statusVerbosity    = toFlag normal
+  }
+
+statusCommand :: CommandUI StatusFlags
+statusCommand = CommandUI {
+    commandName         = "status",
+    commandSynopsis     = "Show various cabal/packagedb-related information.",
+    commandUsage        = usageAlternatives "status" [ "[FLAGS]" ],
+    commandDescription  = Just $ \_ -> wrapText $
+          "A summary of the state of your cabal environment (for the local"
+       ++ " folder). Shows all, or a subset of: Various program versions,"
+       ++ " information about the local package (if present),"
+       ++ " the sandbox (if present), and the package-databases"
+       ++ " in use (and their contents and consistency).",
+    commandNotes        = Nothing,
+    commandDefaultFlags = defaultStatusFlags,
+    commandOptions      = \ _showOrParseArgs -> [
+         optionVerbosity statusVerbosity (\v flags -> flags { statusVerbosity = v })
+
+       , option [] ["version"]
+           "print the version of this program."
+           statusVersion  (\v flags -> flags { statusVersion = v })
+           trueArg
+
+       , option [] ["versions"]
+           "list the versions of all known/related programs"
+           statusProgVersions (\v flags -> flags { statusProgVersions = v })
+           trueArg
+
+       , option [] ["compiler"]
+           "print the currently configured compiler info"
+           statusCompiler (\v flags -> flags { statusCompiler = v })
+           trueArg
+
+       , option [] ["package"]
+           (wrapText $ "print information about the package in the"
+                    ++ " current directory")
+           statusPackage (\v flags -> flags { statusPackage = v })
+           trueArg
+
+       , option [] ["plan"]
+           (wrapText $ "list all packages in the install plan for the current"
+                   ++  " package. Implies --package.")
+           statusPlan (\v flags -> flags { statusPlan = v })
+           trueArg
+
+       , option [] ["sandbox"]
+           (wrapText $ "print if there is a configured sandbox, and"
+                    ++ " information about it.")
+           statusSandbox (\v flags -> flags { statusSandbox = v })
+           trueArg
+
+       , option [] ["databases"]
+           (wrapText $ "list all the packages in the global, local"
+                    ++ " and sandbox package databases")
+           statusPkgDbs (\v flags -> flags { statusPkgDbs = v })
+           trueArg
+
+       , option [] ["check"]
+           "check package-databases for consistency"
+           statusCheckDb (\v flags -> flags { statusCheckDb = v })
+           trueArg
+
+       , option [] ["all"]
+           "include all the information"
+           statusAll (\v flags -> flags { statusAll = v })
+           trueArg
+
+       ]
+  }
+
 -- ------------------------------------------------------------
 -- * Other commands
 -- ------------------------------------------------------------