Add a 'status' command.

Cabal/Distribution/PackageDescription/Parse.hs

@@ -63,7 +63,7 @@ import System.Directory (doesFileExist)
 import Control.Monad    (mapM)
 
 import Text.PrettyPrint
-       (vcat, ($$), (<+>), text, render,
+       (vcat, ($$), (<+>), text,
         comma, fsep, nest, ($+$), punctuate)
 
 

Cabal/Distribution/PackageDescription/PrettyPrint.hs

@@ -39,7 +39,7 @@ import Distribution.ModuleName
 
 import Text.PrettyPrint
        (hsep, space, parens, char, nest, isEmpty, ($$), (<+>),
-        colon, text, vcat, ($+$), Doc, render)
+        colon, text, vcat, ($+$), Doc)
 
 import qualified Data.ByteString.Lazy.Char8 as BS.Char8
 

Cabal/Distribution/ParseUtils.hs

@@ -56,7 +56,7 @@ import Distribution.PrettyUtils
 import Language.Haskell.Extension
 
 import Text.PrettyPrint
-    ( Doc, render, style, renderStyle
+    ( Doc, style, renderStyle
     , text, colon, nest, punctuate, comma, sep
     , fsep, hsep, isEmpty, vcat, mode, Mode (..)
     , ($+$), (<+>)

Cabal/Distribution/Simple/GHC.hs

@@ -36,6 +36,7 @@ module Distribution.Simple.GHC (
         getGhcInfo,
         configure,
         getInstalledPackages,
+        checkPackageDBs,
         getInstalledPackagesMonitorFiles,
         getPackageDBContents,
         buildLib, buildExe,
@@ -300,6 +301,17 @@ getInstalledPackages verbosity comp packagedbs progdb = 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
+                -> ProgramDb
+                -> IO [(PackageDB, [String])]
+checkPackageDBs verbosity comp packagedbs progdb = do
+  checkPackageDbStack comp packagedbs
+  sequenceA
+    [ do strs <- HcPkg.check (hcPkgInfo progdb) 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

@@ -24,6 +24,7 @@ module Distribution.Simple.Program.HcPkg (
     hide,
     dump,
     describe,
+    check,
     list,
 
     -- * Program invocations
@@ -269,6 +270,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)
@@ -437,6 +446,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

@@ -105,6 +105,7 @@ module Distribution.Simple.Utils (
         -- * .cabal and .buildinfo files
         defaultPackageDesc,
         findPackageDesc,
+        listPackageDescs,
         tryFindPackageDesc,
         defaultHookedPackageDesc,
         findHookedPackageDesc,
@@ -1270,30 +1271,37 @@ defaultPackageDesc _verbosity = tryFindPackageDesc currentDir
 -- @.cabal@ files.
 findPackageDesc :: FilePath                    -- ^Where to look
                 -> NoCallStackIO (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 -> NoCallStackIO [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

@@ -17,6 +17,8 @@ module Distribution.Text (
   display,
   simpleParse,
   stdParse,
+  render,
+  brokenString
   ) where
 
 import Prelude ()
@@ -41,6 +43,17 @@ defaultStyle = Disp.Style { Disp.mode           = Disp.PageMode
 display :: Text a => a -> String
 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
+
 simpleParse :: Text a => String -> Maybe a
 simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str
                        , all isSpace s ] of

Cabal/doc/installing-packages.rst

@@ -371,6 +371,55 @@ existing sandbox:
     $ cabal --ignore-sandbox install text
     # Installs 'text' in the user package database ('~/.cabal').
 
+Displaying cabal environment information
+----------------------------------------
+
+A cabal environment (the directory containing a package) has a certain
+state.  One example are the flags of the last (successful)
+configuration. The ``cabal status`` command will print a summary over
+several aspects of the environment, such as
+
+* the cabal version;
+
+* the (configured) versions of the compiler and other build-time dependencies;
+
+* the package, its components and the install-plan;
+
+* the (contents of) package-databases, the sandbox etc.
+
+Just ``cabal status`` will display a default selection of information.
+Flags can be used to print specific items only; ``cabal status --all``
+will print the full summary.
+
+Example:
+
+.. code-block:: console
+
+    $ cabal status --compiler
+    Configured compiler:
+      ghc-7.10.3
+
+Full list of options supported by ``cabal status``:
+
+- ``--version`` -- Print the version of this program.
+- ``--versions`` -- List the versions of all known/related programs
+  (e.g. ``ghc`` and ``ghc-pkg``).
+- ``--compiler`` -- Print the currently configured compiler info.
+- ``--package`` -- Print information about the package in the current
+  directory.
+- ``--plan`` -- List all packages in the install plan for the current
+  package. Implies ``--package``.
+- ``--sandbox`` -- Print information about the currently configured sandbox
+  (if any).
+- ``--databases``-- List all packages in the global, local and sandbox
+  package databases
+- ``--check`` -- Check package databases for consistency.
+- ``--all`` -- Include all the above information.
+
+Please note that the output of ``cabal status`` is not intended to be
+machine parseable and should not be expected to be stable across
+versions.
+
 Creating a binary package
 -------------------------
 

cabal-install/Distribution/Client/Freeze.hs

@@ -13,7 +13,8 @@
 -- The cabal freeze command
 -----------------------------------------------------------------------------
 module Distribution.Client.Freeze (
-    freeze, getFreezePkgs
+    freeze, getFreezePkgs,
+    planPackages
   ) where
 
 import Distribution.Client.Config ( SavedConfig(..) )

cabal-install/Distribution/Client/Sandbox.hs

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

cabal-install/Distribution/Client/Setup.hs

@@ -25,13 +25,15 @@ module Distribution.Client.Setup
                         , configureExOptions, reconfigureCommand
     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
     , defaultSolver, defaultMaxBackjumps
+    , defaultFreezeFlags
     , listCommand, ListFlags(..)
     , updateCommand
     , upgradeCommand
     , uninstallCommand
     , infoCommand, InfoFlags(..)
     , fetchCommand, FetchFlags(..)
     , freezeCommand, FreezeFlags(..)
+    , statusCommand, StatusFlags(..)
     , genBoundsCommand
     , getCommand, unpackCommand, GetFlags(..)
     , checkCommand
@@ -176,6 +178,7 @@ globalCommand commands = CommandUI {
           , "register"
           , "sandbox"
           , "exec"
+          , "status"
           ]
         maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
         align str = str ++ replicate (maxlen - length str) ' '
@@ -196,6 +199,7 @@ globalCommand commands = CommandUI {
         , addCmd "install"
         , par
         , addCmd "help"
+        , addCmd "status"
         , addCmd "info"
         , addCmd "list"
         , addCmd "fetch"
@@ -788,6 +792,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
+
+       ]
+  }
+
 genBoundsCommand :: CommandUI FreezeFlags
 genBoundsCommand = CommandUI {
     commandName         = "gen-bounds",