Commit f8b6d010 authored by Duncan Coutts's avatar Duncan Coutts

Add initial implementation of cabal info

It provides more detailed information on a particular package.
Still a few TODOs. Fixes #361, #449 and #456.
parent b02da8c0
......@@ -11,32 +11,40 @@
-- High level interface to package installation.
-----------------------------------------------------------------------------
module Distribution.Client.List (
list
list, info
) where
import Data.List (sortBy, groupBy, sort, nub, intersperse)
import Data.Maybe (listToMaybe, fromJust)
import Control.Monad (MonadPlus(mplus))
import Data.List (sortBy, groupBy, sort, nub, intersperse, maximumBy)
import Data.Maybe (listToMaybe, fromJust, fromMaybe)
import Control.Monad (MonadPlus(mplus), join)
import Control.Exception (assert)
import Text.PrettyPrint.HughesPJ
import Text.PrettyPrint.HughesPJ as Disp
import Distribution.Text
( Text(disp), display )
import Distribution.Package
( PackageIdentifier(..), PackageName(..), Package(..) )
( PackageName(..), Package(..), packageName, packageVersion
, Dependency(..), thisPackageVersion )
import Distribution.ModuleName (ModuleName)
import Distribution.License (License)
import qualified Distribution.PackageDescription as Available
import Distribution.PackageDescription
( Flag(..), FlagName(..) )
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as Installed
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Version (Version)
import Distribution.Verbosity (Verbosity)
import Distribution.Client.IndexUtils (getAvailablePackages)
import Distribution.Client.Setup (ListFlags(..))
import Distribution.Client.IndexUtils as IndexUtils
( getAvailablePackages, disambiguateDependencies )
import Distribution.Client.Setup (ListFlags(..), InfoFlags(..))
import Distribution.Client.Types
( AvailablePackage(..), Repo, AvailablePackageDb(..) )
( AvailablePackage(..), Repo, AvailablePackageDb(..)
, UnresolvedDependency(..) )
import Distribution.Simple.Configure (getInstalledPackages)
import Distribution.Simple.Compiler (Compiler,PackageDB)
import Distribution.Simple.Program (ProgramConfiguration)
......@@ -68,7 +76,7 @@ list verbosity packageDB repos comp conf listFlags pats = do
if simpleOutput
then putStr $ unlines
[ display(name pkg) ++ " " ++ display version
[ display (pkgname pkg) ++ " " ++ display version
| pkg <- matches
, version <- if onlyInstalled
then installedVersions pkg
......@@ -77,7 +85,7 @@ list verbosity packageDB repos comp conf listFlags pats = do
else
if null matches
then notice verbosity "No matches found."
else putStr $ unlines (map showPackageInfo matches)
else putStr $ unlines (map showPackageSummaryInfo matches)
where
installedFilter
| onlyInstalled = filter (not . null . installedVersions)
......@@ -85,24 +93,58 @@ list verbosity packageDB repos comp conf listFlags pats = do
onlyInstalled = fromFlag (listInstalled listFlags)
simpleOutput = fromFlag (listSimpleOutput listFlags)
info :: Verbosity
-> PackageDB
-> [Repo]
-> Compiler
-> ProgramConfiguration
-> InfoFlags
-> [UnresolvedDependency] --FIXME: just package names? or actually use the constraint
-> IO ()
info verbosity packageDB repos comp conf _listFlags deps = do
AvailablePackageDb available _ <- getAvailablePackages verbosity repos
deps' <- IndexUtils.disambiguateDependencies available deps
Just installed <- getInstalledPackages verbosity comp packageDB conf
let deps'' = [ name | UnresolvedDependency (Dependency name _) _ <- deps' ]
let pkgs = (concatMap (PackageIndex.lookupPackageName installed) deps''
,concatMap (PackageIndex.lookupPackageName available) deps'')
pkgsinfo = map (uncurry mergePackageInfo)
$ uncurry mergePackages pkgs
pkgsinfo' <- mapM updateFileSystemPackageDetails pkgsinfo
putStr $ unlines (map showPackageDetailedInfo pkgsinfo')
-- | 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 {
name :: PackageName,
pkgname :: PackageName,
installedVersions :: [Version],
availableVersions :: [Version],
homepage :: String,
bugReports :: String,
sourceRepo :: String,
synopsis :: String,
license :: License
description :: String,
category :: String,
license :: License,
-- copyright :: String, --TODO: is this useful?
author :: String,
maintainer :: String,
dependencies :: [Dependency],
flags :: [Flag],
executables :: [String],
modules :: [ModuleName],
haddockHtml :: FilePath,
haveTarball :: Bool
}
showPackageInfo :: PackageDisplayInfo -> String
showPackageInfo pkg =
showPackageSummaryInfo :: PackageDisplayInfo -> String
showPackageSummaryInfo pkg =
renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
text " *" <+> disp (name pkg)
char '*' <+> disp (pkgname pkg)
$+$
(nest 6 $ vcat [
(nest 4 $ vcat [
text "Latest version available:" <+>
case availableVersions pkg of
[] -> text "[ Not available from server ]"
......@@ -112,19 +154,84 @@ showPackageInfo pkg =
[] -> text "[ Not installed ]"
vs -> disp (maximum vs)
, maybeShow (homepage pkg) "Homepage:" text
, maybeShow (synopsis pkg) "Synopsis:" reflowParas
, maybeShow (synopsis pkg) "Synopsis:" reflowParagraphs
, text "License: " <+> text (show (license pkg))
])
$+$ text ""
where
maybeShow [] _ _ = empty
maybeShow l s f = text s <+> (f l)
reflowParas = vcat
. intersperse (text "") -- re-insert blank lines
. map (fsep . map text . concatMap words) -- reflow paras
. filter (/= [""])
. groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines
. lines
showPackageDetailedInfo :: PackageDisplayInfo -> String
showPackageDetailedInfo pkg =
renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
char '*' <+> disp (pkgname pkg)
$+$
(nest 4 $ vcat [
entry "Latest version available" availableVersions
(altText "[ Not available from server ]")
(disp . maximum)
, entry "Latest version installed" installedVersions
(altText "[ Not installed ]") --FIXME: unknown for non-libs
(disp . maximum)
, entry "Homepage" homepage orNotSpecified text
, entry "Bug reports" bugReports orNotSpecified text
, entry "Description" description alwaysShow 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 "Downloaded" haveTarball alwaysShow dispYesNo
, text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkg))
])
$+$ text ""
where
entry fname field cond format = case cond (field pkg) of
Nothing -> label <+> format (field pkg)
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 msg v = if null v then replace msg else normal
orNotSpecified = altText "[ 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 pkg))
-- hasLibs = --TODO
-- hasExes = --TODO
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.
......@@ -139,25 +246,62 @@ mergePackageInfo :: [InstalledPackageInfo]
mergePackageInfo installed available =
assert (length installed + length available > 0) $
PackageDisplayInfo {
name = combine (pkgName . packageId) latestAvailable
(pkgName . packageId) latestInstalled,
installedVersions = map (pkgVersion . packageId) installed,
availableVersions = map (pkgVersion . packageId) available,
homepage = combine Available.homepage latestAvailableDesc
Installed.homepage latestInstalled,
synopsis = combine Available.synopsis latestAvailableDesc
Installed.description latestInstalled,
license = combine Available.license latestAvailableDesc
Installed.license latestInstalled
pkgname = combine packageName latestAvailable
packageName latestInstalled,
installedVersions = map packageVersion installed,
availableVersions = map packageVersion available,
license = combine Available.license latestAvailableDesc
Installed.license latestInstalled,
maintainer = combine Available.maintainer latestAvailableDesc
Installed.maintainer latestInstalled,
author = combine Available.author latestAvailableDesc
Installed.author latestInstalled,
homepage = combine Available.homepage latestAvailableDesc
Installed.homepage latestInstalled,
bugReports = maybe "" Available.bugReports latestAvailableDesc,
sourceRepo = fromMaybe "" . join
. fmap (uncons Nothing Available.repoLocation
. sortBy (comparing Available.repoKind)
. Available.sourceRepos)
$ latestAvailableDesc,
synopsis = combine Available.synopsis latestAvailableDesc
Installed.description latestInstalled,
description = combine Available.description latestAvailableDesc
Installed.description latestInstalled,
category = combine Available.category latestAvailableDesc
Installed.category latestInstalled,
flags = maybe [] Available.genPackageFlags latestAvailable,
executables = map fst (maybe [] Available.condExecutables latestAvailable),
modules = combine Installed.exposedModules latestInstalled
(maybe [] Available.exposedModules
. Available.library) latestAvailableDesc,
dependencies = combine Available.buildDepends latestAvailableDesc
(map thisPackageVersion
. Installed.depends) latestInstalled,
haddockHtml = fromMaybe "" . join
. fmap (listToMaybe . Installed.haddockHTMLs)
$ latestInstalled,
haveTarball = False
}
where
combine f x g y = fromJust (fmap f x `mplus` fmap g y)
latestInstalled = latestOf installed
latestAvailable = latestOf available
latestAvailableDesc = fmap (Available.packageDescription . packageDescription)
latestAvailable
latestAvailable = packageDescription `fmap` latestOf available
latestAvailableDesc = fmap flattenPackageDescription latestAvailable
latestOf :: Package pkg => [pkg] -> Maybe pkg
latestOf = listToMaybe . sortBy (comparing (pkgVersion . packageId))
latestOf [] = Nothing
latestOf pkgs = Just (maximumBy (comparing packageVersion) pkgs)
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 = return --FIXME
-- | Rearrange installed and available packages into groups referring to the
-- same package by name. In the result pairs, the lists are guaranteed to not
......@@ -168,8 +312,8 @@ mergePackages :: [InstalledPackageInfo] -> [AvailablePackage]
mergePackages installed available =
map collect
$ mergeBy (\i a -> fst i `compare` fst a)
(groupOn (pkgName . packageId) installed)
(groupOn (pkgName . packageId) available)
(groupOn packageName installed)
(groupOn packageName available)
where
collect (OnlyInLeft (_,is) ) = (is, [])
collect ( InBoth (_,is) (_,as)) = (is, as)
......
......@@ -17,7 +17,7 @@ module Distribution.Client.Setup
, listCommand, ListFlags(..)
, updateCommand
, upgradeCommand
, infoCommand
, infoCommand, InfoFlags(..)
, fetchCommand
, checkCommand
, uploadCommand, UploadFlags(..)
......@@ -244,16 +244,6 @@ cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
options _ = []
-}
infoCommand :: CommandUI (Flag Verbosity)
infoCommand = CommandUI {
commandName = "info",
commandSynopsis = "Emit some info about dependency resolution",
commandDescription = Nothing,
commandUsage = usagePackages "info",
commandDefaultFlags = toFlag normal,
commandOptions = \_ -> [optionVerbosity id const]
}
checkCommand :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
commandName = "check",
......@@ -334,7 +324,7 @@ defaultListFlags = ListFlags {
listCommand :: CommandUI ListFlags
listCommand = CommandUI {
commandName = "list",
commandSynopsis = "List available packages on the server (cached).",
commandSynopsis = "List packages matching a search string.",
commandDescription = Nothing,
commandUsage = usagePackages "list",
commandDefaultFlags = defaultListFlags,
......@@ -363,6 +353,38 @@ instance Monoid ListFlags where
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Info flags
-- ------------------------------------------------------------
data InfoFlags = InfoFlags {
infoVerbosity :: Flag Verbosity
}
defaultInfoFlags :: InfoFlags
defaultInfoFlags = InfoFlags {
infoVerbosity = toFlag normal
}
infoCommand :: CommandUI InfoFlags
infoCommand = CommandUI {
commandName = "info",
commandSynopsis = "Display detailed information about a particular package.",
commandDescription = Nothing,
commandUsage = usagePackages "info",
commandDefaultFlags = defaultInfoFlags,
commandOptions = \_ -> [
optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })
]
}
instance Monoid InfoFlags where
mempty = defaultInfoFlags
mappend a b = InfoFlags {
infoVerbosity = combine infoVerbosity
}
where combine field = field a `mappend` field b
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------
......
......@@ -20,6 +20,7 @@ import Distribution.Client.Setup
, fetchCommand, checkCommand
, updateCommand
, ListFlags(..), listCommand
, InfoFlags(..), infoCommand
, UploadFlags(..), uploadCommand
, reportCommand
, unpackCommand, UnpackFlags(..)
......@@ -41,7 +42,7 @@ import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.Config
( SavedConfig(..), loadConfig, defaultConfigFile )
import Distribution.Client.List (list)
import Distribution.Client.List (list, info)
import Distribution.Client.Install (install, upgrade)
import Distribution.Client.Update (update)
import Distribution.Client.Fetch (fetch)
......@@ -117,6 +118,7 @@ mainWorker args =
[configureCommand `commandAddAction` configureAction
,installCommand `commandAddAction` installAction
,listCommand `commandAddAction` listAction
,infoCommand `commandAddAction` infoAction
,updateCommand `commandAddAction` updateAction
,upgradeCommand `commandAddAction` upgradeAction
,fetchCommand `commandAddAction` fetchAction
......@@ -212,6 +214,22 @@ listAction listFlags extraArgs globalFlags = do
listFlags
extraArgs
infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()
infoAction infoFlags extraArgs globalFlags = do
pkgs <- either die return (parsePackageArgs extraArgs)
let verbosity = fromFlag (infoVerbosity infoFlags)
config <- loadConfig verbosity (globalConfigFile globalFlags) mempty
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, conf) <- configCompilerAux configFlags
info verbosity
(configPackageDB' configFlags)
(globalRepos globalFlags')
comp
conf
infoFlags
[ UnresolvedDependency pkg [] | pkg <- pkgs ]
updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()
updateAction verbosityFlag extraArgs globalFlags = do
unless (null extraArgs) $ do
......
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