cabal-install-0.10.0: Distribution/Client/List.hs
-----------------------------------------------------------------------------
-- |
-- 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
, Dependency(..), thisPackageVersion, depends, simplifyDependency )
import Distribution.ModuleName (ModuleName)
import Distribution.License (License)
import qualified Distribution.InstalledPackageInfo as Installed
import qualified Distribution.PackageDescription as Available
import Distribution.PackageDescription
( Flag(..), FlagName(..) )
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
import Distribution.Simple.Compiler
( Compiler, PackageDBStack )
import Distribution.Simple.Program (ProgramConfiguration)
import Distribution.Simple.Utils
( equating, comparing, die, notice )
import Distribution.Simple.Setup (fromFlag)
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Version
( Version(..), VersionRange, withinRange, anyVersion
, intersectVersionRanges, simplifyVersionRange )
import Distribution.Verbosity (Verbosity)
import Distribution.Text
( Text(disp), display )
import Distribution.Client.Types
( AvailablePackage(..), Repo, AvailablePackageDb(..)
, InstalledPackage(..) )
import Distribution.Client.Dependency.Types
( PackageConstraint(..) )
import Distribution.Client.Targets
( UserTarget, resolveUserTargets, PackageSpecifier(..) )
import Distribution.Client.Setup
( GlobalFlags(..), ListFlags(..), InfoFlags(..) )
import Distribution.Client.Utils
( mergeBy, MergeResult(..) )
import Distribution.Client.IndexUtils as IndexUtils
( getAvailablePackages, getInstalledPackages )
import Distribution.Client.FetchUtils
( isFetched )
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 )
import Control.Exception
( assert )
import Text.PrettyPrint.HughesPJ as Disp
import System.Directory
( doesDirectoryExist )
-- |Show information about packages
list :: Verbosity
-> PackageDBStack
-> [Repo]
-> Compiler
-> ProgramConfiguration
-> ListFlags
-> [String]
-> IO ()
list verbosity packageDBs repos comp conf listFlags pats = do
installed <- getInstalledPackages verbosity comp packageDBs conf
availableDb <- getAvailablePackages verbosity repos
let available = packageIndex availableDb
prefs name = fromMaybe anyVersion
(Map.lookup name (packagePreferences availableDb))
pkgsInfo :: [(PackageName, [InstalledPackage], [AvailablePackage])]
pkgsInfo
-- gather info for all packages
| null pats = mergePackages (PackageIndex.allPackages installed)
(PackageIndex.allPackages available)
-- gather info for packages matching search term
| otherwise = mergePackages (matchingPackages installed)
(matchingPackages available)
matches :: [PackageDisplayInfo]
matches = [ mergePackageInfo pref
installedPkgs availablePkgs selectedPkg False
| (pkgname, installedPkgs, availablePkgs) <- pkgsInfo
, not onlyInstalled || not (null installedPkgs)
, let pref = prefs pkgname
selectedPkg = latestWithPref pref availablePkgs ]
if simpleOutput
then putStr $ unlines
[ display (pkgName pkg) ++ " " ++ display version
| pkg <- matches
, version <- if onlyInstalled
then installedVersions pkg
else nub . sort $ installedVersions pkg
++ availableVersions pkg ]
-- Note: this only works because for 'list', one cannot currently
-- specify any version constraints, so listing all installed
-- and available 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)
matchingPackages index =
[ pkg
| pat <- pats
, (_, pkgs) <- PackageIndex.searchByNameSubstring index pat
, pkg <- pkgs ]
info :: Verbosity
-> PackageDBStack
-> [Repo]
-> Compiler
-> ProgramConfiguration
-> GlobalFlags
-> InfoFlags
-> [UserTarget]
-> IO ()
info verbosity packageDBs repos comp conf
globalFlags _listFlags userTargets = do
installed <- getInstalledPackages verbosity comp packageDBs conf
availableDb <- getAvailablePackages verbosity repos
let available = packageIndex availableDb
prefs name = fromMaybe anyVersion
(Map.lookup name (packagePreferences availableDb))
-- 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 available packages.
let available' = PackageIndex.fromList
$ map packageId (PackageIndex.allPackages installed)
++ map packageId (PackageIndex.allPackages available)
pkgSpecifiers <- resolveUserTargets verbosity
globalFlags available' userTargets
pkgsinfo <- sequence
[ do pkginfo <- either die return $
gatherPkgInfo prefs
installed available pkgSpecifier
updateFileSystemPackageDetails pkginfo
| pkgSpecifier <- pkgSpecifiers ]
putStr $ unlines (map showPackageDetailedInfo pkgsinfo)
where
gatherPkgInfo prefs installed available (NamedPackage name constraints)
| null (selectedInstalledPkgs) && null (selectedAvailablePkgs)
= Left $ "There is no available version of " ++ display name
++ " that satisfies "
++ display (simplifyVersionRange verConstraint)
| otherwise
= Right $ mergePackageInfo pref installedPkgs
availablePkgs selectedAvailablePkg
showPkgVersion
where
pref = prefs name
installedPkgs = PackageIndex.lookupPackageName installed name
availablePkgs = PackageIndex.lookupPackageName available name
selectedInstalledPkgs = PackageIndex.lookupDependency installed
(Dependency name verConstraint)
selectedAvailablePkgs = PackageIndex.lookupDependency available
(Dependency name verConstraint)
selectedAvailablePkg = latestWithPref pref selectedAvailablePkgs
-- 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 | PackageVersionConstraint _ vr <- constraints ]
gatherPkgInfo prefs installed available (SpecificSourcePackage pkg) =
Right $ mergePackageInfo pref installedPkgs availablePkgs
selectedPkg True
where
name = packageName pkg
pref = prefs name
installedPkgs = PackageIndex.lookupPackageName installed name
availablePkgs = PackageIndex.lookupPackageName available name
selectedPkg = Just pkg
-- | The info that we can display for each package. It is information per
-- package name and covers all installed and avilable versions.
--
data PackageDisplayInfo = PackageDisplayInfo {
pkgName :: PackageName,
selectedVersion :: Maybe Version,
selectedAvailable :: Maybe AvailablePackage,
installedVersions :: [Version],
availableVersions :: [Version],
preferredVersions :: VersionRange,
homepage :: String,
bugReports :: String,
sourceRepo :: String,
synopsis :: String,
description :: String,
category :: String,
license :: License,
author :: String,
maintainer :: String,
dependencies :: [Dependency],
flags :: [Flag],
hasLib :: Bool,
hasExe :: Bool,
executables :: [String],
modules :: [ModuleName],
haddockHtml :: FilePath,
haveTarball :: Bool
}
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 selectedAvailable 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)
<> maybe empty (\v -> char '-' <> disp v) (selectedVersion pkginfo)
<+> text (replicate (16 - length (display (pkgName pkginfo))) ' ')
<> parens pkgkind
$+$
(nest 4 $ vcat [
entry "Synopsis" synopsis hideIfNull reflowParagraphs
, entry "Versions available" availableVersions
(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 text)
, entry "Flags" flags hideIfNull (commaSep dispFlag)
, entry "Dependencies" dependencies hideIfNull (commaSep disp)
, 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 <> char ':' <> 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 f = case flagName f of FlagName n -> text n
dispYesNo True = text "Yes"
dispYesNo False = text "No"
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
-> [InstalledPackage]
-> [AvailablePackage]
-> Maybe AvailablePackage
-> Bool
-> PackageDisplayInfo
mergePackageInfo versionPref installedPkgs availablePkgs selectedPkg showVer =
assert (length installedPkgs + length availablePkgs > 0) $
PackageDisplayInfo {
pkgName = combine packageName available
packageName installed,
selectedVersion = if showVer then fmap packageVersion selectedPkg
else Nothing,
selectedAvailable = availableSelected,
installedVersions = map packageVersion installedPkgs,
availableVersions = map packageVersion availablePkgs,
preferredVersions = versionPref,
license = combine Available.license available
Installed.license installed,
maintainer = combine Available.maintainer available
Installed.maintainer installed,
author = combine Available.author available
Installed.author installed,
homepage = combine Available.homepage available
Installed.homepage installed,
bugReports = maybe "" Available.bugReports available,
sourceRepo = fromMaybe "" . join
. fmap (uncons Nothing Available.repoLocation
. sortBy (comparing Available.repoKind)
. Available.sourceRepos)
$ available,
--TODO: installed package info is missing synopsis
synopsis = maybe "" Available.synopsis available,
description = combine Available.description available
Installed.description installed,
category = combine Available.category available
Installed.category installed,
flags = maybe [] Available.genPackageFlags availableGeneric,
hasLib = isJust installed
|| fromMaybe False
(fmap (isJust . Available.condLibrary) availableGeneric),
hasExe = fromMaybe False
(fmap (not . null . Available.condExecutables) availableGeneric),
executables = map fst (maybe [] Available.condExecutables availableGeneric),
modules = combine Installed.exposedModules installed
(maybe [] Available.exposedModules
. Available.library) available,
dependencies = map simplifyDependency
$ combine Available.buildDepends available
(map thisPackageVersion . 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' = latestWithPref versionPref installedPkgs
installed = fmap (\(InstalledPackage p _) -> p) installed'
availableSelected
| isJust selectedPkg = selectedPkg
| otherwise = latestWithPref versionPref availablePkgs
availableGeneric = fmap packageDescription availableSelected
available = fmap flattenPackageDescription availableGeneric
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)
(selectedAvailable 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 available packages into groups referring to the
-- same package by name. In the result pairs, the lists are guaranteed to not
-- both be empty.
--
mergePackages :: [InstalledPackage]
-> [AvailablePackage]
-> [( PackageName
, [InstalledPackage]
, [AvailablePackage] )]
mergePackages installed available =
map collect
$ mergeBy (\i a -> fst i `compare` fst a)
(groupOn packageName installed)
(groupOn packageName available)
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 ((\ns -> Version ns []) . fst) . filter snd
. concat . Tree.levels
. swizzleTree
. reorderTree (\(Node (v,_) _) -> pref (Version v []))
. reverseTree
. mkTree
. map versionBranch
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)