-- Generate an HTML page listing all available packages

module Main (main) where

import Control.Monad
import Data.Char
import Data.Function		( on )
import Data.List
import Data.Maybe
import Data.Ord			( comparing )
import Distribution.ModuleName	( components )
import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
				( flattenPackageDescription )
import Distribution.Text	( display )
import Text.XHtml		hiding ( p )

import Util			( availablePackages, availableVersions,
				  allocatedTopLevelNodes,
				  packageNameURL, maybeLast,
				  loadPackageDescription, catLabel )
import HackagePage		( hackagePage )
import Locations		( pkgScriptURL )
import TagMap                   ( getTag, loadTagMap )

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

main :: IO ()
main = do
	ps <- availablePackages
	mb_pkgs <- forM ps $ \ p -> do
		vs <- availableVersions p
		case maybeLast vs of
		    Nothing -> return Nothing
		    Just v -> do
                       let pkgId = PackageIdentifier p v
                       tm <- loadTagMap pkgId
                       if getTag "deprecated" tm == "true"
                           then return Nothing
                           else do
                             pkg <- loadPackageDescription pkgId
                             return (Just (flattenPackageDescription pkg))
	putStr $ renderHtml $ formatPkgGroups $ catMaybes mb_pkgs

-- Packages, grouped by category and ordered by name with each category.
formatPkgGroups :: [PackageDescription] -> Html
formatPkgGroups pkgs = hackagePage "packages by category" docBody
  where docBody =
		(thediv ! [theclass "floatright"] << searchBox) :
		(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]
	searchBox =
		[form ! [method "GET", action "http://www.google.co.uk/search"] <<
			[input ! [thetype "hidden", name "hl", value "en"],
			 input ! [thetype "hidden", name "as_sitesearch", value (server ++ pkgScriptURL)],
			 input ! [thetype "text", size "20", name "as_q", value ""],
			 input ! [thetype "submit", value "Search package pages"]
			]]
	server = "hackage.haskell.org"
	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 <- categories pkg]
	sortKey pkg = map toLower $ display $ pkgName $ package pkg
	formatCategory cat =
		h3 ! [theclass "category"] <<
			anchor ! [name (catLabel catName)] << catName
	  where catName = categoryName cat
	categoryName (Category cat) = cat
	categoryName NoCategory = "Unclassified"
	capitalize (Category s) =
		Category (unwords [toUpper c : cs | (c:cs) <- words s])
	capitalize NoCategory = NoCategory

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

formatPkg :: PackageDescription -> Html
formatPkg pkg = li << (pkgLink : toHtml (" " ++ ptype) : defn)
  where pname = pkgName (package pkg)
	pkgLink = anchor ! [href (packageNameURL pname)] << display pname
	defn
	  | null (synopsis pkg) = []
	  | otherwise = [toHtml (": " ++ trim (synopsis pkg))]
	ptype
	  | null (executables pkg) = "library"
	  | hasLibs pkg = "library and " ++ programs
	  | otherwise = programs
	  where programs
		  | length (executables 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) && not (cats `elem` 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 (head . components) . 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 ((==) `on` (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