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

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