-- Body of the HTML page for a package
{-# LANGUAGE PatternGuards, RecordWildCards #-}
module Distribution.Server.Pages.Package (
    packagePage,
    renderDependencies,
    renderVersion,
    renderFields,
    renderDownloads
  ) where

import Distribution.Server.Features.PreferredVersions

import Distribution.Server.Pages.Template (hackagePageWith)
import Distribution.Server.Pages.Package.HaddockParse (parseHaddockParagraphs)
import Distribution.Server.Pages.Package.HaddockLex  (tokenise)
import Distribution.Server.Pages.Package.HaddockHtml
import Distribution.Server.Packages.ModuleForest
import Distribution.Server.Packages.Render
import Distribution.Server.Users.Types (userStatus, userName, isActiveAccount)

import Distribution.Package
import Distribution.PackageDescription as P
import Distribution.Simple.Utils ( cabalVersion )
import Distribution.Version
import Distribution.Text        (display)
import Text.XHtml.Strict hiding (p, name, title, content)

import Data.Maybe               (maybeToList)
import Data.List                (intersperse, intercalate)
import System.FilePath.Posix    ((</>), (<.>))
import System.Locale            (defaultTimeLocale)
import Data.Time.Format         (formatTime)

packagePage :: PackageRender -> [Html] -> [Html] -> [(String, Html)] -> [(String, Html)] -> Maybe URL -> Html
packagePage render headLinks top sections bottom docURL =
    hackagePageWith [] docTitle docSubtitle docBody [docFooter]
  where
    pkgid = rendPkgId render

    docTitle = display (packageName pkgid)
            ++ case synopsis (rendOther render) of
                 ""    -> ""
                 short -> ": " ++ short
    docSubtitle = toHtml docTitle

    docBody =
        h1 <<
           bodyTitle :
            concat [
             renderHeads,
             top,
             pkgBody render sections,
             moduleSection render docURL,
             downloadSection render,
             maintainerSection pkgid,
             map pair bottom
           ]
    bodyTitle = "The " ++ display (pkgName pkgid) ++ " package"

    renderHeads = case headLinks of
        [] -> []
        items -> [thediv ! [thestyle "font-size: small"] <<
            (map (\item -> "[" +++ item +++ "] ") items)]

    docFooter = thediv ! [identifier "footer"]
                  << paragraph
                       << [ toHtml "Produced by "
                          , anchor ! [href "/"] << "hackage"
                          , toHtml " and "
                          , anchor ! [href cabalHomeURL] << "Cabal"
                          , toHtml (" " ++ display cabalVersion) ]

    pair (title, content) =
        toHtml [ h2 << title, content ]

-- | Body of the package page
pkgBody :: PackageRender -> [(String, Html)] -> [Html]
pkgBody render sections =
    prologue (description $ rendOther render) ++
    propertySection sections

prologue :: String -> [Html]
prologue [] = []
prologue desc = case tokenise desc >>= parseHaddockParagraphs of
    Left _ -> [paragraph << p | p <- paragraphs desc]
    Right doc -> [markup htmlMarkup doc]

-- Break text into paragraphs (separated by blank lines)
paragraphs :: String -> [String]
paragraphs = map unlines . paras . lines
  where paras xs = case dropWhile null xs of
                [] -> []
                xs' -> case break null xs' of
                        (para, xs'') -> para : paras xs''

downloadSection :: PackageRender -> [Html]
downloadSection PackageRender{..} =
    [ h2 << "Downloads"
    , ulist << map (li <<) downloadItems
    ]
  where
    downloadItems =
      [ if rendHasTarball
          then [ anchor ! [href downloadURL] << tarGzFileName
               , toHtml << " ["
               , anchor ! [href srcURL] << "browse"
               , toHtml << "]"
               , toHtml << " (Cabal source package)"
               ]
          else [ toHtml << "Package tarball not uploaded" ]
      , [ anchor ! [href cabalURL] << "Package description"
        , toHtml $ if rendHasTarball then " (included in the package)" else ""
        ]
      , case (rendHasTarball, rendHasChangeLog) of
         (True, True)  -> [ anchor ! [href changeLogURL] << "Changelog"
                          , toHtml << " (included in the package)"
                          ]
         (True, False) -> [ toHtml << "No changelog available" ]
         _             -> [ toHtml << "Package tarball not uploaded" ]
      ]

    downloadURL   = rendPkgUri </> display rendPkgId <.> "tar.gz"
    cabalURL      = rendPkgUri </> display (packageName rendPkgId) <.> "cabal"
    changeLogURL  = rendPkgUri </> "changelog"
    srcURL        = rendPkgUri </> "src/"
    tarGzFileName = display rendPkgId ++ ".tar.gz"

maintainerSection :: PackageId -> [Html]
maintainerSection pkgid =
    [ h4 << "Maintainers' corner"
    , paragraph << "For package maintainers and hackage trustees"
    , ulist << li << anchor ! [href maintainURL]
                  << "edit package information"
    ]
  where
    maintainURL = display (packageName pkgid) </> "maintain"

moduleSection :: PackageRender -> Maybe URL -> [Html]
moduleSection render docURL = maybeToList $ fmap msect (rendModules render)
  where msect lib = toHtml
            [ h2 << "Modules"
            , renderModuleForest docURL lib
            ]

propertySection :: [(String, Html)] -> [Html]
propertySection sections =
    [ h2 << "Properties"
    , tabulate $ filter (not . isNoHtml . snd) sections
    ]

tabulate :: [(String, Html)] -> Html
tabulate items = table <<
        [tr << [th ! [align "left", valign "top"] << t, td << d] | (t, d) <- items]


renderDependencies :: PackageRender -> (String, Html)
renderDependencies render = ("Dependencies", case htmlDepsList of
    [] -> toHtml "None"
    _  -> foldr (+++) noHtml htmlDepsList)
  where htmlDepsList =
            intersperse (toHtml " " +++ bold (toHtml "or") +++ br) $
            map showDependencies (rendDepends render)

showDependencies :: [Dependency] -> Html
showDependencies deps = commaList (map showDependency deps)

showDependency ::  Dependency -> Html
showDependency (Dependency (PackageName pname) vs) = showPkg +++ vsHtml
  where vsHtml = if vs == anyVersion then noHtml
                                     else toHtml (" (" ++ display vs ++ ")")
        -- mb_vers links to latest version in range. This is a bit computationally
        -- expensive, not cache-friendly, and perhaps unexpected in some cases
        {-mb_vers = maybeLast $ filter (`withinRange` vs) $ map packageVersion $
                    PackageIndex.lookupPackageName vmap (PackageName pname)-}
        -- nonetheless, we should ensure that the package exists /before/
        -- passing along the PackageRender, which is not the case here
        showPkg = anchor ! [href . packageURL $ PackageIdentifier (PackageName pname) (Version [] [])] << pname

renderVersion :: PackageId -> [(Version, VersionStatus)] -> Maybe String -> (String, Html)
renderVersion (PackageIdentifier pname pversion) allVersions info =
    (if null earlierVersions && null laterVersions then "Version" else "Versions", versionList +++ infoHtml)
  where (earlierVersions, laterVersionsInc) = span ((<pversion) . fst) allVersions
        (mThisVersion, laterVersions) = case laterVersionsInc of
            (v:later) | fst v == pversion -> (Just v, later)
            later -> (Nothing, later)
        versionList = commaList $ map versionedLink earlierVersions
                               ++ (case pversion of
                                      Version [] [] -> []
                                      _ -> [strong ! (maybe [] (status . snd) mThisVersion) << display pversion]
                                  )
                               ++ map versionedLink laterVersions
        versionedLink (v, s) = anchor ! (status s ++ [href $ packageURL $ PackageIdentifier pname v]) << display v
        status st = case st of
            NormalVersion -> []
            DeprecatedVersion  -> [theclass "deprecated"]
            UnpreferredVersion -> [theclass "unpreferred"]
        infoHtml = case info of Nothing -> noHtml; Just str -> " (" +++ (anchor ! [href str] << "info") +++ ")"

-- We don't keep currently per-version downloads in memory; if we decide that
-- it is important to show this all the time, we can reenable
renderDownloads :: Int -> {- Int -> Version -> -} (String, Html)
renderDownloads totalDown {- versionDown version -} =
    ("Downloads", toHtml $ {- show versionDown ++ " for " ++ display version ++
                      " and " ++ -} show totalDown ++ " total")

renderFields :: PackageRender -> [(String, Html)]
renderFields render = [
        -- Cabal-Version
        ("License",     toHtml $ rendLicenseName render),
        ("Copyright",   toHtml $ P.copyright desc),
        ("Author",      toHtml $ author desc),
        ("Maintainer",  maintainField $ rendMaintainer render),
        ("Stability",   toHtml $ stability desc),
        ("Category",    commaList . map categoryField $ rendCategory render),
        ("Home page",   linkField $ homepage desc),
        ("Bug tracker", linkField $ bugReports desc),
        ("Source repository", vList $ map sourceRepositoryField $ sourceRepos desc),
        ("Executables", commaList . map toHtml $ rendExecNames render),
        ("Upload date", toHtml $ showTime utime),
        ("Uploaded by", userField)
      ]
  where desc = rendOther render
        (utime, uinfo) = rendUploadInfo render
        uname = maybe "Unknown" (display . userName) uinfo
        uactive = maybe False (isActiveAccount . userStatus) uinfo
        userField | uactive   = anchor ! [href $ "/user/" ++ uname] << uname
                  | otherwise = toHtml uname
        linkField url = case url of
            [] -> noHtml
            _  -> anchor ! [href url] << url
        categoryField cat = anchor ! [href $ "/packages/#cat:" ++ cat] << cat
        maintainField mnt = case mnt of
            Nothing -> strong ! [theclass "warning"] << toHtml "none"
            Just n  -> toHtml n
        showTime = formatTime defaultTimeLocale "%c"
        sourceRepositoryField sr = sourceRepositoryToHtml sr

sourceRepositoryToHtml :: SourceRepo -> Html
sourceRepositoryToHtml sr
    = toHtml (display (repoKind sr) ++ ": ")
  +++ case repoType sr of
      Just Darcs
       | (Just url, Nothing, Nothing) <-
         (repoLocation sr, repoModule sr, repoBranch sr) ->
          concatHtml [toHtml "darcs get ",
                      anchor ! [href url] << toHtml url,
                      case repoTag sr of
                          Just tag' -> toHtml (" --tag " ++ tag')
                          Nothing   -> noHtml,
                      case repoSubdir sr of
                          Just sd -> toHtml " ("
                                 +++ (anchor ! [href (url </> sd)]
                                      << toHtml sd)
                                 +++ toHtml ")"
                          Nothing   -> noHtml]
      Just Git
       | (Just url, Nothing) <-
         (repoLocation sr, repoModule sr) ->
          concatHtml [toHtml "git clone ",
                      anchor ! [href url] << toHtml url,
                      case repoBranch sr of
                          Just branch -> toHtml (" -b " ++ branch)
                          Nothing     -> noHtml,
                      case repoTag sr of
                          Just tag' -> toHtml ("(tag " ++ tag' ++ ")")
                          Nothing   -> noHtml,
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing -> noHtml]
      Just SVN
       | (Just url, Nothing, Nothing, Nothing) <-
         (repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) ->
          concatHtml [toHtml "svn checkout ",
                      anchor ! [href url] << toHtml url,
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing   -> noHtml]
      Just CVS
       | (Just url, Just m, Nothing, Nothing) <-
         (repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) ->
          concatHtml [toHtml "cvs -d ",
                      anchor ! [href url] << toHtml url,
                      toHtml (" " ++ m),
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing   -> noHtml]
      Just Mercurial
       | (Just url, Nothing, Nothing, Nothing) <-
         (repoLocation sr, repoModule sr, repoBranch sr, repoTag sr) ->
          concatHtml [toHtml "hg clone ",
                      anchor ! [href url] << toHtml url,
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing   -> noHtml]
      Just Bazaar
       | (Just url, Nothing, Nothing) <-
         (repoLocation sr, repoModule sr, repoBranch sr) ->
          concatHtml [toHtml "bzr branch ",
                      anchor ! [href url] << toHtml url,
                      case repoTag sr of
                          Just tag' -> toHtml (" -r " ++ tag')
                          Nothing -> noHtml,
                      case repoSubdir sr of
                          Just sd -> toHtml ("(" ++ sd ++ ")")
                          Nothing   -> noHtml]
      _ ->
          -- We don't know how to show this SourceRepo.
          -- This is a kludge so that we at least show all the info.
          toHtml (show sr)

commaList :: [Html] -> Html
commaList = concatHtml . intersperse (toHtml ", ")

vList :: [Html] -> Html
vList = concatHtml . intersperse br
-----------------------------------------------------------------------------

renderModuleForest :: Maybe URL -> ModuleForest -> Html
renderModuleForest mb_url forest =
    thediv ! [identifier "module-list"] << renderForest [] forest
    where
      renderForest _       [] = noHtml
      renderForest pathRev ts = myUnordList $ map renderTree ts
          where
            renderTree (Node s isModule subs) =
                    ( if isModule then moduleEntry newPath else italics << s )
                +++ renderForest newPathRev subs
                where
                  newPathRev = s:pathRev
                  newPath = reverse newPathRev

      moduleEntry path =
          thespan ! [theclass "module"] << maybe modName linkedName mb_url path
      modName path = toHtml (intercalate "." path)
      linkedName url path = anchor ! [href modUrl] << modName path
          where
            modUrl = url ++ "/" ++ intercalate "-" path ++ ".html"
      myUnordList :: HTML a => [a] -> Html
      myUnordList = unordList ! [theclass "modules"]

------------------------------------------------------------------------------
-- TODO: most of these should be available from the CoreFeature
-- so pass it in to this module

-- | URL describing a package.
packageURL :: PackageIdentifier -> URL
packageURL pkgId = "/package" </> display pkgId

--cabalLogoURL :: URL
--cabalLogoURL = "/built-with-cabal.png"

-- global URLs
cabalHomeURL :: URL
cabalHomeURL = "http://haskell.org/cabal/"