cabal-install/src/Distribution/Client/List.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2
   3 -----------------------------------------------------------------------------
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Client.List
   9 -- Copyright   :  (c) David Himmelstrup 2005
  10 --                    Duncan Coutts 2008-2011
  11 -- License     :  BSD-like
  12 --
  13 -- Maintainer  :  cabal-devel@haskell.org
  14 --
  15 -- Search for and print information about packages
  16 module Distribution.Client.List
  17   ( list
  18   , info
  19   ) where
  20
  21 import Distribution.Client.Compat.Prelude
  22 import Prelude ()
  23
  24 import qualified Distribution.InstalledPackageInfo as Installed
  25 import Distribution.License (License)
  26 import Distribution.ModuleName (ModuleName)
  27 import Distribution.Package
  28   ( Package (..)
  29   , PackageName
  30   , UnitId
  31   , packageName
  32   , packageVersion
  33   )
  34 import Distribution.PackageDescription
  35   ( PackageFlag (..)
  36   , unFlagName
  37   )
  38 import qualified Distribution.PackageDescription as Source
  39 import Distribution.PackageDescription.Configuration
  40   ( flattenPackageDescription
  41   )
  42 import Distribution.Types.Dependency
  43 import Distribution.Types.UnqualComponentName
  44
  45 import Distribution.Simple.Compiler
  46 import Distribution.Simple.PackageIndex (InstalledPackageIndex)
  47 import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
  48 import Distribution.Simple.Program (ProgramDb)
  49 import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault)
  50 import Distribution.Simple.Utils
  51   ( dieWithException
  52   , equating
  53   , notice
  54   )
  55 import Distribution.Version
  56   ( Version
  57   , VersionRange
  58   , anyVersion
  59   , intersectVersionRanges
  60   , mkVersion
  61   , simplifyVersionRange
  62   , versionNumbers
  63   , withinRange
  64   )
  65
  66 import qualified Distribution.SPDX as SPDX
  67
  68 import Distribution.Solver.Types.PackageConstraint
  69 import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
  70 import Distribution.Solver.Types.SourcePackage
  71
  72 import Distribution.Client.FetchUtils
  73   ( isFetched
  74   )
  75 import Distribution.Client.IndexUtils as IndexUtils
  76   ( getInstalledPackages
  77   , getSourcePackages
  78   )
  79 import Distribution.Client.Setup
  80   ( GlobalFlags (..)
  81   , InfoFlags (..)
  82   , ListFlags (..)
  83   , RepoContext (..)
  84   )
  85 import Distribution.Client.Targets
  86   ( UserTarget
  87   , resolveUserTargets
  88   )
  89 import Distribution.Client.Types
  90   ( PackageSpecifier (..)
  91   , SourcePackageDb (..)
  92   , UnresolvedSourcePackage
  93   )
  94 import Distribution.Client.Utils
  95   ( MergeResult (..)
  96   , mergeBy
  97   )
  98
  99 import Control.Exception
 100   ( assert
 101   )
 102 import Data.Bits ((.|.))
 103 import Data.List
 104   ( maximumBy
 105   )
 106 import qualified Data.List as L
 107 import Data.List.NonEmpty (groupBy)
 108 import qualified Data.Map as Map
 109 import Data.Maybe
 110   ( fromJust
 111   )
 112 import Data.Tree as Tree
 113 import System.Directory
 114   ( doesDirectoryExist
 115   )
 116 import Text.PrettyPrint
 117   ( Doc
 118   , char
 119   , fsep
 120   , lineLength
 121   , nest
 122   , parens
 123   , renderStyle
 124   , ribbonsPerLine
 125   , style
 126   , text
 127   , vcat
 128   , ($+$)
 129   )
 130 import qualified Text.PrettyPrint as Disp
 131
 132 import Distribution.Client.Errors
 133 import Distribution.Utils.ShortText (ShortText)
 134 import qualified Distribution.Utils.ShortText as ShortText
 135 import qualified Text.Regex.Base as Regex
 136 import qualified Text.Regex.Posix.String as Regex
 137
 138 -- | Return a list of packages matching given search strings.
 139 getPkgList
 140   :: Verbosity
 141   -> PackageDBStackCWD
 142   -> RepoContext
 143   -> Maybe (Compiler, ProgramDb)
 144   -> ListFlags
 145   -> [String]
 146   -> IO [PackageDisplayInfo]
 147 getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do
 148   installedPkgIndex <- for mcompprogdb $ \(comp, progdb) ->
 149     getInstalledPackages verbosity comp packageDBs progdb
 150   sourcePkgDb <- getSourcePackages verbosity repoCtxt
 151
 152   regexps <- for pats $ \pat -> do
 153     e <- Regex.compile compOption Regex.execBlank pat
 154     case e of
 155       Right r -> return r
 156       Left err -> dieWithException verbosity $ GetPkgList pat err
 157
 158   let sourcePkgIndex = packageIndex sourcePkgDb
 159       prefs name =
 160         fromMaybe
 161           anyVersion
 162           (Map.lookup name (packagePreferences sourcePkgDb))
 163
 164       pkgsInfoMatching
 165         :: [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
 166       pkgsInfoMatching =
 167         let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex
 168             matchingSource = matchingPackages (\idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex
 169          in mergePackages matchingInstalled matchingSource
 170
 171       pkgsInfo
 172         :: [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
 173       pkgsInfo
 174         -- gather info for all packages
 175         | null regexps =
 176             mergePackages
 177               (maybe [] InstalledPackageIndex.allPackages installedPkgIndex)
 178               (PackageIndex.allPackages sourcePkgIndex)
 179         -- gather info for packages matching search term
 180         | otherwise = pkgsInfoMatching
 181
 182       matches :: [PackageDisplayInfo]
 183       matches =
 184         [ mergePackageInfo
 185           pref
 186           installedPkgs
 187           sourcePkgs
 188           selectedPkg
 189           False
 190         | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo
 191         , not onlyInstalled || not (null installedPkgs)
 192         , let pref = prefs pkgname
 193               selectedPkg = latestWithPref pref sourcePkgs
 194         ]
 195   return matches
 196   where
 197     onlyInstalled = fromFlagOrDefault False (listInstalled listFlags)
 198     caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags)
 199
 200     compOption
 201       | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase
 202       | otherwise = Regex.compExtended
 203
 204     matchingPackages search regexps index =
 205       [ pkg
 206       | re <- regexps
 207       , pkg <- search index (Regex.matchTest re)
 208       ]
 209
 210 -- | Show information about packages.
 211 list
 212   :: Verbosity
 213   -> PackageDBStackCWD
 214   -> RepoContext
 215   -> Maybe (Compiler, ProgramDb)
 216   -> ListFlags
 217   -> [String]
 218   -> IO ()
 219 list verbosity packageDBs repos mcompProgdb listFlags pats = do
 220   matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats
 221
 222   if simpleOutput
 223     then
 224       putStr $
 225         unlines
 226           [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version
 227           | pkg <- matches
 228           , version <-
 229               if onlyInstalled
 230                 then installedVersions pkg
 231                 else
 232                   nub . sort $
 233                     installedVersions pkg
 234                       ++ sourceVersions pkg
 235           ]
 236     else -- Note: this only works because for 'list', one cannot currently
 237     -- specify any version constraints, so listing all installed
 238     -- and source ones works.
 239
 240       if null matches
 241         then notice verbosity "No matches found."
 242         else putStr $ unlines (map showPackageSummaryInfo matches)
 243   where
 244     onlyInstalled = fromFlag (listInstalled listFlags)
 245     simpleOutput = fromFlag (listSimpleOutput listFlags)
 246
 247 info
 248   :: Verbosity
 249   -> PackageDBStackCWD
 250   -> RepoContext
 251   -> Compiler
 252   -> ProgramDb
 253   -> GlobalFlags
 254   -> InfoFlags
 255   -> [UserTarget]
 256   -> IO ()
 257 info verbosity _ _ _ _ _ _ [] =
 258   notice verbosity "No packages requested. Nothing to do."
 259 info
 260   verbosity
 261   packageDBs
 262   repoCtxt
 263   comp
 264   progdb
 265   _
 266   _listFlags
 267   userTargets = do
 268     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
 269     sourcePkgDb <- getSourcePackages verbosity repoCtxt
 270     let sourcePkgIndex = packageIndex sourcePkgDb
 271         prefs name =
 272           fromMaybe
 273             anyVersion
 274             (Map.lookup name (packagePreferences sourcePkgDb))
 275
 276     -- Users may specify names of packages that are only installed, not
 277     -- just available source packages, so we must resolve targets using
 278     -- the combination of installed and source packages.
 279     let sourcePkgs' =
 280           PackageIndex.fromList $
 281             map
 282               packageId
 283               (InstalledPackageIndex.allPackages installedPkgIndex)
 284               ++ map
 285                 packageId
 286                 (PackageIndex.allPackages sourcePkgIndex)
 287     pkgSpecifiers <-
 288       resolveUserTargets
 289         verbosity
 290         repoCtxt
 291         sourcePkgs'
 292         userTargets
 293
 294     pkgsinfo <-
 295       sequenceA
 296         [ do
 297           pkginfo <-
 298             either (dieWithException verbosity) return $
 299               gatherPkgInfo
 300                 prefs
 301                 installedPkgIndex
 302                 sourcePkgIndex
 303                 pkgSpecifier
 304           updateFileSystemPackageDetails pkginfo
 305         | pkgSpecifier <- pkgSpecifiers
 306         ]
 307
 308     putStr $ unlines (map showPackageDetailedInfo pkgsinfo)
 309     where
 310       gatherPkgInfo
 311         :: (PackageName -> VersionRange)
 312         -> InstalledPackageIndex
 313         -> PackageIndex.PackageIndex UnresolvedSourcePackage
 314         -> PackageSpecifier UnresolvedSourcePackage
 315         -> Either CabalInstallException PackageDisplayInfo
 316       gatherPkgInfo
 317         prefs
 318         installedPkgIndex
 319         sourcePkgIndex
 320         (NamedPackage name props)
 321           | null (selectedInstalledPkgs) && null (selectedSourcePkgs) =
 322               Left $ GatherPkgInfo name (simplifyVersionRange verConstraint)
 323           | otherwise =
 324               Right $
 325                 mergePackageInfo
 326                   pref
 327                   installedPkgs
 328                   sourcePkgs
 329                   selectedSourcePkg'
 330                   showPkgVersion
 331           where
 332             (pref, installedPkgs, sourcePkgs) =
 333               sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex
 334
 335             selectedInstalledPkgs =
 336               InstalledPackageIndex.lookupDependency
 337                 installedPkgIndex
 338                 name
 339                 verConstraint
 340             selectedSourcePkgs =
 341               PackageIndex.lookupDependency
 342                 sourcePkgIndex
 343                 name
 344                 verConstraint
 345             selectedSourcePkg' = latestWithPref pref selectedSourcePkgs
 346
 347             -- display a specific package version if the user
 348             -- supplied a non-trivial version constraint
 349             showPkgVersion = not (null verConstraints)
 350             verConstraint = foldr intersectVersionRanges anyVersion verConstraints
 351             verConstraints = [vr | PackagePropertyVersion vr <- props]
 352       gatherPkgInfo
 353         prefs
 354         installedPkgIndex
 355         sourcePkgIndex
 356         (SpecificSourcePackage pkg) =
 357           Right $
 358             mergePackageInfo
 359               pref
 360               installedPkgs
 361               sourcePkgs
 362               selectedPkg
 363               True
 364           where
 365             name = packageName pkg
 366             selectedPkg = Just pkg
 367             (pref, installedPkgs, sourcePkgs) =
 368               sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex
 369
 370 sourcePkgsInfo
 371   :: (PackageName -> VersionRange)
 372   -> PackageName
 373   -> InstalledPackageIndex
 374   -> PackageIndex.PackageIndex UnresolvedSourcePackage
 375   -> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])
 376 sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex =
 377   (pref, installedPkgs, sourcePkgs)
 378   where
 379     pref = prefs name
 380     installedPkgs =
 381       concatMap
 382         snd
 383         ( InstalledPackageIndex.lookupPackageName
 384             installedPkgIndex
 385             name
 386         )
 387     sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name
 388
 389 -- | The info that we can display for each package. It is information per
 390 -- package name and covers all installed and available versions.
 391 data PackageDisplayInfo = PackageDisplayInfo
 392   { pkgName :: PackageName
 393   , selectedVersion :: Maybe Version
 394   , selectedSourcePkg :: Maybe UnresolvedSourcePackage
 395   , installedVersions :: [Version]
 396   , sourceVersions :: [Version]
 397   , preferredVersions :: VersionRange
 398   , homepage :: ShortText
 399   , bugReports :: ShortText
 400   , sourceRepo :: String -- TODO
 401   , synopsis :: ShortText
 402   , description :: ShortText
 403   , category :: ShortText
 404   , license :: Either SPDX.License License
 405   , author :: ShortText
 406   , maintainer :: ShortText
 407   , dependencies :: [ExtDependency]
 408   , flags :: [PackageFlag]
 409   , hasLib :: Bool
 410   , hasExe :: Bool
 411   , executables :: [UnqualComponentName]
 412   , modules :: [ModuleName]
 413   , haddockHtml :: FilePath
 414   , haveTarball :: Bool
 415   }
 416
 417 -- | Covers source dependencies and installed dependencies in
 418 -- one type.
 419 data ExtDependency
 420   = SourceDependency Dependency
 421   | InstalledDependency UnitId
 422
 423 showPackageSummaryInfo :: PackageDisplayInfo -> String
 424 showPackageSummaryInfo pkginfo =
 425   renderStyle (style{lineLength = 80, ribbonsPerLine = 1}) $
 426     char '*'
 427       <+> pretty (pkgName pkginfo)
 428       $+$ nest
 429         4
 430         ( vcat
 431             [ maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs
 432             , text "Default available version:"
 433                 <+> case selectedSourcePkg pkginfo of
 434                   Nothing -> text "[ Not available from any configured repository ]"
 435                   Just pkg -> pretty (packageVersion pkg)
 436             , text "Installed versions:"
 437                 <+> case installedVersions pkginfo of
 438                   []
 439                     | hasLib pkginfo -> text "[ Not installed ]"
 440                     | otherwise -> text "[ Unknown ]"
 441                   versions ->
 442                     dispTopVersions
 443                       4
 444                       (preferredVersions pkginfo)
 445                       versions
 446             , maybeShowST (homepage pkginfo) "Homepage:" text
 447             , text "License: " <+> either pretty pretty (license pkginfo)
 448             ]
 449         )
 450       $+$ text ""
 451   where
 452     maybeShowST l s f
 453       | ShortText.null l = Disp.empty
 454       | otherwise = text s <+> f (ShortText.fromShortText l)
 455
 456 showPackageDetailedInfo :: PackageDisplayInfo -> String
 457 showPackageDetailedInfo pkginfo =
 458   renderStyle (style{lineLength = 80, ribbonsPerLine = 1}) $
 459     char '*'
 460       <+> pretty (pkgName pkginfo)
 461         <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo)
 462       <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ')
 463         <<>> parens pkgkind
 464       $+$ nest
 465         4
 466         ( vcat
 467             [ entryST "Synopsis" synopsis hideIfNull reflowParagraphs
 468             , entry
 469                 "Versions available"
 470                 sourceVersions
 471                 (altText null "[ Not available from server ]")
 472                 (dispTopVersions 9 (preferredVersions pkginfo))
 473             , entry
 474                 "Versions installed"
 475                 installedVersions
 476                 ( altText
 477                     null
 478                     ( if hasLib pkginfo
 479                         then "[ Not installed ]"
 480                         else "[ Unknown ]"
 481                     )
 482                 )
 483                 (dispTopVersions 4 (preferredVersions pkginfo))
 484             , entryST "Homepage" homepage orNotSpecified text
 485             , entryST "Bug reports" bugReports orNotSpecified text
 486             , entryST "Description" description hideIfNull reflowParagraphs
 487             , entryST "Category" category hideIfNull text
 488             , entry "License" license alwaysShow (either pretty pretty)
 489             , entryST "Author" author hideIfNull reflowLines
 490             , entryST "Maintainer" maintainer hideIfNull reflowLines
 491             , entry "Source repo" sourceRepo orNotSpecified text
 492             , entry "Executables" executables hideIfNull (commaSep pretty)
 493             , entry "Flags" flags hideIfNull (commaSep dispFlag)
 494             , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
 495             , entry "Documentation" haddockHtml showIfInstalled text
 496             , entry "Cached" haveTarball alwaysShow dispYesNo
 497             , if not (hasLib pkginfo)
 498                 then mempty
 499                 else text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo))
 500             ]
 501         )
 502       $+$ text ""
 503   where
 504     entry fname field cond format = case cond (field pkginfo) of
 505       Nothing -> label <+> format (field pkginfo)
 506       Just Nothing -> mempty
 507       Just (Just other) -> label <+> text other
 508       where
 509         label = text fname Disp.<> char ':' Disp.<> padding
 510         padding = text (replicate (13 - length fname) ' ')
 511
 512     entryST fname field = entry fname (ShortText.fromShortText . field)
 513
 514     normal = Nothing
 515     hide = Just Nothing
 516     replace msg = Just (Just msg)
 517
 518     alwaysShow = const normal
 519     hideIfNull v = if null v then hide else normal
 520     showIfInstalled v
 521       | not isInstalled = hide
 522       | null v = replace "[ Not installed ]"
 523       | otherwise = normal
 524     altText nul msg v = if nul v then replace msg else normal
 525     orNotSpecified = altText null "[ Not specified ]"
 526
 527     commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f
 528     dispFlag = text . unFlagName . flagName
 529     dispYesNo True = text "Yes"
 530     dispYesNo False = text "No"
 531
 532     dispExtDep (SourceDependency dep) = pretty dep
 533     dispExtDep (InstalledDependency dep) = pretty dep
 534
 535     isInstalled = not (null (installedVersions pkginfo))
 536     hasExes = length (executables pkginfo) >= 2
 537     -- TODO: exclude non-buildable exes
 538     pkgkind
 539       | hasLib pkginfo && hasExes = text "programs and library"
 540       | hasLib pkginfo && hasExe pkginfo = text "program and library"
 541       | hasLib pkginfo = text "library"
 542       | hasExes = text "programs"
 543       | hasExe pkginfo = text "program"
 544       | otherwise = mempty
 545
 546 reflowParagraphs :: String -> Doc
 547 reflowParagraphs =
 548   vcat
 549     . intersperse (text "") -- re-insert blank lines
 550     . map (fsep . map text . concatMap words) -- reflow paragraphs
 551     . filter (/= [""])
 552     . L.groupBy (\x y -> "" `notElem` [x, y]) -- break on blank lines
 553     . lines
 554
 555 reflowLines :: String -> Doc
 556 reflowLines = vcat . map text . lines
 557
 558 -- | We get the 'PackageDisplayInfo' by combining the info for the installed
 559 -- and available versions of a package.
 560 --
 561 -- * We're building info about a various versions of a single named package so
 562 -- the input package info records are all supposed to refer to the same
 563 -- package name.
 564 mergePackageInfo
 565   :: VersionRange
 566   -> [Installed.InstalledPackageInfo]
 567   -> [UnresolvedSourcePackage]
 568   -> Maybe UnresolvedSourcePackage
 569   -> Bool
 570   -> PackageDisplayInfo
 571 mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =
 572   assert (length installedPkgs + length sourcePkgs > 0) $
 573     PackageDisplayInfo
 574       { pkgName =
 575           combine
 576             packageName
 577             source
 578             packageName
 579             installed
 580       , selectedVersion =
 581           if showVer
 582             then fmap packageVersion selectedPkg
 583             else Nothing
 584       , selectedSourcePkg = sourceSelected
 585       , installedVersions = map packageVersion installedPkgs
 586       , sourceVersions = map packageVersion sourcePkgs
 587       , preferredVersions = versionPref
 588       , license =
 589           combine
 590             Source.licenseRaw
 591             source
 592             Installed.license
 593             installed
 594       , maintainer =
 595           combine
 596             Source.maintainer
 597             source
 598             Installed.maintainer
 599             installed
 600       , author =
 601           combine
 602             Source.author
 603             source
 604             Installed.author
 605             installed
 606       , homepage =
 607           combine
 608             Source.homepage
 609             source
 610             Installed.homepage
 611             installed
 612       , bugReports = maybe mempty Source.bugReports source
 613       , sourceRepo =
 614           fromMaybe mempty
 615             . join
 616             . fmap
 617               ( uncons Nothing Source.repoLocation
 618                   . sortBy (comparing Source.repoKind)
 619                   . Source.sourceRepos
 620               )
 621             $ source
 622       , -- TODO: installed package info is missing synopsis
 623         synopsis = maybe mempty Source.synopsis source
 624       , description =
 625           combine
 626             Source.description
 627             source
 628             Installed.description
 629             installed
 630       , category =
 631           combine
 632             Source.category
 633             source
 634             Installed.category
 635             installed
 636       , flags = maybe [] Source.genPackageFlags sourceGeneric
 637       , hasLib =
 638           isJust installed
 639             || maybe False (isJust . Source.condLibrary) sourceGeneric
 640       , hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric
 641       , executables = map fst (maybe [] Source.condExecutables sourceGeneric)
 642       , modules =
 643           combine
 644             (map Installed.exposedName . Installed.exposedModules)
 645             installed
 646             -- NB: only for the PUBLIC library
 647             (concatMap getListOfExposedModules . maybeToList . Source.library)
 648             source
 649       , dependencies =
 650           combine
 651             ( map (SourceDependency . simplifyDependency)
 652                 . Source.allBuildDepends
 653             )
 654             source
 655             (map InstalledDependency . Installed.depends)
 656             installed
 657       , haddockHtml =
 658           fromMaybe ""
 659             . join
 660             . fmap (listToMaybe . Installed.haddockHTMLs)
 661             $ installed
 662       , haveTarball = False
 663       }
 664   where
 665     combine f x g y = fromJust (fmap f x `mplus` fmap g y)
 666     installed :: Maybe Installed.InstalledPackageInfo
 667     installed = latestWithPref versionPref installedPkgs
 668
 669     getListOfExposedModules lib =
 670       Source.exposedModules lib
 671         ++ map
 672           Source.moduleReexportName
 673           (Source.reexportedModules lib)
 674
 675     sourceSelected
 676       | isJust selectedPkg = selectedPkg
 677       | otherwise = latestWithPref versionPref sourcePkgs
 678     sourceGeneric = fmap srcpkgDescription sourceSelected
 679     source = fmap flattenPackageDescription sourceGeneric
 680
 681     uncons :: b -> (a -> b) -> [a] -> b
 682     uncons z _ [] = z
 683     uncons _ f (x : _) = f x
 684
 685 -- | Not all the info is pure. We have to check if the docs really are
 686 -- installed, because the registered package info lies. Similarly we have to
 687 -- check if the tarball has indeed been fetched.
 688 updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo
 689 updateFileSystemPackageDetails pkginfo = do
 690   fetched <-
 691     maybe
 692       (return False)
 693       (isFetched . srcpkgSource)
 694       (selectedSourcePkg pkginfo)
 695   docsExist <- doesDirectoryExist (haddockHtml pkginfo)
 696   return
 697     pkginfo
 698       { haveTarball = fetched
 699       , haddockHtml = if docsExist then haddockHtml pkginfo else ""
 700       }
 701
 702 latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg
 703 latestWithPref _ [] = Nothing
 704 latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs)
 705   where
 706     prefThenVersion pkg =
 707       let ver = packageVersion pkg
 708        in (withinRange ver pref, ver)
 709
 710 -- | Rearrange installed and source packages into groups referring to the
 711 -- same package by name. In the result pairs, the lists are guaranteed to not
 712 -- both be empty.
 713 mergePackages
 714   :: [Installed.InstalledPackageInfo]
 715   -> [UnresolvedSourcePackage]
 716   -> [ ( PackageName
 717        , [Installed.InstalledPackageInfo]
 718        , [UnresolvedSourcePackage]
 719        )
 720      ]
 721 mergePackages installedPkgs sourcePkgs =
 722   map collect $
 723     mergeBy
 724       (\i a -> fst i `compare` fst a)
 725       (groupOn packageName installedPkgs)
 726       (groupOn packageName sourcePkgs)
 727   where
 728     collect (OnlyInLeft (name, is)) = (name, is, [])
 729     collect (InBoth (_, is) (name, as)) = (name, is, as)
 730     collect (OnlyInRight (name, as)) = (name, [], as)
 731
 732 groupOn :: Ord key => (a -> key) -> [a] -> [(key, [a])]
 733 groupOn key =
 734   map (\xs -> (key (head xs), toList xs))
 735     . groupBy (equating key)
 736     . sortBy (comparing key)
 737
 738 dispTopVersions :: Int -> VersionRange -> [Version] -> Doc
 739 dispTopVersions n pref vs =
 740   ( Disp.fsep
 741       . Disp.punctuate (Disp.char ',')
 742       . map (\ver -> if ispref ver then pretty ver else parens (pretty ver))
 743       . sort
 744       . take n
 745       . interestingVersions ispref
 746       $ vs
 747   )
 748     <+> trailingMessage
 749   where
 750     ispref ver = withinRange ver pref
 751     extra = length vs - n
 752     trailingMessage
 753       | extra <= 0 = Disp.empty
 754       | otherwise =
 755           Disp.parens $
 756             Disp.text "and"
 757               <+> Disp.int (length vs - n)
 758               <+> if extra == 1
 759                 then Disp.text "other"
 760                 else Disp.text "others"
 761
 762 -- | Reorder a bunch of versions to put the most interesting / significant
 763 -- versions first. A preferred version range is taken into account.
 764 --
 765 -- This may be used in a user interface to select a small number of versions
 766 -- to present to the user, e.g.
 767 --
 768 -- > let selectVersions = sort . take 5 . interestingVersions pref
 769 interestingVersions :: (Version -> Bool) -> [Version] -> [Version]
 770 interestingVersions pref =
 771   map (mkVersion . fst)
 772     . filter snd
 773     . concat
 774     . Tree.levels
 775     . swizzleTree
 776     . reorderTree (\(Node (v, _) _) -> pref (mkVersion v))
 777     . reverseTree
 778     . mkTree
 779     . map (or0 . versionNumbers)
 780   where
 781     or0 [] = 0 :| []
 782     or0 (x : xs) = x :| xs
 783
 784     swizzleTree = unfoldTree (spine [])
 785       where
 786         spine ts' (Node x []) = (x, ts')
 787         spine ts' (Node x (t : ts)) = spine (Node x ts : ts') t
 788
 789     reorderTree _ (Node x []) = Node x []
 790     reorderTree p (Node x ts) = Node x (ts' ++ ts'')
 791       where
 792         (ts', ts'') = partition p (map (reorderTree p) ts)
 793
 794     reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))
 795
 796     mkTree :: forall a. Eq a => [NonEmpty a] -> Tree ([a], Bool)
 797     mkTree xs = unfoldTree step (False, [], xs)
 798       where
 799         step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])])
 800         step (node, ns, vs) =
 801           ( (reverse ns, node)
 802           , [ (any null vs', n : ns, mapMaybe nonEmpty (toList vs'))
 803             | (n, vs') <- groups vs
 804             ]
 805           )
 806
 807         groups :: [NonEmpty a] -> [(a, NonEmpty [a])]
 808         groups =
 809           map (\g -> (head (head g), fmap tail g))
 810             . groupBy (equating head)