Ppr049.hs

-- | HTML output for documentation package index.

module Ppr049 (
  htmlPage
) where

import Control.Monad
import Data.Char (isAlpha, toUpper)
import Data.List
import Data.Ord
import Data.Time
import Data.Version
import qualified Data.Map as M
import System.FilePath
import System.Locale
import Text.Html

import Distribution.DocIdx.Common
import Distribution.DocIdx.Config
import Distribution.GhcPkgList

-- | Project homepage, for footer.
homePage :: String
homePage = "http://hackage.haskell.org/package/docidx"

-- | Create and render entire page.
htmlPage :: DocIdxCfg -> PackageMap HaddockInfo -> UTCTime -> String
htmlPage config pkgs now = renderHtml [htmlHeader, htmlBody]
  where htmlHeader = header << ((thetitle << pageTitle config) : fav : css)
        fav = thelink ! [rel "shortcut icon", href $ favIcon config] << noHtml
        css = map oneCss (pageCss config)
        oneCss cp = thelink ! [rel "stylesheet",
                               thetype "text/css", href cp] << noHtml
        htmlBody = body << (title' ++ toc ++ secs ++ nowFoot)
          where title' = [h2 << "Local packages with docs"]
                toc = [htmlToc config am]
                secs = concatMap (uncurry htmlPkgsAlpha) $ M.assocs am
                am = alphabetize pkgs
                now' = formatTime defaultTimeLocale rfc822DateFormat now
                nowFoot = [p ! [theclass "toc"] $
                           stringToHtml ("Page rendered " ++ now' ++ " by ")
                           +++ (anchor ! [href homePage] <<
                                          stringToHtml appName)]

-- | An AlphaMap groups packages together by their name's first character.
type AlphaMap = M.Map Char (PackageMap HaddockInfo)

-- | Group packages together by their name's first character.
alphabetize :: PackageMap HaddockInfo -> AlphaMap
alphabetize = foldr addAlpha M.empty
  where addAlpha (n, vs) = M.insertWith (++) c [(n, vs)]
          where c = if isAlpha c' then c' else '\0'
                c' = toUpper $ head n

-- | Generate the table of contents.
htmlToc :: DocIdxCfg -> AlphaMap -> Html
htmlToc config am =
  p ! [theclass "toc"] << tocHtml (alphaItems ++ tocExtras config)
    where tocHtml = intersperse bull . concatMap tocItemHtml
          alphaItems = map (\k -> TocItem [k] ('#':[k])) $ sort $ M.keys am

-- | Render toc elements to HTML.
tocItemHtml :: TocItem -> [Html]
tocItemHtml (TocItem nm path) = [anchor ! [href path] << nm]
tocItemHtml TocSeparator = [mdash]
tocItemHtml TocNewline = [br] -- Hmmm... you still get the bullets?

-- | Render a collection of packages with the same first character.
htmlPkgsAlpha :: Char -> PackageMap HaddockInfo -> [Html]
htmlPkgsAlpha c pm = [heading, packages]
  where heading = h3 ! [theclass "category"] << anchor ! [name [c]] << [c]
        packages = ulist ! [theclass "packages"] <<
                     map (uncurry htmlPkg) pm'
        pm' = sortBy (comparing (map toUpper . fst)) pm

-- | Render a particularly-named package (all versions of it).
htmlPkg :: String -> VersionMap HaddockInfo -> Html
htmlPkg nm vs = li << pvsHtml (flattenPkgVersions nm vs)

-- | Everything we want to know about a particular version of a
-- package, nicely flattened and ready to use.  (Actually, we'd also
-- like to use the synopsis, but this isn't exposed through the Cabal
-- library, sadly.  We could conceivably grab it from the haddock docs
-- (and hackage for packages with no local docs)  but this
-- seems excessive so for now we forget about it.
data PkgVersion = PkgVersion {
    pvName ::String
  , pvSynopsis :: Maybe String
  , pvVersion :: Version
  , pvExposed :: Bool
  , pvHaddocks :: Maybe FilePath
  } deriving (Eq, Ord, Show)

-- | Flatten a given package's various versions into a list of
-- PkgVersion values, which is much nicer to iterate over when
-- building the HTML for this package.
flattenPkgVersions :: String -> VersionMap HaddockInfo -> [PkgVersion]
flattenPkgVersions nm vs = concatMap (uncurry flatten') $ reverse vs
  where flatten' :: Version -> [VersionInfo HaddockInfo] -> [PkgVersion]
        -- We reverse here to put user versions of pkgs before
        -- identically versioned global versions.
        flatten' v = concatMap (uncurry flatten3) . reverse
          where flatten3 :: Bool -> [HaddockInfo] -> [PkgVersion]
                flatten3 ex [] = [PkgVersion nm Nothing v ex Nothing]
                flatten3 ex ps = map (mkPv nm v ex) ps

-- | Construct a PkgVersion from information about a single version of
-- a package.
mkPv :: String -> Version -> Bool -> HaddockInfo -> PkgVersion
mkPv nm v ex Nothing = PkgVersion nm Nothing v ex Nothing
mkPv nm v ex (Just (hp, syn)) = PkgVersion nm (Just syn) v ex (Just hp)

-- | Render the HTML for a list of versions of (we presume) the same
-- package.
pvsHtml :: [PkgVersion] -> Html
pvsHtml pvs = pvHeader (head pvs) +++ spaceHtml +++ pvVersions pvs +++
                pvSyn pvs

-- | Render the "header" part of some package's HTML: name (with link
-- to default version of local docs if available) and hackage link.
pvHeader :: PkgVersion -> [Html]
pvHeader pv = [maybeURL nme (pvHaddocks pv)
              ,spaceHtml
              ,anchor ! [href $ hackagePath pv] << extLinkArrow
              ]
  where nme = if not (pvExposed pv) then "(" ++ nm ++ ")" else nm
        nm = pvName pv

-- | Render HTML linking to the various versions of a package
-- installed, listed by version number only (name is implicit).
pvVersions :: [PkgVersion] -> Html
pvVersions [_] = noHtml -- Don't bother if there's only one version.
pvVersions pvs = stringToHtml "[" +++
                  intersperse comma (map pvOneVer pvs) +++
                  stringToHtml "]"
  where pvOneVer pv = maybeURL (showVersion $ pvVersion pv) (pvHaddocks pv)

-- | Render the synopsis of a package, if present in any of its versions.
pvSyn :: [PkgVersion] -> Html
pvSyn = maybe noHtml (\x -> mdash +++ stringToHtml x) . msum . map pvSynopsis

-- | Render a URL if there's a path; otherwise, just render some text.
-- (Useful in cases where a package is installed but no documentation
-- was found: you'll still get the hackage link.)
maybeURL :: String -> Maybe String -> Html
maybeURL nm Nothing = stringToHtml nm
maybeURL nm (Just path) = anchor ! [href $ joinPath [path, "index.html"]] << nm

-- | Compute the URL to a package's page on hackage.
hackagePath :: PkgVersion -> String
hackagePath pv = "http://hackage.haskell.org/package/" ++ pvTag
  where pvTag = pvName pv ++ "-" ++ showVersion (pvVersion pv)

-- Some primitives.

bull, comma, extLinkArrow, mdash :: Html
bull = primHtml " &bull; "
comma = stringToHtml ", "
extLinkArrow = primHtml "&#x2b08;"
mdash = primHtml " &mdash; "