Index.hs

-- Generate an HTML page listing all available packages

module Distribution.Server.Pages.Index (packageIndex) where

import Distribution.Server.Pages.Template       ( hackagePage )

import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
                                ( flattenPackageDescription )
import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
import Distribution.Server.Packages.Types
import Distribution.Simple.Utils (comparing, equating)
import Distribution.ModuleName (toFilePath)

import Text.XHtml.Strict hiding ( p, name )
import qualified Text.XHtml.Strict as XHtml ( name )

import Data.Char (toLower, toUpper, isSpace)
import Data.List (intersperse, sortBy, groupBy, nub, maximumBy)


packageIndex :: PackageIndex.PackageIndex PkgInfo -> Html
packageIndex = formatPkgGroups
                 . map (mkPackageIndexInfo
                      . flattenPackageDescription
                      . pkgDesc
                      . maximumBy (comparing packageVersion))
                 . PackageIndex.allPackagesByName

data PackageIndexInfo = PackageIndexInfo {
                            pii_pkgName :: !PackageName,
                            pii_categories :: ![Category],
                            pii_hasLibrary :: !Bool,
                            pii_numExecutables :: !Int,
                            pii_synopsis :: !String
                        }

mkPackageIndexInfo :: PackageDescription -> PackageIndexInfo
mkPackageIndexInfo pd = PackageIndexInfo {
                            pii_pkgName = pkgName $ package pd,
                            pii_categories = categories pd,
                            pii_hasLibrary = hasLibs pd,
                            pii_numExecutables = length (executables pd),
                            pii_synopsis = synopsis pd
                        }

data Category = Category String | NoCategory
        deriving (Eq, Ord, Show)

-- Packages, grouped by category and ordered by name with each category.
formatPkgGroups :: [PackageIndexInfo] -> Html
formatPkgGroups pkgs = hackagePage "packages by category" docBody
  where docBody =
                (h2 << "Packages by category") :
                -- table of contents
                paragraph ! [theclass "toc"] <<
                        (bold << "Categories:" : toHtml " " :
                         intersperse (toHtml ", ") (map catLink cat_pkgs) ++
                         [toHtml "."]) :
                -- packages grouped by category
                [formatCategory cat +++
                        formatPkgList (sortBy (comparing sortKey) sub_pkgs) |
                        (cat, sub_pkgs) <- cat_pkgs]
        catLink (cat, sub_pkgs) =
                (anchor ! [href ("#" ++ catLabel catName)] << catName) +++
                spaceHtml +++
                toHtml ("(" ++ show (length sub_pkgs) ++ ")")
          where catName = categoryName cat
        cat_pkgs = groupOnFstBy normalizeCategory $ [(capitalize cat, pkg) |
                        pkg <- pkgs, cat <- pii_categories pkg]
        sortKey pkg = map toLower $ unPackageName $ pii_pkgName pkg
        formatCategory cat =
                h3 ! [theclass "category"] <<
                        anchor ! [XHtml.name (catLabel catName)] << catName
          where catName = categoryName cat
        catLabel cat = "cat:" ++ cat
        categoryName (Category cat) = cat
        categoryName NoCategory = "Unclassified"
        capitalize (Category s) =
                Category (unwords [toUpper c : cs | (c:cs) <- words s])
        capitalize NoCategory = NoCategory

formatPkgList :: [PackageIndexInfo] -> Html
formatPkgList pkgs = ulist ! [theclass "packages"] << map formatPkg pkgs

formatPkg :: PackageIndexInfo -> Html
formatPkg pkg = li << (pkgLink : toHtml (" " ++ ptype) : defn)
  where pname = pii_pkgName pkg
        pkgLink = anchor ! [href (packageNameURL pname)] << unPackageName pname
        defn
          | null (pii_synopsis pkg) = []
          | otherwise = [toHtml (": " ++ trim (pii_synopsis pkg))]
        ptype
          | pii_numExecutables pkg == 0 = "library"
          | pii_hasLibrary pkg = "library and " ++ programs
          | otherwise = programs
          where programs
                  | pii_numExecutables pkg > 1 = "programs"
                  | otherwise = "program"
        trim s
          | length s < 90 = s
          | otherwise = reverse (dropWhile (/= ',') (reverse (take 76 s))) ++ " ..."

categories :: PackageDescription -> [Category]
categories pkg
  | not (null cats) && (cats `notElem` blacklist) = split cats
  | not (null top_level_nodes) && length top_level_nodes < 3 &&
        all (`elem` allocatedTopLevelNodes) top_level_nodes =
        map Category top_level_nodes
  | otherwise = [NoCategory]
  where cats = trim (category pkg)
        -- trim will not be necessary with future releases of cabal
        trim = reverse . dropWhile isSpace . reverse
        split cs = case break (== ',') cs of
                (front, _:back) ->
                        Category front : split (dropWhile isSpace back)
                (front, []) -> [Category front]
        -- if no category specified, use top-level of module hierarchy
        top_level_nodes =
                maybe [] (nub . map (takeWhile (/= '.') . toFilePath) . exposedModules)
                (library pkg)

-- categories we ignore
blacklist :: [String]
blacklist = ["Application", "Foreign binding", "Tool", "Type", "Various",
        "Unclassified"]

groupOnFstBy :: (Ord a, Ord c) => (a -> c) -> [(a, b)] -> [(a, [b])]
groupOnFstBy f xys = [(x, y : map snd xys') |
        (x, y) : xys' <- groupBy (equating (f . fst)) (sortBy (comparing sortKey) xys)]
  where sortKey (x, _) = (f x, x)

normalizeCategory :: Category -> Category
normalizeCategory (Category n) = Category (map toLower n)
normalizeCategory NoCategory = NoCategory

allocatedTopLevelNodes :: [String]
allocatedTopLevelNodes = [
        "Algebra", "Codec", "Control", "Data", "Database", "Debug",
        "Distribution", "DotNet", "Foreign", "Graphics", "Language",
        "Network", "Numeric", "Prelude", "Sound", "System", "Test", "Text"]

packageNameURL :: PackageName -> URL
packageNameURL pkg = "/package/" ++ unPackageName pkg

unPackageName :: PackageName -> String
unPackageName (PackageName name) = name