Skip to content

Commit

Permalink
Add initial implementation of cabal info
Browse files Browse the repository at this point in the history 
It provides more detailed information on a particular package.
Still a few TODOs. Fixes #361, #449 and #456.
  • Loading branch information
@dcoutts
dcoutts committed Jan 19, 2009
1 parent 3f74ca8 commit bdf999b
Show file tree
Hide file tree
Showing 3 changed files with 237 additions and 53 deletions.
224 changes: 184 additions & 40 deletions Distribution/Client/List.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand All @@ -77,32 +85,66 @@ 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)
| otherwise = id
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 ]"
Expand All @@ -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.
Expand All @@ -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
Expand All @@ -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)
Expand Down
46 changes: 34 additions & 12 deletions Distribution/Client/Setup.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,7 @@ module Distribution.Client.Setup
, listCommand, ListFlags(..)
, updateCommand
, upgradeCommand
, infoCommand
, infoCommand, InfoFlags(..)
, fetchCommand
, checkCommand
, uploadCommand, UploadFlags(..)
Expand Down Expand Up @@ -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",
Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -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
-- ------------------------------------------------------------
Expand Down
Loading

0 comments on commit bdf999b

Please sign in to comment.