module Text.Haggis.Binders (
bindPage,
bindTag,
bindSpecial,
bindComment
) where
import Data.Either
import System.FilePath
import Text.Pandoc.Readers.Markdown
import Text.Pandoc.Options
import Text.Haggis.Types
import Text.Haggis.Utils
import Text.Hquery
import Text.XmlHtml
bindPage :: HaggisConfig -> Page -> [Node] -> [Node]
bindPage config Page { pageTitle = title
, pageAuthor = author
, pageTags = tags
, pageDate = date
, pagePath = path
, pageContent = content
, pageComments = comments
} =
let bindTags = if null tags
then hq ".tags" nothing
else hq ".tag *" (map (bindTag config) tags)
auth = maybe (defaultAuthor config) Just author
in hq ".title *" title .
bindTags .
hq ".author *" auth .
hq ".date *" (fmap show date) .
(hq ".content *" $ Group content) .
hq ".more [href]" (sitePath config </> path) .
hq ".commentCount *" ((show . length) comments) .
hq ".comment *" (map bindComment comments)
bindComment :: Comment -> [Node] -> [Node]
bindComment c = nameBind (commenterUrl c)
. hq ".datetime *" (show (commentTime c))
. hq ".payload *" (pandocToHtml (readMarkdown def (commentPayload c)))
where
nameBind (Just url) = hq ".name *" (commenterName c) . hq ".name [href]" url
nameBind Nothing = hq ".name" (commenterName c)
bindTag :: HaggisConfig -> String -> [Node] -> [Node]
bindTag config t = hq "a [href]" (sitePath config </> (mpTypeToPath $ Tag t)) .
hq "a *" (t ++ ", ")
bindSpecial :: HaggisConfig -> [MultiPage] -> [Node] -> [Node]
bindSpecial config mps = let (archives, tags) = bindAggregates
in hq ".tag" tags . hq ".archive *" archives
where
bindAggregates :: ([[Node] -> [Node]], [[Node] -> [Node]])
bindAggregates = let bind (MultiPage _ typ@(Archive y (Just m))) = Left $
hq "a [href]" (sitePath config </> mpTypeToPath typ) .
hq "a *" (show y ++ " - " ++ show m)
bind (MultiPage xs typ@(Tag t)) = Right $
hq ".tag [href]" (sitePath config </> mpTypeToPath typ) .
hq ".tag *" (t ++ " (" ++ show (length xs) ++ "), ")
bind _ = Left $ hq "*" nothing
in partitionEithers $ map bind mps