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