diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs index 34c43b8fc46..4267d7c32d0 100644 --- a/Cabal/Distribution/PackageDescription/Parse.hs +++ b/Cabal/Distribution/PackageDescription/Parse.hs @@ -58,7 +58,7 @@ import System.Directory (doesFileExist) import Control.Monad (mapM) import Text.PrettyPrint - (vcat, ($$), (<+>), text, render, + (vcat, ($$), (<+>), text, comma, fsep, nest, ($+$), punctuate) diff --git a/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/Cabal/Distribution/PackageDescription/PrettyPrint.hs index 7cbf726bfa4..da372df74c8 100644 --- a/Cabal/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal/Distribution/PackageDescription/PrettyPrint.hs @@ -38,7 +38,7 @@ import Distribution.Text 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 diff --git a/Cabal/Distribution/ParseUtils.hs b/Cabal/Distribution/ParseUtils.hs index 3d5e5e4b177..d68aba9b2c8 100644 --- a/Cabal/Distribution/ParseUtils.hs +++ b/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 (..) , ($+$), (<+>) diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index 72bfd89eaa3..477f1d893be 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -42,6 +42,7 @@ module Distribution.Simple.Configure (configure, getInstalledPackages, getInstalledPackagesMonitorFiles, getPackageDBContents, + checkPackageDBs, configCompiler, configCompilerAux, configCompilerEx, configCompilerAuxEx, ccLdOptionsBuildInfo, @@ -1172,6 +1173,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 47872918f43..9d8a9888dad 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, @@ -297,6 +298,18 @@ 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 + sequenceA + [ 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 868e1474372..e397e521335 100644 --- a/Cabal/Distribution/Simple/Program/HcPkg.hs +++ b/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) { diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs index fb0c1527e2a..dd6daa4d01b 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, @@ -1231,30 +1232,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 b3c21c7c4f5..edb6c976a0d 100644 --- a/Cabal/Distribution/Text.hs +++ b/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 diff --git a/Cabal/doc/installing-packages.markdown b/Cabal/doc/installing-packages.markdown index c95037f56d7..d2cfe9e373f 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 48fc8fd92b0..d10773eb5f6 100644 --- a/cabal-install/Distribution/Client/Freeze.hs +++ b/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(..) ) diff --git a/cabal-install/Distribution/Client/Sandbox.hs b/cabal-install/Distribution/Client/Sandbox.hs index 1c253f0c78b..d07e9078c00 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 61f961c565b..9806b870fca 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -24,6 +24,7 @@ module Distribution.Client.Setup , replCommand, testCommand, benchmarkCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , defaultSolver, defaultMaxBackjumps + , defaultFreezeFlags , listCommand, ListFlags(..) , updateCommand , upgradeCommand @@ -31,6 +32,7 @@ module Distribution.Client.Setup , infoCommand, InfoFlags(..) , fetchCommand, FetchFlags(..) , freezeCommand, FreezeFlags(..) + , statusCommand, StatusFlags(..) , genBoundsCommand , getCommand, unpackCommand, GetFlags(..) , checkCommand @@ -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" @@ -755,6 +759,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", diff --git a/cabal-install/Distribution/Client/Status.hs b/cabal-install/Distribution/Client/Status.hs new file mode 100644 index 00000000000..c872a727bb9 --- /dev/null +++ b/cabal-install/Distribution/Client/Status.hs @@ -0,0 +1,417 @@ +----------------------------------------------------------------------------- +-- | +-- 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(..) + , withRepoContext + , 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.Targets ( resolveUserTargets + , UserTarget(..) ) +import Distribution.Client.Types ( SourcePackageDb(..) ) +import Distribution.Solver.Types.PkgConfigDb ( readPkgConfigDb ) +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 <- withRepoContext verbosity + globalFlags' + (getSourcePackages verbosity) + pkgConfigDb <- readPkgConfigDb verbosity conf + pkgSpecifiers <- withRepoContext verbosity + globalFlags' + $ \repoContext -> resolveUserTargets + verbosity + repoContext + (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 + pkgConfigDb + 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 c7c83a86a4e..66b442bd459 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 , genBoundsCommand , GetFlags(..), getCommand, unpackCommand , checkCommand @@ -81,6 +82,7 @@ import Distribution.Client.Fetch (fetch) import Distribution.Client.Freeze (freeze) import Distribution.Client.GenBounds (genBounds) 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) @@ -251,6 +253,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 @@ -1035,6 +1038,11 @@ freezeAction freezeFlags _extraArgs globalFlags = do mSandboxPkgInfo globalFlags' freezeFlags +statusAction :: StatusFlags -> [String] -> Action +statusAction statusFlags _extraArgs globalFlags = + Status.status (fromFlag $ statusVerbosity statusFlags) globalFlags statusFlags + + genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () genBoundsAction freezeFlags _extraArgs globalFlags = do let verbosity = fromFlag (freezeVerbosity freezeFlags) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 3a2d5e5baaa..69f6355c735 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -247,6 +247,7 @@ executable cabal Distribution.Client.SrcDist Distribution.Client.SolverInstallPlan Distribution.Client.SolverPlanIndex + Distribution.Client.Status Distribution.Client.Tar Distribution.Client.Targets Distribution.Client.Types diff --git a/cabal-install/changelog b/cabal-install/changelog index bc99ecece66..02a73900cdd 100644 --- a/cabal-install/changelog +++ b/cabal-install/changelog @@ -17,6 +17,7 @@ * The bootstrap script now works correctly when run from a Git clone (#3439). * Removed the top-down solver (#3598). + * Added a 'status' command. 1.24.0.0 Ryan Thomas March 2016 * If there are multiple remote repos, 'cabal update' now updates