Commit 636aa6dd authored by Oleg Grenrus's avatar Oleg Grenrus

Resolve #6721: list command takes --with-compiler

    % cabal list transformers --installed
    * transformers
        Synopsis: Concrete functor and monad transformers
        Default available version: 0.5.6.2
        Installed versions: 0.5.6.2
        License:  BSD3

    % cabal list transformers --installed -w ghc-8.10.1
    * transformers
        Synopsis: Concrete functor and monad transformers
        Default available version: 0.5.6.2
        Installed versions: 0.5.6.2
        License:  BSD3

    % cabal list transformers --installed -w ghc-7.6.3
    No matches found.

    % cabal list transformers --installed -w ghc-7.8.4
    * transformers
        Synopsis: Concrete functor and monad transformers
        Default available version: 0.5.6.2
        Installed versions: 0.3.0.0
        License:  BSD3
parent 9fef4c67
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.List
......@@ -13,6 +14,9 @@ module Distribution.Client.List (
list, info
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Package
( PackageName, Package(..), packageName
, packageVersion, UnitId )
......@@ -62,16 +66,21 @@ import Distribution.Client.FetchUtils
( isFetched )
import Data.List
( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )
( maximumBy, partition )
import Data.List.NonEmpty (groupBy, nonEmpty)
import qualified Data.List as L
import Data.Maybe
( listToMaybe, fromJust, fromMaybe, isJust, maybeToList )
( fromJust )
import qualified Data.Map as Map
import Data.Tree as Tree
import Control.Monad
( MonadPlus(mplus), join )
( join )
import Control.Exception
( assert )
import Text.PrettyPrint as Disp
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint
( lineLength, ribbonsPerLine, Doc, renderStyle, char
, (<+>), nest, ($+$), text, vcat, style, parens, fsep)
import System.Directory
( doesDirectoryExist )
......@@ -83,42 +92,36 @@ import qualified Distribution.Utils.ShortText as ShortText
getPkgList :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> ProgramDb
-> Maybe (Compiler, ProgramDb)
-> ListFlags
-> [String]
-> IO [PackageDisplayInfo]
getPkgList verbosity packageDBs repoCtxt comp progdb listFlags pats = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do
installedPkgIndex <- for mcompprogdb $ \(comp, progdb) ->
getInstalledPackages verbosity comp packageDBs progdb
sourcePkgDb <- getSourcePackages verbosity repoCtxt
let sourcePkgIndex = packageIndex sourcePkgDb
prefs name = fromMaybe anyVersion
(Map.lookup name (packagePreferences sourcePkgDb))
pkgsInfoMatching ::
[(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
pkgsInfoMatching =
let matchingInstalled = maybe [] (matchingPackages ipiSearch) installedPkgIndex
matchingSource = matchingPackages (\ idx n -> concatMap snd (piSearch idx n)) sourcePkgIndex
in mergePackages matchingInstalled matchingSource
pkgsInfo ::
[(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
pkgsInfo
-- gather info for all packages
| null pats = mergePackages
(InstalledPackageIndex.allPackages installedPkgIndex)
( PackageIndex.allPackages sourcePkgIndex)
(maybe [] InstalledPackageIndex.allPackages installedPkgIndex)
( PackageIndex.allPackages sourcePkgIndex)
-- gather info for packages matching search term
| otherwise = pkgsInfoMatching
pkgsInfoMatching ::
[(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
pkgsInfoMatching =
let matchingInstalled = matchingPackages
ipiSearch
installedPkgIndex
matchingSource = matchingPackages
(\ idx n ->
concatMap snd
(piSearch idx n))
sourcePkgIndex
in mergePackages matchingInstalled matchingSource
matches :: [PackageDisplayInfo]
matches = [ mergePackageInfo pref
installedPkgs sourcePkgs selectedPkg False
......@@ -144,13 +147,12 @@ getPkgList verbosity packageDBs repoCtxt comp progdb listFlags pats = do
list :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> ProgramDb
-> Maybe (Compiler, ProgramDb)
-> ListFlags
-> [String]
-> IO ()
list verbosity packageDBs repos comp progdb listFlags pats = do
matches <- getPkgList verbosity packageDBs repos comp progdb listFlags pats
list verbosity packageDBs repos mcompProgdb listFlags pats = do
matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats
if simpleOutput
then putStr $ unlines
......@@ -204,7 +206,7 @@ info verbosity packageDBs repoCtxt comp progdb
(fromFlag $ globalWorldFile globalFlags)
sourcePkgs' userTargets
pkgsinfo <- sequence
pkgsinfo <- sequenceA
[ do pkginfo <- either (die' verbosity) return $
gatherPkgInfo prefs
installedPkgIndex sourcePkgIndex
......@@ -330,16 +332,16 @@ showPackageSummaryInfo pkginfo =
$+$ text ""
where
maybeShowST l s f
| ShortText.null l = empty
| ShortText.null l = Disp.empty
| otherwise = text s <+> f (ShortText.fromShortText l)
showPackageDetailedInfo :: PackageDisplayInfo -> String
showPackageDetailedInfo pkginfo =
renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
char '*' <+> pretty (pkgName pkginfo)
Disp.<> maybe empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo)
<<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo)
<+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ')
Disp.<> parens pkgkind
<<>> parens pkgkind
$+$
(nest 4 $ vcat [
entryST "Synopsis" synopsis hideIfNull reflowParagraphs
......@@ -363,14 +365,14 @@ showPackageDetailedInfo pkginfo =
, entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
, entry "Documentation" haddockHtml showIfInstalled text
, entry "Cached" haveTarball alwaysShow dispYesNo
, if not (hasLib pkginfo) then empty else
, if not (hasLib pkginfo) then mempty else
text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo))
])
$+$ text ""
where
entry fname field cond format = case cond (field pkginfo) of
Nothing -> label <+> format (field pkginfo)
Just Nothing -> empty
Just Nothing -> mempty
Just (Just other) -> label <+> text other
where
label = text fname Disp.<> char ':' Disp.<> padding
......@@ -407,7 +409,7 @@ showPackageDetailedInfo pkginfo =
| hasLib pkginfo = text "library"
| hasExes = text "programs"
| hasExe pkginfo = text "program"
| otherwise = empty
| otherwise = mempty
reflowParagraphs :: String -> Doc
......@@ -416,7 +418,7 @@ reflowParagraphs =
. intersperse (text "") -- re-insert blank lines
. map (fsep . map text . concatMap words) -- reflow paragraphs
. filter (/= [""])
. groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines
. L.groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines
. lines
reflowLines :: String -> Doc
......@@ -548,7 +550,7 @@ mergePackages installedPkgs sourcePkgs =
collect (OnlyInRight (name,as)) = (name, [], as)
groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]
groupOn key = map (\xs -> (key (head xs), xs))
groupOn key = map (\xs -> (key (head xs), toList xs))
. groupBy (equating key)
. sortBy (comparing key)
......@@ -586,9 +588,12 @@ interestingVersions pref =
. reorderTree (\(Node (v,_) _) -> pref (mkVersion v))
. reverseTree
. mkTree
. map versionNumbers
. map (or0 . versionNumbers)
where
or0 [] = 0 :| []
or0 (x:xs) = x :| xs
swizzleTree = unfoldTree (spine [])
where
spine ts' (Node x []) = (x, ts')
......@@ -601,12 +606,17 @@ interestingVersions pref =
reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))
mkTree :: forall a. Eq a => [NonEmpty a] -> Tree ([a], Bool)
mkTree xs = unfoldTree step (False, [], xs)
where
step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])])
step (node,ns,vs) =
( (reverse ns, node)
, [ (any null vs', n:ns, filter (not . null) vs')
| (n, vs') <- groups vs ]
, [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs'))
| (n, vs') <- groups vs
]
)
groups = map (\g -> (head (head g), map tail g))
groups :: [NonEmpty a] -> [(a, NonEmpty [a])]
groups = map (\g -> (head (head g), fmap tail g))
. groupBy (equating head)
......@@ -28,7 +28,7 @@ module Distribution.Client.Setup
, installCommand, InstallFlags(..), installOptions, defaultInstallFlags
, filterHaddockArgs, filterHaddockFlags, haddockOptions
, defaultSolver, defaultMaxBackjumps
, listCommand, ListFlags(..)
, listCommand, ListFlags(..), listNeedsCompiler
, updateCommand, UpdateFlags(..), defaultUpdateFlags
, infoCommand, InfoFlags(..)
, fetchCommand, FetchFlags(..)
......@@ -92,6 +92,10 @@ import qualified Distribution.Simple.Command as Command
import Distribution.Simple.Configure
( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling )
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Flag
( Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag
, flagElim, fromFlagOrDefault
)
import Distribution.Simple.Setup
( ConfigFlags(..), BuildFlags(..), ReplFlags
, TestFlags, BenchmarkFlags
......@@ -99,7 +103,6 @@ import Distribution.Simple.Setup
, CleanFlags(..), DoctestFlags(..)
, CopyFlags(..), RegisterFlags(..)
, readPackageDbList, showPackageDbList
, Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag
, BooleanFlag(..), optionVerbosity
, boolOpt, boolOpt', trueArg, falseArg
, optionNumJobs )
......@@ -1519,22 +1522,25 @@ instance Semigroup GetFlags where
-- * List flags
-- ------------------------------------------------------------
data ListFlags = ListFlags {
listInstalled :: Flag Bool,
listSimpleOutput :: Flag Bool,
listExactMatch :: Flag Bool,
listVerbosity :: Flag Verbosity,
listPackageDBs :: [Maybe PackageDB]
} deriving Generic
data ListFlags = ListFlags
{ listInstalled :: Flag Bool
, listSimpleOutput :: Flag Bool
, listExactMatch :: Flag Bool
, listVerbosity :: Flag Verbosity
, listPackageDBs :: [Maybe PackageDB]
, listHcPath :: Flag FilePath
}
deriving Generic
defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
listInstalled = Flag False,
listSimpleOutput = Flag False,
listExactMatch = Flag False,
listVerbosity = toFlag normal,
listPackageDBs = []
}
defaultListFlags = ListFlags
{ listInstalled = Flag False
, listSimpleOutput = Flag False
, listExactMatch = Flag False
, listVerbosity = toFlag normal
, listPackageDBs = []
, listHcPath = mempty
}
listCommand :: CommandUI ListFlags
listCommand = CommandUI {
......@@ -1553,35 +1559,47 @@ listCommand = CommandUI {
commandUsage = usageAlternatives "list" [ "[FLAGS]"
, "[FLAGS] STRINGS"],
commandDefaultFlags = defaultListFlags,
commandOptions = \_ -> [
optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
, option [] ["installed"]
"Only print installed packages"
listInstalled (\v flags -> flags { listInstalled = v })
trueArg
, option [] ["simple-output"]
"Print in a easy-to-parse format"
listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
trueArg
, option [] ["exact"]
"Print only exact match"
listExactMatch (\v flags -> flags { listExactMatch = v })
trueArg
commandOptions = const listOptions
}
, option "" ["package-db"]
( "Append the given package database to the list of package"
++ " databases used (to satisfy dependencies and register into)."
++ " May be a specific file, 'global' or 'user'. The initial list"
++ " is ['global'], ['global', 'user'],"
++ " depending on context. Use 'clear' to reset the list to empty."
++ " See the user guide for details.")
listPackageDBs (\v flags -> flags { listPackageDBs = v })
(reqArg' "DB" readPackageDbList showPackageDbList)
listOptions :: [OptionField ListFlags]
listOptions =
[ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
]
}
, option [] ["installed"]
"Only print installed packages"
listInstalled (\v flags -> flags { listInstalled = v })
trueArg
, option [] ["simple-output"]
"Print in a easy-to-parse format"
listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
trueArg
, option [] ["exact"]
"Print only exact match"
listExactMatch (\v flags -> flags { listExactMatch = v })
trueArg
, option "" ["package-db"]
( "Append the given package database to the list of package"
++ " databases used (to satisfy dependencies and register into)."
++ " May be a specific file, 'global' or 'user'. The initial list"
++ " is ['global'], ['global', 'user'],"
++ " depending on context. Use 'clear' to reset the list to empty."
++ " See the user guide for details.")
listPackageDBs (\v flags -> flags { listPackageDBs = v })
(reqArg' "DB" readPackageDbList showPackageDbList)
, option "w" ["with-compiler"]
"give the path to a particular compiler"
listHcPath (\v flags -> flags { listHcPath = v })
(reqArgFlag "PATH")
]
listNeedsCompiler :: ListFlags -> Bool
listNeedsCompiler f =
flagElim False (const True) (listHcPath f)
|| fromFlagOrDefault False (listInstalled f)
instance Monoid ListFlags where
mempty = gmempty
......
......@@ -33,7 +33,7 @@ import Distribution.Client.Setup
, checkCommand
, formatCommand
, UpdateFlags(..), updateCommand
, ListFlags(..), listCommand
, ListFlags(..), listCommand, listNeedsCompiler
, InfoFlags(..), infoCommand
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
......@@ -705,18 +705,22 @@ listAction listFlags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags)
config <- loadConfigOrSandboxConfig verbosity globalFlags
let configFlags' = savedConfigureFlags config
configFlags = configFlags' {
configPackageDBs = configPackageDBs configFlags'
configFlags = configFlags'
{ configPackageDBs = configPackageDBs configFlags'
`mappend` listPackageDBs listFlags
, configHcPath = listHcPath listFlags
}
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, _, progdb) <- configCompilerAux' configFlags
compProgdb <- if listNeedsCompiler listFlags
then do
(comp, _, progdb) <- configCompilerAux' configFlags
return (Just (comp, progdb))
else return Nothing
withRepoContext verbosity globalFlags' $ \repoContext ->
List.list verbosity
(configPackageDB' configFlags)
repoContext
comp
progdb
compProgdb
listFlags
extraArgs
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment