-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.List
-- Copyright : (c) David Himmelstrup 2005
-- Duncan Coutts 2008-2011
-- License : BSD-like
--
-- Maintainer : cabal-devel@haskell.org
--
-- Search for and print information about packages
-----------------------------------------------------------------------------
module Distribution.Client.List (
list, info
) where
import Distribution.Package
( PackageName, Package(..), packageName
, packageVersion, UnitId )
import Distribution.Types.Dependency
import Distribution.Types.UnqualComponentName
import Distribution.ModuleName (ModuleName)
import Distribution.License (License)
import qualified Distribution.InstalledPackageInfo as Installed
import qualified Distribution.PackageDescription as Source
import Distribution.PackageDescription
( Flag(..), unFlagName )
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
import Distribution.Simple.Compiler
( Compiler, PackageDBStack )
import Distribution.Simple.Program (ProgramDb)
import Distribution.Simple.Utils
( equating, comparing, die', notice )
import Distribution.Simple.Setup (fromFlag)
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import Distribution.Version
( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion
, intersectVersionRanges, simplifyVersionRange )
import Distribution.Verbosity (Verbosity)
import Distribution.Text
( Text(disp), display )
import Distribution.Solver.Types.PackageConstraint
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import Distribution.Solver.Types.SourcePackage
import Distribution.Client.Types
( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage )
import Distribution.Client.Targets
( UserTarget, resolveUserTargets )
import Distribution.Client.Setup
( GlobalFlags(..), ListFlags(..), InfoFlags(..)
, RepoContext(..) )
import Distribution.Client.Utils
( mergeBy, MergeResult(..) )
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.FetchUtils
( isFetched )
import Data.List
( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )
import Data.Maybe
( listToMaybe, fromJust, fromMaybe, isJust, maybeToList )
import qualified Data.Map as Map
import Data.Tree as Tree
import Control.Monad
( MonadPlus(mplus), join )
import Control.Exception
( assert )
import Text.PrettyPrint as Disp
import System.Directory
( doesDirectoryExist )
-- | Return a list of packages matching given search strings.
getPkgList :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> ProgramDb
-> ListFlags
-> [String]
-> IO [PackageDisplayInfo]
getPkgList verbosity packageDBs repoCtxt comp progdb listFlags pats = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
sourcePkgDb <- getSourcePackages verbosity repoCtxt
let sourcePkgIndex = packageIndex sourcePkgDb
prefs name = fromMaybe anyVersion
(Map.lookup name (packagePreferences sourcePkgDb))
pkgsInfo ::
[(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
pkgsInfo
-- gather info for all packages
| null pats = mergePackages
(InstalledPackageIndex.allPackages installedPkgIndex)
( PackageIndex.allPackages sourcePkgIndex)
-- gather info for packages matching search term
| otherwise = pkgsInfoMatching
pkgsInfoMatching ::
[(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
pkgsInfoMatching =
let matchingInstalled = matchingPackages
InstalledPackageIndex.searchByNameSubstring
installedPkgIndex
matchingSource = matchingPackages
(\ idx n ->
concatMap snd
(PackageIndex.searchByNameSubstring idx n))
sourcePkgIndex
in mergePackages matchingInstalled matchingSource
matches :: [PackageDisplayInfo]
matches = [ mergePackageInfo pref
installedPkgs sourcePkgs selectedPkg False
| (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo
, not onlyInstalled || not (null installedPkgs)
, let pref = prefs pkgname
selectedPkg = latestWithPref pref sourcePkgs ]
return matches
where
onlyInstalled = fromFlag (listInstalled listFlags)
matchingPackages search index =
[ pkg
| pat <- pats
, pkg <- search index pat ]
-- | Show information about packages.
list :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> ProgramDb
-> ListFlags
-> [String]
-> IO ()
list verbosity packageDBs repos comp progdb listFlags pats = do
matches <- getPkgList verbosity packageDBs repos comp progdb 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)
info :: Verbosity
-> PackageDBStack
-> RepoContext
-> Compiler
-> ProgramDb
-> GlobalFlags
-> InfoFlags
-> [UserTarget]
-> IO ()
info verbosity _ _ _ _ _ _ [] =
notice verbosity "No packages requested. Nothing to do."
info verbosity packageDBs repoCtxt comp progdb
globalFlags _listFlags userTargets = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
sourcePkgDb <- getSourcePackages verbosity repoCtxt
let sourcePkgIndex = packageIndex sourcePkgDb
prefs name = fromMaybe anyVersion
(Map.lookup name (packagePreferences sourcePkgDb))
-- Users may specify names of packages that are only installed, not
-- just available source packages, so we must resolve targets using
-- the combination of installed and source packages.
let sourcePkgs' = PackageIndex.fromList
$ map packageId
(InstalledPackageIndex.allPackages installedPkgIndex)
++ map packageId
(PackageIndex.allPackages sourcePkgIndex)
pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
(fromFlag $ globalWorldFile globalFlags)
sourcePkgs' userTargets
pkgsinfo <- sequence
[ do pkginfo <- either (die' verbosity) return $
gatherPkgInfo prefs
installedPkgIndex sourcePkgIndex
pkgSpecifier
updateFileSystemPackageDetails pkginfo
| pkgSpecifier <- pkgSpecifiers ]
putStr $ unlines (map showPackageDetailedInfo pkgsinfo)
where
gatherPkgInfo :: (PackageName -> VersionRange) ->
InstalledPackageIndex ->
PackageIndex.PackageIndex UnresolvedSourcePackage ->
PackageSpecifier UnresolvedSourcePackage ->
Either String PackageDisplayInfo
gatherPkgInfo prefs installedPkgIndex sourcePkgIndex
(NamedPackage name props)
| null (selectedInstalledPkgs) && null (selectedSourcePkgs)
= Left $ "There is no available version of " ++ display name
++ " that satisfies "
++ display (simplifyVersionRange verConstraint)
| otherwise
= Right $ mergePackageInfo pref installedPkgs
sourcePkgs selectedSourcePkg'
showPkgVersion
where
(pref, installedPkgs, sourcePkgs) =
sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex
selectedInstalledPkgs = InstalledPackageIndex.lookupDependency
installedPkgIndex
(Dependency name verConstraint)
selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex
(Dependency name verConstraint)
selectedSourcePkg' = latestWithPref pref selectedSourcePkgs
-- display a specific package version if the user
-- supplied a non-trivial version constraint
showPkgVersion = not (null verConstraints)
verConstraint = foldr intersectVersionRanges anyVersion verConstraints
verConstraints = [ vr | PackagePropertyVersion vr <- props ]
gatherPkgInfo prefs installedPkgIndex sourcePkgIndex
(SpecificSourcePackage pkg) =
Right $ mergePackageInfo pref installedPkgs sourcePkgs
selectedPkg True
where
name = packageName pkg
selectedPkg = Just pkg
(pref, installedPkgs, sourcePkgs) =
sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex
sourcePkgsInfo ::
(PackageName -> VersionRange)
-> PackageName
-> InstalledPackageIndex
-> PackageIndex.PackageIndex UnresolvedSourcePackage
-> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])
sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex =
(pref, installedPkgs, sourcePkgs)
where
pref = prefs name
installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName
installedPkgIndex name)
sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name
-- | The info that we can display for each package. It is information per
-- package name and covers all installed and available versions.
--
data PackageDisplayInfo = PackageDisplayInfo {
pkgName :: PackageName,
selectedVersion :: Maybe Version,
selectedSourcePkg :: Maybe UnresolvedSourcePackage,
installedVersions :: [Version],
sourceVersions :: [Version],
preferredVersions :: VersionRange,
homepage :: String,
bugReports :: String,
sourceRepo :: String,
synopsis :: String,
description :: String,
category :: String,
license :: License,
author :: String,
maintainer :: String,
dependencies :: [ExtDependency],
flags :: [Flag],
hasLib :: Bool,
hasExe :: Bool,
executables :: [UnqualComponentName],
modules :: [ModuleName],
haddockHtml :: FilePath,
haveTarball :: Bool
}
-- | Covers source dependencies and installed dependencies in
-- one type.
data ExtDependency = SourceDependency Dependency
| InstalledDependency UnitId
showPackageSummaryInfo :: PackageDisplayInfo -> String
showPackageSummaryInfo pkginfo =
renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
char '*' <+> disp (pkgName pkginfo)
$+$
(nest 4 $ vcat [
maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs
, text "Default available version:" <+>
case selectedSourcePkg pkginfo of
Nothing -> text "[ Not available from any configured repository ]"
Just pkg -> disp (packageVersion pkg)
, text "Installed versions:" <+>
case installedVersions pkginfo of
[] | hasLib pkginfo -> text "[ Not installed ]"
| otherwise -> text "[ Unknown ]"
versions -> dispTopVersions 4
(preferredVersions pkginfo) versions
, maybeShow (homepage pkginfo) "Homepage:" text
, text "License: " <+> text (display (license pkginfo))
])
$+$ text ""
where
maybeShow [] _ _ = empty
maybeShow l s f = text s <+> (f l)
showPackageDetailedInfo :: PackageDisplayInfo -> String
showPackageDetailedInfo pkginfo =
renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
char '*' <+> disp (pkgName pkginfo)
Disp.<> maybe empty (\v -> char '-' Disp.<> disp v) (selectedVersion pkginfo)
<+> text (replicate (16 - length (display (pkgName pkginfo))) ' ')
Disp.<> parens pkgkind
$+$
(nest 4 $ vcat [
entry "Synopsis" synopsis hideIfNull reflowParagraphs
, entry "Versions available" sourceVersions
(altText null "[ Not available from server ]")
(dispTopVersions 9 (preferredVersions pkginfo))
, entry "Versions installed" installedVersions
(altText null (if hasLib pkginfo then "[ Not installed ]"
else "[ Unknown ]"))
(dispTopVersions 4 (preferredVersions pkginfo))
, entry "Homepage" homepage orNotSpecified text
, entry "Bug reports" bugReports orNotSpecified text
, entry "Description" description hideIfNull reflowParagraphs
, entry "Category" category hideIfNull text
, entry "License" license alwaysShow disp
, entry "Author" author hideIfNull reflowLines
, entry "Maintainer" maintainer hideIfNull reflowLines
, entry "Source repo" sourceRepo orNotSpecified text
, entry "Executables" executables hideIfNull (commaSep disp)
, entry "Flags" flags hideIfNull (commaSep dispFlag)
, entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
, entry "Documentation" haddockHtml showIfInstalled text
, entry "Cached" haveTarball alwaysShow dispYesNo
, if not (hasLib pkginfo) then empty else
text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))
])
$+$ text ""
where
entry fname field cond format = case cond (field pkginfo) of
Nothing -> label <+> format (field pkginfo)
Just Nothing -> empty
Just (Just other) -> label <+> text other
where
label = text fname Disp.<> char ':' Disp.<> padding
padding = text (replicate (13 - length fname ) ' ')
normal = Nothing
hide = Just Nothing
replace msg = Just (Just msg)
alwaysShow = const normal
hideIfNull v = if null v then hide else normal
showIfInstalled v
| not isInstalled = hide
| null v = replace "[ Not installed ]"
| otherwise = normal
altText nul msg v = if nul v then replace msg else normal
orNotSpecified = altText null "[ Not specified ]"
commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f
dispFlag = text . unFlagName . flagName
dispYesNo True = text "Yes"
dispYesNo False = text "No"
dispExtDep (SourceDependency dep) = disp dep
dispExtDep (InstalledDependency dep) = disp dep
isInstalled = not (null (installedVersions pkginfo))
hasExes = length (executables pkginfo) >= 2
--TODO: exclude non-buildable exes
pkgkind | hasLib pkginfo && hasExes = text "programs and library"
| hasLib pkginfo && hasExe pkginfo = text "program and library"
| hasLib pkginfo = text "library"
| hasExes = text "programs"
| hasExe pkginfo = text "program"
| otherwise = empty
reflowParagraphs :: String -> Doc
reflowParagraphs =
vcat
. 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
. lines
reflowLines :: String -> Doc
reflowLines = vcat . map text . lines
-- | We get the 'PackageDisplayInfo' by combining the info for the installed
-- and available versions of a package.
--
-- * We're building info about a various versions of a single named package so
-- the input package info records are all supposed to refer to the same
-- package name.
--
mergePackageInfo :: VersionRange
-> [Installed.InstalledPackageInfo]
-> [UnresolvedSourcePackage]
-> Maybe UnresolvedSourcePackage
-> Bool
-> PackageDisplayInfo
mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =
assert (length installedPkgs + length sourcePkgs > 0) $
PackageDisplayInfo {
pkgName = combine packageName source
packageName installed,
selectedVersion = if showVer then fmap packageVersion selectedPkg
else Nothing,
selectedSourcePkg = sourceSelected,
installedVersions = map packageVersion installedPkgs,
sourceVersions = map packageVersion sourcePkgs,
preferredVersions = versionPref,
license = combine Source.license source
Installed.license installed,
maintainer = combine Source.maintainer source
Installed.maintainer installed,
author = combine Source.author source
Installed.author installed,
homepage = combine Source.homepage source
Installed.homepage installed,
bugReports = maybe "" Source.bugReports source,
sourceRepo = fromMaybe "" . join
. fmap (uncons Nothing Source.repoLocation
. sortBy (comparing Source.repoKind)
. Source.sourceRepos)
$ source,
--TODO: installed package info is missing synopsis
synopsis = maybe "" Source.synopsis source,
description = combine Source.description source
Installed.description installed,
category = combine Source.category source
Installed.category installed,
flags = maybe [] Source.genPackageFlags sourceGeneric,
hasLib = isJust installed
|| maybe False (isJust . Source.condLibrary) sourceGeneric,
hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric,
executables = map fst (maybe [] Source.condExecutables sourceGeneric),
modules = combine (map Installed.exposedName . Installed.exposedModules)
installed
-- NB: only for the PUBLIC library
(concatMap getListOfExposedModules . maybeToList . Source.library)
source,
dependencies =
combine (map (SourceDependency . simplifyDependency)
. Source.buildDepends) source
(map InstalledDependency . Installed.depends) installed,
haddockHtml = fromMaybe "" . join
. fmap (listToMaybe . Installed.haddockHTMLs)
$ installed,
haveTarball = False
}
where
combine f x g y = fromJust (fmap f x `mplus` fmap g y)
installed :: Maybe Installed.InstalledPackageInfo
installed = latestWithPref versionPref installedPkgs
getListOfExposedModules lib = Source.exposedModules lib
++ map Source.moduleReexportName
(Source.reexportedModules lib)
sourceSelected
| isJust selectedPkg = selectedPkg
| otherwise = latestWithPref versionPref sourcePkgs
sourceGeneric = fmap packageDescription sourceSelected
source = fmap flattenPackageDescription sourceGeneric
uncons :: b -> (a -> b) -> [a] -> b
uncons z _ [] = z
uncons _ f (x:_) = f x
-- | Not all the info is pure. We have to check if the docs really are
-- installed, because the registered package info lies. Similarly we have to
-- check if the tarball has indeed been fetched.
--
updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo
updateFileSystemPackageDetails pkginfo = do
fetched <- maybe (return False) (isFetched . packageSource)
(selectedSourcePkg pkginfo)
docsExist <- doesDirectoryExist (haddockHtml pkginfo)
return pkginfo {
haveTarball = fetched,
haddockHtml = if docsExist then haddockHtml pkginfo else ""
}
latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg
latestWithPref _ [] = Nothing
latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs)
where
prefThenVersion pkg = let ver = packageVersion pkg
in (withinRange ver pref, ver)
-- | Rearrange installed and source packages into groups referring to the
-- same package by name. In the result pairs, the lists are guaranteed to not
-- both be empty.
--
mergePackages :: [Installed.InstalledPackageInfo]
-> [UnresolvedSourcePackage]
-> [( PackageName
, [Installed.InstalledPackageInfo]
, [UnresolvedSourcePackage] )]
mergePackages installedPkgs sourcePkgs =
map collect
$ mergeBy (\i a -> fst i `compare` fst a)
(groupOn packageName installedPkgs)
(groupOn packageName sourcePkgs)
where
collect (OnlyInLeft (name,is) ) = (name, is, [])
collect ( InBoth (_,is) (name,as)) = (name, is, as)
collect (OnlyInRight (name,as)) = (name, [], as)
groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]
groupOn key = map (\xs -> (key (head xs), xs))
. groupBy (equating key)
. sortBy (comparing key)
dispTopVersions :: Int -> VersionRange -> [Version] -> Doc
dispTopVersions n pref vs =
(Disp.fsep . Disp.punctuate (Disp.char ',')
. map (\ver -> if ispref ver then disp ver else parens (disp ver))
. sort . take n . interestingVersions ispref
$ vs)
<+> trailingMessage
where
ispref ver = withinRange ver pref
extra = length vs - n
trailingMessage
| extra <= 0 = Disp.empty
| otherwise = Disp.parens $ Disp.text "and"
<+> Disp.int (length vs - n)
<+> if extra == 1 then Disp.text "other"
else Disp.text "others"
-- | Reorder a bunch of versions to put the most interesting / significant
-- versions first. A preferred version range is taken into account.
--
-- This may be used in a user interface to select a small number of versions
-- to present to the user, e.g.
--
-- > let selectVersions = sort . take 5 . interestingVersions pref
--
interestingVersions :: (Version -> Bool) -> [Version] -> [Version]
interestingVersions pref =
map (mkVersion . fst) . filter snd
. concat . Tree.levels
. swizzleTree
. reorderTree (\(Node (v,_) _) -> pref (mkVersion v))
. reverseTree
. mkTree
. map versionNumbers
where
swizzleTree = unfoldTree (spine [])
where
spine ts' (Node x []) = (x, ts')
spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t
reorderTree _ (Node x []) = Node x []
reorderTree p (Node x ts) = Node x (ts' ++ ts'')
where
(ts',ts'') = partition p (map (reorderTree p) ts)
reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))
mkTree xs = unfoldTree step (False, [], xs)
where
step (node,ns,vs) =
( (reverse ns, node)
, [ (any null vs', n:ns, filter (not . null) vs')
| (n, vs') <- groups vs ]
)
groups = map (\g -> (head (head g), map tail g))
. groupBy (equating head)