content: -- ----------------------------------------------------------------------------
  
  {- |
    Module     : Hayoo.Search.HTML
    Copyright  : Copyright (C) 2008 Timo B. Huebel
    License    : MIT
  
    Maintainer : Timo B. Huebel (tbh@holumbus.org)
    Stability  : experimental
    Portability: portable
    Version    : 0.1
  
    The conversion functions for generating the HTML code of an Hayoo!
    search result.
   
  -}
  
  -- ----------------------------------------------------------------------------
  
  {-# LANGUAGE OverloadedStrings #-}
  
  module Hayoo.Search.HTML 
      ( RenderState (..)
      , result
      )
  where
  
  import           Data.Char      ( toLower
                                  , isSpace
                                  )
  import           Data.Function
  import qualified Data.List      as L
  import qualified Data.Map       as M
  import           Data.Maybe
  import           Data.Text      (Text, pack)
  
  import           Text.XHtmlCombinators
  import qualified Text.XHtmlCombinators.Attributes as A
  
  import           Holumbus.Utility hiding (escape)
  import           Holumbus.Index.Common
  
  import           Holumbus.Query.Result
  
  import           Hayoo.IndexTypes
  import           Hayoo.Search.Common
  
  data RenderState = RenderState
                   { rsQuery    :: String
                   , rsStart    :: Int
                   , rsStatic   :: Bool
                   }
  
  pageLimit :: Int
  pageLimit = 10
  
  maxWordHits :: Int
  maxWordHits = 75
  
  staticRoot :: String
  staticRoot = "hayoo.html"
  
  text' :: (Functor t, Monad t, CData c) => String -> XHtmlT t c
  text' = text . pack
  
  onclick :: Text -> Attr
  onclick = A.attr "onclick"
  
  -- | Render the whole Hayoo! search result.
  result :: RenderState -> StatusResult -> XHtml FlowContent
  result rs (sm, rf, rp, tm, tp) = div' [A.id_ "result"] $ do
    div' [A.id_ "status"] $ text' sm  
    packageResults rs rp
    topLists rs tm tp
    functionResults rs rf
    div' [A.class_ "clear"] $ empty
    pager rs $ max (sizeDocHits rf) (sizeDocHits rp)
  
  -- | The aggregation lists.
  topLists :: RenderState -> [(String, Int)] -> [(String, Int)] -> XHtml FlowContent
  topLists _ [] [] = empty
  topLists rs tm tp = div' [A.id_ "aggregation"] $ do
    moduleList rs tm
    packageList rs tp
  
  -- | The aggregated module list.
  moduleList :: RenderState -> [(String, Int)] -> XHtml FlowContent
  moduleList _ [] = empty
  moduleList rs tm = div' [A.id_ "modules"] $ do
    div' [A.class_ "headline"] $ text "Top 15 Modules"
    mapM_ topModule (take 15 tm)
    where
    topModule (m, c) = div' [A.class_ "rootModule"] $ do
      a' [A.class_ "rootModuleName", A.href staticLink, onclick dynamicLink] $ text' m
      text " "
      span' [A.class_ "rootModuleCount"] $ text' $ show c
        where
        staticLink = pack $ staticRoot ++ "?query=" ++ (rsQuery rs) ++ "%20module%3A" ++ m
        dynamicLink = pack $ "addToQuery('module:" ++ m ++ "'); return false;"
  
  -- | The aggregated package list.
  packageList :: RenderState -> [(String, Int)] -> XHtml FlowContent
  packageList _ [] = empty
  packageList rs tp = div' [A.id_ "packages"] $ do
    div' [A.class_ "headline"] $ text "Top 15 Packages"
    mapM_ topPackage (take 15 tp)
    where
    topPackage (k, c) = div' [A.class_ "package"] $ do
      a' [A.class_ "packageLink", A.href staticLink, onclick dynamicLink] $ text' k
      text " "
      span' [A.class_ "packageCount"] $ text' $ show c
        where
        staticLink = pack $ staticRoot ++ "?query=" ++ (rsQuery rs) ++ "%20package%3A" ++ k
        dynamicLink = pack $ "addToQuery('package:" ++ k ++ "'); return false;"
  
  -- | The Hackage hits (i.e. packages)
  packageResults :: RenderState -> (Result PackageInfo) -> XHtml FlowContent
  packageResults rs rp = let pl = extractPackages rp in 
    if L.null pl then empty else div' [A.id_ "hackage"] $ do 
      mapM_ packageInfo pl
    where
    packageInfo k = div' [A.class_ "package"] $ do
      div' [A.class_ "category"] $ mapM_ packageCategory (split "," $ p_category k)
      div' [A.class_ "name"] $ do
        a' [A.class_ "name", A.href $ pack $ "http://hackage.haskell.org/package/" ++ (p_name k)] $ 
                                  text' (p_name k)
        span' [A.class_ "synopsis"] $ text' (" " ++ (p_synopsis k))
      div' [A.class_ "description"] $ text' (p_description k)
      div' [A.class_ "author"] $ text' (p_author k)
    packageCategory c = a' [A.class_ "category", A.href $ pack $ "http://hackage.haskell.org/packages/archive/pkg-list.html#cat:" ++ map toLower c] $ text' c
    extractPackages = take pageLimit . drop (rsStart rs) . 
                      (mapMaybe (\(_, (di, _)) -> custom $ document di)) . 
                      reverse . L.sortBy (compare `on` (docScore . fst . snd)) . toListDocIdMap . docHits
  
  -- | The function hits.
  functionResults :: RenderState -> (Result FunctionInfo) -> XHtml FlowContent
  functionResults rs rf = do
    div' [A.id_ "words"] $ mapM_ (wordInfo rs $ maxScoreWordHits rf) (toListSortedWords $ wordHits rf)
    div' [A.id_ "documents"] $ table $ mapM_ functionInfo (toListSortedDocs $ docHits rf)
      where
                  notSignature (_, (_, wch)) = M.keys wch /= ["signature"]
                  toListSortedDocs = take pageLimit . drop (rsStart rs) . reverse . 
                          L.sortBy (compare `on` (docScore . fst . snd)) . toListDocIdMap
                  toListSortedWords = L.sortBy (compare `on` fst) . take maxWordHits . 
                          L.sortBy (compare `on` (wordScore .fst . snd)) . filter notSignature . M.toList
  
  -- | Render the information about a function (module w/ link, function name, signature, ...)
  functionInfo :: (DocId, (DocInfo FunctionInfo, DocContextHits)) -> XHtml Table1Content
  functionInfo (_, (DocInfo (Document _ _ Nothing) _, _)) = error "Expecting custom document info"
  functionInfo (_, (DocInfo (Document t u (Just fi)) r, _)) = tbody $ do
          tr' [A.class_ "function"] $ do
                  td' [A.class_ "module"] $ do
                          a' [A.class_ "module", A.href $ pack (modLink u)] $ text' (moduleName fi ++ ".")
                  td' [A.class_ "name"] $ do
                          a' [A.class_ "function", A.href $ pack u, A.title $ pack ("Score: " ++ show r)] $ text' t
                  td' [A.class_ "signature"] $ do
                          sigDecl (signature fi)
          tr' [A.class_ "details"] $ do
                  td' [A.class_ "package"] $ do
                          a' [A.class_ "package", A.href $ pack (pkgLink $ package fi)] $ text' (package fi)
                  td' [A.class_ "description", A.colspan 2] $ div_ $ do
                          a' [A.class_ "toggleFold", onclick "toggleFold(this);"] $ empty
                          div' [A.class_ "description"] $ let f = fctDescr fi in
                                  if L.null f then text "No description." else text' f
                          let c = sourceURI fi in if L.null c then empty else span' [A.class_ "source"] $ do
                                  a' [A.class_ "source", A.href $ pack c] $ text "Source"
          where
          modLink = takeWhile ((/=) '#')
          pkgLink = (++) "http://hackage.haskell.org/package/"
          sigDecl s'
                  | s' `elem` ["data", "type", "newtype", "class", "module"] = span' [A.class_ "declaration"] $ text' s
                  | otherwise = text' $ replace "->" " -> " s
                  where
                  s = ":: " ++ stringTrim s'
  
  -- | Render a word in the cloud of suggestions
  wordInfo :: RenderState -> Score -> (Word, (WordInfo, WordContextHits)) -> XHtml FlowContent
  wordInfo rs m (w, (WordInfo ts s, c)) = do
          a' [A.class_ "cloud", A.href staticLink, onclick dynamicLink, A.title $ pack origin] $ do
                  span' [A.class_ $ pack $ "cloud" ++ (show ((round $ weightScore 1 9 m s)::Int))] $ text' w
          text " "
          where
          origin = join ", " $ M.keys c
          dynamicLink = pack $ "replaceInfQuery('" ++ escape t ++ "','" ++ escape w ++ "'); return false;"
          staticLink = pack $  staticRoot ++ "?query=" ++ (replace t w qu) ++ "&start=" ++ (show st)
          weightScore mi ma to v  = ma - ((to - v) / to) * (ma - mi)
          escape []      = []
          escape (x:xs)  = if x == '\'' then "\\'" ++ escape xs else x : (escape xs)
          t = head ts
          qu = rsQuery rs
          st = rsStart rs
  
  pager :: RenderState -> Int -> XHtml FlowContent
  pager rs m = if m <= 0 || m < pageLimit then empty else div'[A.id_ "pager"] $ do
                  nav "previous" "<" (_prevPage pg)
                  mapM_ page (_predPages pg)
                  span' [A.class_ "current"] $ text' $ show $  _currPage pg
                  mapM_ page (_succPages pg)
                  nav "next" ">" (_nextPage pg)
          where
          pg = makePager (rsStart rs) pageLimit m
          nav :: Text -> String -> Maybe Int -> XHtml FlowContent
          nav _ _ Nothing = empty
          nav c t (Just v) = a' [A.class_ c, A.href $ statLink v, onclick $ dynLink v] $ text' t
          page (v, t)  = a' [A.class_ "page", A.href $ statLink v, onclick $ dynLink v] $ text' $ show t
          dynLink v = pack $ "showPage(" ++ show v ++ "); return false;"
          statLink v = pack $ staticRoot ++ "?query=" ++ (rsQuery rs) ++ "&start=" ++ show v
  
  data Pager  = Pager 
                { _prevPage  :: Maybe Int -- == last predPages
                , _predPages :: [(Int, Int)]
                , _currPage  :: Int
                , _succPages :: [(Int, Int)]
                , _nextPage  :: Maybe Int -- == head succPages
                }
  
  -- Start element (counting from zero), elements per page, total number of elements.
  makePager :: Int -> Int -> Int -> Pager
  makePager s pg n = Pager pv (drop (length pd - 10) pd) (length pd + 1) (take 10 sc) nt
    where
    pv = if s < pg then Nothing else Just (s - pg)
    nt = if s + pg >= n then Nothing else Just (s + pg)
    pd = map (\x -> (x, x `div` pg + 1)) $ genPred s []
      where
      genPred rp tp = let np = rp - pg in
                                    if np < 0
                                    then tp
                                    else genPred np (np:tp)
    sc = map (\x -> (x, x `div` pg + 1)) $ genSucc s []
      where
      genSucc rs ts = let ns = rs + pg in
                                    if ns >= n
                                    then ts
                                    else genSucc ns (ts ++ [ns])
  
  -- | Replace a given list with another list in a list.
  replace :: Eq a => [a] -> [a] -> [a] -> [a]
  replace old new l = L.intercalate new . split old $ l
  
  -- | Remove leading and trailing whitespace using isSpace.
  stringTrim :: String -> String
  stringTrim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
  
  