From 497caeee6cb1532cd5ed22089e98463b2211dec5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 23 Feb 2016 21:01:47 +0100 Subject: [PATCH] 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. --- .../Distribution/PackageDescription/Parse.hs | 2 +- .../PackageDescription/PrettyPrint.hs | 2 +- Cabal/Distribution/ParseUtils.hs | 2 +- Cabal/Distribution/Simple/Configure.hs | 24 + Cabal/Distribution/Simple/GHC.hs | 12 + Cabal/Distribution/Simple/Program/HcPkg.hs | 20 + Cabal/Distribution/Simple/Utils.hs | 38 +- Cabal/Distribution/Text.hs | 28 +- Cabal/changelog | 2 +- Cabal/doc/installing-packages.markdown | 27 ++ cabal-install/Distribution/Client/Freeze.hs | 1 + cabal-install/Distribution/Client/Sandbox.hs | 1 + cabal-install/Distribution/Client/Setup.hs | 103 +++++ cabal-install/Distribution/Client/Status.hs | 413 ++++++++++++++++++ cabal-install/Main.hs | 8 + cabal-install/cabal-install.cabal | 1 + 16 files changed, 659 insertions(+), 25 deletions(-) create mode 100644 cabal-install/Distribution/Client/Status.hs diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs index 39fa1f0c0ee..22965e3b7fe 100644 --- a/Cabal/Distribution/PackageDescription/Parse.hs +++ b/Cabal/Distribution/PackageDescription/Parse.hs @@ -67,7 +67,7 @@ import Control.Arrow (first) import System.Directory (doesFileExist) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import Text.PrettyPrint +import Text.PrettyPrint hiding (render) -- ----------------------------------------------------------------------------- diff --git a/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/Cabal/Distribution/PackageDescription/PrettyPrint.hs index 3d31b06a70b..65f57f8fed9 100644 --- a/Cabal/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal/Distribution/PackageDescription/PrettyPrint.hs @@ -28,7 +28,7 @@ import Data.Monoid as Mon (Monoid(mempty)) import Data.Maybe (isJust) import Text.PrettyPrint (hsep, parens, char, nest, empty, isEmpty, ($$), (<+>), - colon, (<>), text, vcat, ($+$), Doc, render) + colon, (<>), text, vcat, ($+$), Doc) -- | Recompile with false for regression testing simplifiedPrinting :: Bool diff --git a/Cabal/Distribution/ParseUtils.hs b/Cabal/Distribution/ParseUtils.hs index d3d649a34d4..f268212a7cf 100644 --- a/Cabal/Distribution/ParseUtils.hs +++ b/Cabal/Distribution/ParseUtils.hs @@ -51,7 +51,7 @@ import Distribution.Text import Distribution.Simple.Utils import Language.Haskell.Extension -import Text.PrettyPrint hiding (braces) +import Text.PrettyPrint hiding (braces, render) import Data.Char (isSpace, toLower, isAlphaNum, isDigit) import Data.Maybe (fromMaybe) import Data.Tree as Tree (Tree(..), flatten) diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index ae4ae4e97b5..d00ead3fa99 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -40,6 +40,7 @@ module Distribution.Simple.Configure (configure, getInstalledPackages, getInstalledPackagesMonitorFiles, getPackageDBContents, + checkPackageDBs, configCompiler, configCompilerAux, configCompilerEx, configCompilerAuxEx, ccLdOptionsBuildInfo, @@ -1051,6 +1052,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. -- -- NB: Why isn't this always a fall through to 'getInstalledPackages'? diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index 5e2a1310f62..60d9048183a 100644 --- a/Cabal/Distribution/Simple/GHC.hs +++ b/Cabal/Distribution/Simple/GHC.hs @@ -36,6 +36,7 @@ module Distribution.Simple.GHC ( getGhcInfo, configure, getInstalledPackages, + checkPackageDBs, getInstalledPackagesMonitorFiles, getPackageDBContents, buildLib, buildExe, @@ -292,6 +293,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'. diff --git a/Cabal/Distribution/Simple/Program/HcPkg.hs b/Cabal/Distribution/Simple/Program/HcPkg.hs index 1d3ee95af89..39f669ef7c0 100644 --- a/Cabal/Distribution/Simple/Program/HcPkg.hs +++ b/Cabal/Distribution/Simple/Program/HcPkg.hs @@ -23,6 +23,7 @@ module Distribution.Simple.Program.HcPkg ( hide, dump, describe, + check, list, -- * Program invocations @@ -264,6 +265,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) @@ -432,6 +441,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) { diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs index 87338e8d4c3..f69290dc494 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/Cabal/Distribution/Simple/Utils.hs @@ -103,6 +103,7 @@ module Distribution.Simple.Utils ( -- * .cabal and .buildinfo files defaultPackageDesc, findPackageDesc, + listPackageDescs, tryFindPackageDesc, defaultHookedPackageDesc, findHookedPackageDesc, @@ -1224,30 +1225,37 @@ defaultPackageDesc _verbosity = tryFindPackageDesc currentDir -- @.cabal@ files. findPackageDesc :: FilePath -- ^Where to look -> IO (Either String FilePath) -- ^.cabal -findPackageDesc dir - = do files <- getDirectoryContents dir - -- to make sure we do not mistake a ~/.cabal/ dir for a .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 .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 .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 diff --git a/Cabal/Distribution/Text.hs b/Cabal/Distribution/Text.hs index 236f4804900..8ad9fb0c2ec 100644 --- a/Cabal/Distribution/Text.hs +++ b/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 diff --git a/Cabal/changelog b/Cabal/changelog index 753edfa649d..f5e59ae97df 100644 --- a/Cabal/changelog +++ b/Cabal/changelog @@ -1,7 +1,7 @@ -*-change-log-*- 1.25.x.x (current development version) - * No changes yet. + * Add command 'status' 1.24.0.0 Ryan Thomas February 2016 * Support GHC 8. diff --git a/Cabal/doc/installing-packages.markdown b/Cabal/doc/installing-packages.markdown index fbb995d31dc..88f0ea5e95d 100644 --- a/Cabal/doc/installing-packages.markdown +++ b/Cabal/doc/installing-packages.markdown @@ -349,6 +349,33 @@ $ 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: + +~~~~~~~~~~~~~~~ +$ cabal status --compiler +Configured compiler: + ghc-7.10.3 +~~~~~~~~~~~~~~~ + ## Creating a binary package ## When creating binary packages (e.g. for Red Hat or Debian) one needs to diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs index 5f61996fc5f..ee04fbe27c5 100644 --- a/cabal-install/Distribution/Client/Freeze.hs +++ b/cabal-install/Distribution/Client/Freeze.hs @@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- module Distribution.Client.Freeze ( freeze, + planPackages ) where import Distribution.Client.Config ( SavedConfig(..) ) diff --git a/cabal-install/Distribution/Client/Sandbox.hs b/cabal-install/Distribution/Client/Sandbox.hs index 382d87cad05..0db246425da 100644 --- a/cabal-install/Distribution/Client/Sandbox.hs +++ b/cabal-install/Distribution/Client/Sandbox.hs @@ -20,6 +20,7 @@ module Distribution.Client.Sandbox ( withSandboxBinDirOnSearchPath, getSandboxConfigFilePath, + tryLoadSandboxConfig, loadConfigOrSandboxConfig, findSavedDistPref, initPackageDBIfNeeded, diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index ec106bdc2f2..44163a6e78d 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -24,6 +24,7 @@ module Distribution.Client.Setup , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , replCommand, testCommand, benchmarkCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags + , defaultFreezeFlags , listCommand, ListFlags(..) , updateCommand , upgradeCommand @@ -31,6 +32,7 @@ module Distribution.Client.Setup , infoCommand, InfoFlags(..) , fetchCommand, FetchFlags(..) , freezeCommand, FreezeFlags(..) + , statusCommand, StatusFlags(..) , getCommand, unpackCommand, GetFlags(..) , checkCommand , formatCommand @@ -173,6 +175,7 @@ globalCommand commands = CommandUI { , "register" , "sandbox" , "exec" + , "status" ] maxlen = maximum $ [length name | (name, _) <- cmdDescs] align str = str ++ replicate (maxlen - length str) ' ' @@ -193,6 +196,7 @@ globalCommand commands = CommandUI { , addCmd "install" , par , addCmd "help" + , addCmd "status" , addCmd "info" , addCmd "list" , addCmd "fetch" @@ -763,6 +767,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 -- ------------------------------------------------------------ diff --git a/cabal-install/Distribution/Client/Status.hs b/cabal-install/Distribution/Client/Status.hs new file mode 100644 index 00000000000..19f82289ca2 --- /dev/null +++ b/cabal-install/Distribution/Client/Status.hs @@ -0,0 +1,413 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Status +-- Copyright : (c) Lennart Spitzner 2015 +-- License : BSD-like +-- +-- Maintainer : lsp@informatik.uni-kiel.de +-- Stability : provisional +-- Portability : portable +-- +-- print a summary of info about +-- - versions used +-- - the package (if present) +-- - package databases +-- - the sandbox (if present) +-- - the install plan +-- +----------------------------------------------------------------------------- +module Distribution.Client.Status ( + status + ) where + +import Distribution.Simple.PackageIndex ( allPackages ) +import Distribution.Simple.Program.Db ( configuredPrograms ) +import Distribution.Simple.Program.Types ( ConfiguredProgram(..) ) +import Distribution.Simple.Configure ( tryGetPersistBuildConfig + , checkPackageDBs ) +import Distribution.Simple.Compiler ( PackageDB(..) + , compilerId ) +import Distribution.Simple.BuildPaths ( exeExtension ) +import Distribution.Simple.Utils ( cabalVersion + , rawSystemStdout + , listPackageDescs + , currentDir + , wrapText + ) +import Distribution.Client.Setup ( StatusFlags(..) + , GlobalFlags(..) + , globalRepos + , defaultFreezeFlags + ) +import Distribution.Client.Config ( defaultCompiler + , SavedConfig(..) + ) +import Distribution.Client.Sandbox ( getSandboxConfigFilePath + , tryLoadSandboxConfig + , loadConfigOrSandboxConfig + , configCompilerAux' + , maybeWithSandboxPackageInfo + , maybeWithSandboxDirOnSearchPath + ) +import Distribution.Client.Sandbox.PackageEnvironment ( sandboxPackageDBPath ) +import Distribution.Client.SetupWrapper ( useDistPref + , defaultSetupScriptOptions ) +import Distribution.Client.Freeze ( planPackages ) +import Distribution.Client.IndexUtils ( getInstalledPackages + , getSourcePackages + ) +import Distribution.Client.HttpUtils ( configureTransport ) +import Distribution.Client.Targets ( resolveUserTargets, UserTarget(..) ) +import Distribution.Client.Types ( SourcePackageDb(..) ) +import Distribution.Text ( simpleParse + , display + , disp + , render + , brokenString + ) +import Distribution.Version ( Version(..) + ) +import Distribution.PackageDescription.Parse ( readPackageDescription ) +import Distribution.PackageDescription ( GenericPackageDescription(..) + , package + ) +import Distribution.InstalledPackageInfo ( InstalledPackageInfo(..) ) +import Distribution.Package +import Distribution.Verbosity + +import qualified Distribution.Simple.Setup as Cabal +import qualified Distribution.Simple.LocalBuildInfo as LBI + +import qualified Paths_cabal_install ( version ) + +import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) +import System.Directory ( doesFileExist ) +import System.FilePath ( splitFileName + , combine + , splitPath + , joinPath + , takeDirectory + , (<.>) + ) +import Control.Monad ( when + , forM + , guard + , forM_ + ) +import Data.Version ( showVersion + ) +import Data.Maybe ( isJust + ) +import Data.List ( groupBy + , sortBy + ) +import Data.Ord ( comparing + ) +import Text.PrettyPrint ( empty + , ($$) + , vcat + , nest + , text + , punctuate + , ($+$) + , (<+>) + ) +import Data.Monoid ( (<>) + ) +import qualified Data.Monoid as Monoid +import Data.List ( inits ) +import Data.Foldable ( asum ) + + + +status :: Verbosity -> GlobalFlags -> StatusFlags -> IO () +status verbosity globalFlags statusFlags = do + (useSandbox, config) <- loadConfigOrSandboxConfig + verbosity + (globalFlags { globalRequireSandbox = Cabal.Flag False }) + (defaultComp, platform, defaultConf) <- configCompilerAux' + $ savedConfigureFlags config + let distPref = useDistPref defaultSetupScriptOptions + -- TODO: this currently only works if the cabal version used for configuring + -- is the same as the one doing the status. would be cool if it would + -- either work or at least indicate this otherwise. + buildConfig <- tryGetPersistBuildConfig distPref + let (comp, conf) = case buildConfig of + Left _ -> (defaultComp, defaultConf) + Right c -> (LBI.compiler c, LBI.withPrograms c) + let globalFlags' = savedGlobalFlags config `Monoid.mappend` globalFlags + sandboxConfigPath <- getSandboxConfigFilePath globalFlags + sandboxConfigExists <- doesFileExist sandboxConfigPath + (sandboxPath, sandboxDbPath) <- if sandboxConfigExists + then do + (sandboxPath, _pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags + return $ ( Just sandboxPath + , Just $ sandboxPackageDBPath sandboxPath comp platform) + else return (Nothing, Nothing) + let dbs :: [PackageDB] -- TODO: it might be better to inspect the currently + -- configured dbs instead of a static global,local,.. + dbs = GlobalPackageDB + : UserPackageDB + : case sandboxDbPath of + Nothing -> [] + Just p -> [SpecificPackageDB p] + let noFlags = not $ any Cabal.fromFlag [ statusVersion statusFlags + , statusProgVersions statusFlags + , statusCompiler statusFlags + , statusPackage statusFlags + , statusPlan statusFlags + , statusSandbox statusFlags + , statusPkgDbs statusFlags + , statusCheckDb statusFlags + , statusAll statusFlags + ] + doAll = Cabal.fromFlag $ statusAll statusFlags + doVersion = Cabal.fromFlag (statusVersion statusFlags) + || doAll || noFlags + doProgVersions = Cabal.fromFlag (statusProgVersions statusFlags) + || doAll + doCompiler = Cabal.fromFlag (statusCompiler statusFlags) + || doAll || noFlags + doPackage = Cabal.fromFlag (statusPackage statusFlags) + || Cabal.fromFlag (statusPlan statusFlags) -- implication + || doAll || noFlags + doPlan = Cabal.fromFlag (statusPlan statusFlags) + || doAll + doSandbox = Cabal.fromFlag (statusSandbox statusFlags) + || doAll || noFlags + doPkgDbs = Cabal.fromFlag (statusPkgDbs statusFlags) + || doAll + doCheckDb = Cabal.fromFlag (statusCheckDb statusFlags) + || doAll + case () of { () -> do + when doVersion printCurrentVersion + -- printOtherCabalCheck is called by printCurrentVersion + when doProgVersions printProgramVersions + when doCompiler printCompiler + when doPackage printPackageInformation + when doSandbox printSandboxInformation + when doPkgDbs printPackageDbs + when doCheckDb printPackageDBChecks + -- printInstallPlan is called by printPackageInformation + where + -- print self version information: + printCurrentVersion :: IO () + -- check if there is a different newer cabal-install installed + -- (with the likely reason of a missing PATH addition): + printOtherCabalCheck :: IO () + -- print external program versions (ghc, ...): + printProgramVersions :: IO () + -- print the configured compiler + printCompiler :: IO () + -- information about the package in the current directory: + printPackageInformation :: IO () + -- print information about the sandbox in the current directory + -- (including a check if a parent directory has a sandbox): + printSandboxInformation :: IO () + -- print which package dbs are currently configured: + printPackageDbs :: IO () + -- ghc-pkg check on the current package dbs (including sandbox, if present) + printPackageDBChecks :: IO () + -- print the install plan (i.e. all configured dependencies); similar + -- to "cabal freeze --dry-run": + printInstallPlan :: IO () + printCurrentVersion = do + putStrLn "Self version:" + putStrLn $ render + $ nest 2 + $ brokenString + $ "cabal-install version " + ++ display Paths_cabal_install.version + ++ " compiled using version " + ++ display cabalVersion + ++ " of the Cabal library." + printOtherCabalCheck + printOtherCabalCheck = do + defInstDirs <- LBI.defaultInstallDirs defaultCompiler True False + let binDir :: FilePath + binDir = LBI.fromPathTemplate + $ LBI.bindir + $ LBI.substituteInstallDirTemplates [] defInstDirs + currentBinDir <- getExecutablePath + when (takeDirectory binDir /= takeDirectory currentBinDir) $ do + let defaultCabalPath = binDir `combine` ("cabal" <.> exeExtension) + exists <- doesFileExist defaultCabalPath + when exists $ do + -- TODO: replace rawSystemStdout by rawSystemStdInOuts + v <- rawSystemStdout verbosity defaultCabalPath ["--version"] + let vs :: [Maybe Version] + vs = map (simpleParse . filter (\x -> x `elem` "0123456789.")) + $ lines v + case vs of + [Just cabalInstallVersion, Just _cabalVersion] -> + if cabalInstallVersion == Paths_cabal_install.version + then return () + else putStrLn $ render + $ nest 2 + $ brokenString + $ " There is a different 'cabal' executable" + ++ " (version " + ++ showVersion cabalInstallVersion + ++ ") located in " ++ binDir + ++ "." + _ -> putStrLn $ render + $ nest 2 + $ brokenString + $ wrapText + $ " Warning: could not parse version of" + ++ " the `cabal` executable located in " + ++ binDir + ++ "." + return () + printProgramVersions = do + putStrLn "Program versions:" + flip mapM_ (configuredPrograms conf) $ \cp -> + case programVersion cp of + Nothing -> return () + Just v -> putStrLn + $ render + $ nest 2 + $ text (programId cp) + <> text "-" + <> disp v + printCompiler = do + putStrLn "Configured compiler:" + case buildConfig of + Left _ -> putStrLn $ " Could not be determined." + Right lbi -> putStrLn $ " " ++ (display $ compilerId $ LBI.compiler lbi) + printPackageInformation = do + putStrLn "Local package(s):" + packageDescs <- listPackageDescs currentDir + case packageDescs of + [] -> putStrLn " No packages in the current directory." + [p] -> do + ppd <- readPackageDescription verbosity p + let packageDesc = packageDescription $ ppd + let packName :: String + packName = unPackageName $ pkgName $ package $ packageDesc + let components :: [String] + components = + ( [ "Library \"" ++ packName ++ "\"" + | isJust (condLibrary ppd) ] + ++ [ "Executable \"" ++ fst e ++ "\"" + | e <- condExecutables ppd] + ++ [ "Testsuite \"" ++ fst t ++ "\"" + | t <- condTestSuites ppd] + ++ [ "Benchmark \"" ++ fst b ++ "\"" + | b <- condBenchmarks ppd] + ) + putStrLn $ render + $ nest 2 + $ text ("Package \"" ++ packName ++ "\" containing " + ++ show (length components) ++ " component(s):") + $$ ( nest 2 + $ vcat + $ fmap text components + ) + when doPlan printInstallPlan + _ -> + putStrLn " Multiple packages in the current directory." + printInstallPlan = do + putStrLn "Install plan:" + installedPkgIndex <- getInstalledPackages + verbosity + comp + dbs + conf + sourcePkgDb <- getSourcePackages + verbosity + (globalRepos globalFlags') + transport <- configureTransport + verbosity + (Cabal.flagToMaybe (globalHttpTransport globalFlags')) + pkgSpecifiers <- resolveUserTargets verbosity transport + (Cabal.fromFlag $ globalWorldFile globalFlags') + (packageIndex sourcePkgDb) + [UserTargetLocalDir "."] + maybeWithSandboxPackageInfo + (lessVerbose verbosity) + (savedConfigureFlags config) + globalFlags' + comp + platform + conf + useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ do + planPkgs <- planPackages + (lessVerbose verbosity) + comp + platform + mSandboxPkgInfo + defaultFreezeFlags + installedPkgIndex + sourcePkgDb + pkgSpecifiers + planPkgs `forM_` \pkg -> + let pid = (packageId pkg) + in putStrLn $ " " ++ display (packageName pid) + ++ " == " + ++ showVersion (packageVersion pid) + printSandboxInformation = case (sandboxPath, sandboxDbPath) of + (Just path, Just dbpath) -> do + putStrLn $ "Sandbox: Present in current directory:" + putStrLn $ " config in " ++ sandboxConfigPath + putStrLn $ " sandbox in " ++ path + putStrLn $ " sandbox package db in " ++ dbpath + -- TODO: (optionally) print add-source directories (?) + _ -> do + let (dir,fname) = splitFileName sandboxConfigPath + dirs = splitPath dir + r <- if length dirs <= 1 + then return Nothing + -- test if there is a sandbox is any of the parents + else fmap asum + $ ( fmap joinPath + $ reverse + $ inits + $ init dirs + ) `forM` \path -> -- doesnt exist -> Nothing; otherwise Just path. + fmap (fmap (const path) . guard) + $ doesFileExist + $ combine path fname + putStr "Sandbox: Not present in current directory." + case r of + Nothing -> putStrLn $ "." + Just op -> putStrLn $ ";\n But there is a sandbox in parent:\n " + ++ op + printPackageDbs = do + installedPackageIndex <- getInstalledPackages verbosity comp dbs conf + let pkgs = allPackages installedPackageIndex + pkgTuples = [ (root, disp $ sourcePackageId pkg) + | pkg <- pkgs + , root <- [x | Just x <- [pkgRoot pkg]] + ] + grouped = groupBy (\a b -> fst a == fst b) + $ sortBy (comparing fst) + $ pkgTuples + groups = [(fst (head x), map snd x) | x <- grouped] + let packageDoc ps = if Cabal.fromFlag (statusPkgDbs statusFlags) + || Cabal.fromFlag (statusAll statusFlags) + then nest 2 ( text "(" + <> vcat (punctuate (text ",") ps) + <> text ")") + else empty + putStrLn $ render + $ ( text "Package databases:" + $$ ( nest 2 + $ vcat + $ flip fmap groups + $ \(root, ps) -> + ( text (show (length ps)) + <+> text "packages in database" + <+> text root) + $+$ + packageDoc ps)) + printPackageDBChecks = do + putStrLn $ "Package database checks:" + checks <- checkPackageDBs verbosity comp dbs conf + flip mapM_ checks $ \(db, output) -> if null output + then putStrLn $ " clean for database " ++ show db ++ "." + else do + putStrLn $ " " ++ show db ++ ":" + mapM_ putStrLn output + } diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs index 8e79acc76d6..42e19d9db26 100644 --- a/cabal-install/Main.hs +++ b/cabal-install/Main.hs @@ -25,6 +25,7 @@ import Distribution.Client.Setup , installCommand, upgradeCommand, uninstallCommand , FetchFlags(..), fetchCommand , FreezeFlags(..), freezeCommand + , StatusFlags(..), statusCommand , GetFlags(..), getCommand, unpackCommand , checkCommand , formatCommand @@ -77,6 +78,7 @@ import Distribution.Client.Exec (exec) import Distribution.Client.Fetch (fetch) import Distribution.Client.Freeze (freeze) import Distribution.Client.Check as Check (check) +import Distribution.Client.Status as Status (status) --import Distribution.Client.Clean (clean) import qualified Distribution.Client.Upload as Upload import Distribution.Client.Run (run, splitRunArgs) @@ -246,6 +248,7 @@ mainWorker args = topHandler $ , regularCmd fetchCommand fetchAction , regularCmd freezeCommand freezeAction , regularCmd getCommand getAction + , regularCmd statusCommand statusAction , hiddenCmd unpackCommand unpackAction , regularCmd checkCommand checkAction , regularCmd sdistCommand sdistAction @@ -1013,6 +1016,11 @@ freezeAction freezeFlags _extraArgs globalFlags = do mSandboxPkgInfo globalFlags' freezeFlags +statusAction :: StatusFlags -> [String] -> Action +statusAction statusFlags _extraArgs globalFlags = + Status.status (fromFlag $ statusVerbosity statusFlags) globalFlags statusFlags + + uploadAction :: UploadFlags -> [String] -> Action uploadAction uploadFlags extraArgs globalFlags = do config <- loadConfig verbosity (globalConfigFile globalFlags) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index d0d24c91d1b..5108632b3b7 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -190,6 +190,7 @@ executable cabal Distribution.Client.Setup Distribution.Client.SetupWrapper Distribution.Client.SrcDist + Distribution.Client.Status Distribution.Client.Tar Distribution.Client.Targets Distribution.Client.Types