Skip to content

Extend cabal list cmd #3202

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 3 commits into from
Closed

Extend cabal list cmd #3202

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
f762201
remove out of date comment.
mtullsen Feb 26, 2016
f56bbe4
wibble: fix grammar in help output.
mtullsen Feb 26, 2016
9504521
Extend the cabal 'list' command with --dependencies
mtullsen Mar 1, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
153 changes: 131 additions & 22 deletions cabal-install/Distribution/Client/List.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,8 @@ module Distribution.Client.List (
list, info
) where

import Distribution.Client.SetupWrapper
( SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Package
( PackageName(..), Package(..), packageName, packageVersion
, Dependency(..), simplifyDependency
Expand All @@ -26,8 +28,11 @@ import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )

import Distribution.ParseUtils ( fieldName, ppFields )
import Distribution.Simple.Compiler
( Compiler, PackageDBStack )
import Distribution.Simple.Configure (getPersistBuildConfig)
import qualified Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program (ProgramConfiguration)
import Distribution.Simple.Utils
( equating, comparing, die, notice )
Expand All @@ -36,7 +41,7 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Version
( Version(..), VersionRange, withinRange, anyVersion
( Version(..), VersionRange, withinRange, anyVersion, thisVersion
, intersectVersionRanges, simplifyVersionRange )
import Distribution.Verbosity (Verbosity)
import Distribution.Text
Expand All @@ -57,15 +62,19 @@ import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.FetchUtils
( isFetched )
import Distribution.Utils.NubList
( fromNubList )

import Data.Either
( partitionEithers )
import Data.List
( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )
import Data.Maybe
( listToMaybe, fromJust, fromMaybe, isJust )
import qualified Data.Map as Map
import Data.Tree as Tree
import Control.Monad
( MonadPlus(mplus), join )
( MonadPlus(mplus), join, unless )
import Control.Exception
( assert )
import Text.PrettyPrint as Disp
Expand Down Expand Up @@ -129,6 +138,94 @@ getPkgList verbosity packageDBs repoCtxt comp conf listFlags pats = do
, pkg <- search index pat ]


-- | List the installed packages that the current package depends on.
-- This is similar to getPkgList, but it takes no patterns; rather, it assumes
-- there is a current, configured configuration so it can determine the exact
-- (installed) packages depended on.
listPkgDeps :: Verbosity
-> RepoContext
-> ListFlags
-> IO ()
listPkgDeps verbosity repoCtxt listFlags =
case possiblyShowPackageFields of
Left msg -> die msg
Right showPackageFields -> do
installedPkgIndex <-
fmap Distribution.Simple.LocalBuildInfo.installedPkgs $
getPersistBuildConfig (useDistPref defaultSetupScriptOptions)
-- TODO: add a --builddir=DIR option rather than assume
-- the default value of 'dist'

srcPkgIndex <- fmap packageIndex $
getSourcePackages verbosity repoCtxt

let
showPkgSimple pkg =
display (packageName pkg)
++ " "
++ display (packageVersion pkg)
++ showPackageFields pkg

showPkgStd = showPackageSummaryInfo . mkDisplayInfo srcPkgIndex

pkgs = InstalledPackageIndex.topologicalOrder installedPkgIndex
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't think that this is correct, it will print all packages in the package index. I think you should use dependencyClosure.


if simpleOutput
then putStr $ unlines $ map showPkgSimple pkgs
else putStr $ unlines $ map showPkgStd pkgs

where

-- flags:
simpleOutput = fromFlag (listSimpleOutput listFlags)
fields = fromNubList $ listFields listFlags

-- Left if any of the fields are bad, otherwise Right with the show function:
possiblyShowPackageFields :: Either String
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This feels a bit overcomplicated. Why not just build a Map String (FieldDescr InstalledPackageInfo) from fieldsInstalledPackageInfo? Then the code would look roughly like this:

fieldDescrMap <- buildFieldDescrMap
validateFieldNames fieldDescrMap fields
showPackageFields <- mkShowPackageFields fieldDescrMap

(Installed.InstalledPackageInfo -> String)
possiblyShowPackageFields =
if null fields then
Right (\_pkg -> "")
else
case partitionEithers (map getFieldDescr fields) of
([], fds) -> Right $
\pkg-> '\n' : showFields fds pkg

(ss, _ ) -> Left $
unlines $
[ "unrecognized package fields: "
++ unwords ss
, "must use one of these field names:"
]
++ map ((" - "++) . fieldName)
Installed.fieldsInstalledPackageInfo
where
getFieldDescr nm =
case [ fd | fd <- Installed.fieldsInstalledPackageInfo
, nm == fieldName fd ] of
[] -> Left nm
fd:_ -> Right fd

showFields fds = render . nest 2 . ($+$ text "") . ppFields fds

mkDisplayInfo :: PackageIndex.PackageIndex SourcePackage
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This function looks like something that could be reused in other parts of the file.

-> Installed.InstalledPackageInfo
-> PackageDisplayInfo
mkDisplayInfo srcPkgIndex pkg =
mergePackageInfo
pref
[pkg]
srcPkgs
(listToMaybe srcPkgs)
False

where
pref = thisVersion (packageVersion pkg)
srcPkgs = PackageIndex.lookupDependency
srcPkgIndex
(Dependency (packageName pkg) pref)


-- | Show information about packages.
list :: Verbosity
-> PackageDBStack
Expand All @@ -138,27 +235,39 @@ list :: Verbosity
-> ListFlags
-> [String]
-> IO ()
list verbosity packageDBs repos comp conf listFlags pats = do
matches <- getPkgList verbosity packageDBs repos comp conf listFlags pats

if simpleOutput
then putStr $ unlines
[ display (pkgName pkg) ++ " " ++ display version
| pkg <- matches
, version <- if onlyInstalled
then installedVersions pkg
else nub . sort $ installedVersions pkg
++ sourceVersions pkg ]
-- Note: this only works because for 'list', one cannot currently
-- specify any version constraints, so listing all installed
-- and source ones works.
else
if null matches
then notice verbosity "No matches found."
else putStr $ unlines (map showPackageSummaryInfo matches)
list verbosity packageDBs repoCtxt comp conf listFlags pats = do
unless (simpleOutput || null fields) $
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

So just --field=foo --simple-output is allowed, even though it has no effect? From the error message it looks like the test should be when (not.null fields && (not simpleOutput || not onlyDependencies)) $ die "...".

die "--field requires \"--dependencies --simple-output\""
if onlyDependencies
then
if null pats
then listPkgDeps verbosity repoCtxt listFlags
else die "no patterns allowed in 'list --dependencies'"
else
do
matches <-
getPkgList verbosity packageDBs repoCtxt comp conf listFlags pats

if simpleOutput
then putStr $ unlines
[ display (pkgName pkg) ++ " " ++ display version
| pkg <- matches
, version <- if onlyInstalled
then installedVersions pkg
else nub . sort $ installedVersions pkg
++ sourceVersions pkg ]
-- Note: this only works because for 'list', one cannot currently
-- specify any version constraints, so listing all installed
-- and source ones works.
else
if null matches
then notice verbosity "No matches found."
else putStr $ unlines (map showPackageSummaryInfo matches)
where
onlyInstalled = fromFlag (listInstalled listFlags)
simpleOutput = fromFlag (listSimpleOutput listFlags)
onlyInstalled = fromFlag (listInstalled listFlags)
simpleOutput = fromFlag (listSimpleOutput listFlags)
onlyDependencies = fromFlag (listDependencies listFlags)
fields = fromNubList $ listFields listFlags

info :: Verbosity
-> PackageDBStack
Expand Down
39 changes: 32 additions & 7 deletions cabal-install/Distribution/Client/Setup.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -994,26 +994,33 @@ instance Semigroup GetFlags where

data ListFlags = ListFlags {
listInstalled :: Flag Bool,
listDependencies :: Flag Bool, -- this implies last.
listSimpleOutput :: Flag Bool,
listFields :: NubList String, -- when last two set: fields to print
listVerbosity :: Flag Verbosity,
listPackageDBs :: [Maybe PackageDB]
} deriving Generic

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
listInstalled = Flag False,
listDependencies = Flag False,
listSimpleOutput = Flag False,
listFields = mempty,
listVerbosity = toFlag normal,
listPackageDBs = []
}

listCommand :: CommandUI ListFlags
listCommand = CommandUI {
commandName = "list",
commandSynopsis = "List packages matching a search string.",
commandSynopsis = "List packages.",
commandDescription = Just $ \_ -> wrapText $
"List all packages, or all packages matching one of the search"
++ " strings.\n"
"List all packages, all packages matching one of the search"
++ " strings, or all package dependencies.\n"
++ "\n"
++ "In the '--dependencies --simple-output' variant, you may specify"
++ " the names of Cabal fields to be printed using the '--field' flag.\n"
++ "\n"
++ "If there is a sandbox in the current directory and "
++ "config:ignore-sandbox is False, use the sandbox package database. "
Expand All @@ -1022,9 +1029,17 @@ listCommand = CommandUI {
commandNotes = Just $ \pname ->
"Examples:\n"
++ " " ++ pname ++ " list pandoc\n"
++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n",
commandUsage = usageAlternatives "list" [ "[FLAGS]"
, "[FLAGS] STRINGS"],
++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n"
++ " " ++ pname ++ " list --dependencies\n"
++ " Will list the installed dependencies\n"
++ " " ++ pname ++ " list --dependencies --simple-output --field=license\n"
++ " Will list the 'license' field for each package dependency\n",
commandUsage =
usageAlternatives "list"
[ "[FLAGS]"
, "[FLAGS] STRINGS"
, "--dependencies"
, "--dependencies --simple-output [--field=FIELD ...]"],
commandDefaultFlags = defaultListFlags,
commandOptions = \_ -> [
optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
Expand All @@ -1034,11 +1049,21 @@ listCommand = CommandUI {
listInstalled (\v flags -> flags { listInstalled = v })
trueArg

, option [] ["dependencies"]
"Print installed dependencies of the current package"
listDependencies (\v flags -> flags { listDependencies = v })
trueArg

, option [] ["simple-output"]
"Print in a easy-to-parse format"
"Print in an easy-to-parse format"
listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
trueArg

, option ['f'] ["field"]
"Print field FIELD of installed package"
listFields (\v flags -> flags { listFields = v })
(reqArg' "FIELD" (\x -> toNubList [x]) fromNubList)

, option "" ["package-db"]
( "Append the given package database to the list of package"
++ " databases used (to satisfy dependencies and register into)."
Expand Down
2 changes: 0 additions & 2 deletions cabal-install/Distribution/Client/Utils.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -72,8 +72,6 @@ import System.IO.Error (ioError, mkIOError, doesNotExistErrorType)

-- | Generic merging utility. For sorted input lists this is a full outer join.
--
-- * The result list never contains @(Nothing, Nothing)@.
--
mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy cmp = merge
where
Expand Down