From d4d4dfad0be256d2c4c92f1f6b724c21dfa1211d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 15 Nov 2015 20:27:09 +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. --- Cabal/Distribution/Simple/Configure.hs | 26 +- Cabal/Distribution/Simple/GHC.hs | 13 +- Cabal/Distribution/Simple/Program/HcPkg.hs | 22 +- Cabal/Distribution/Simple/Utils.hs | 38 +- Cabal/Distribution/Text.hs | 28 +- Cabal/changelog | 1 + 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 + 12 files changed, 631 insertions(+), 24 deletions(-) create mode 100644 cabal-install/Distribution/Client/Status.hs diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index 5e216d51296..3d1c5e02dbb 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/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 diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index d8e297a0351..647d2c6d893 100644 --- a/Cabal/Distribution/Simple/GHC.hs +++ b/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'. diff --git a/Cabal/Distribution/Simple/Program/HcPkg.hs b/Cabal/Distribution/Simple/Program/HcPkg.hs index fca63dc4140..8d740db4ab3 100644 --- a/Cabal/Distribution/Simple/Program/HcPkg.hs +++ b/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) { diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs index 5f1c35f03c0..20c0a170ef1 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/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) -- ^.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 f63dae82512..84e7e9ed31d 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 bbbb4caafcf..5c4a462c55c 100644 --- a/Cabal/changelog +++ b/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 January 2015 * Support GHC 7.10. diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs index 470e27a1d8e..10634c5d360 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 23eb969547d..858ef29ffa4 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 212c68ae433..454fcbf7c1e 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -19,6 +19,7 @@ module Distribution.Client.Setup , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , replCommand, testCommand, benchmarkCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags + , defaultFreezeFlags , listCommand, ListFlags(..) , updateCommand , upgradeCommand @@ -26,6 +27,7 @@ module Distribution.Client.Setup , 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 -- ------------------------------------------------------------ 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 ee0617c53ac..3e0c43d8a60 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 @@ -73,6 +74,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) @@ -242,6 +244,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 @@ -985,6 +988,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 ba91c8ad98b..7c304b08809 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -141,6 +141,7 @@ executable cabal Distribution.Client.Setup Distribution.Client.SetupWrapper Distribution.Client.SrcDist + Distribution.Client.Status Distribution.Client.Tar Distribution.Client.Targets Distribution.Client.Types