hablo/src/DOM.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module DOM (
      HasContent(..)
    , htmlDocument
  ) where

import Article (Article)
import qualified Article (preview)
import ArticlesList (
    ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
  )
import Blog (Blog(..), Skin(..), URL(..), template)
import Control.Monad.Reader (ReaderT, asks)
import Data.Map as Map (Map, toList)
import Data.Text (Text, pack, empty)
import DOM.Card (HasCard)
import qualified DOM.Card as Card (make)
import Files (absoluteLink)
import Lucid (
      HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_, h1_, h2_
    , head_, header_, href_, li_, link_, id_, meta_, pre_, rel_, script_, src_
    , title_, toHtml, toHtmlRaw, type_, ul_
  )
import Markdown (Markdown(..), MarkdownContent(..))
import Page (Page)
import Prelude hiding (head, lookup)
import Pretty ((.$))
import System.FilePath.Posix ((<.>))

type HtmlGenerator = HtmlT (ReaderT Blog IO)

class HasCard a => HasContent a where
  content :: a -> HtmlGenerator ()

instance HasContent Article where
  content = mDContent True . getMarkdown

instance HasContent Page where
  content = mDContent True . getMarkdown

instance HasContent ArticlesList where
  content al@(ArticlesList {full}) = do
    preview <- Article.preview <$> (asks $skin.$previewLinesCount)
    h2_ . toHtml =<< description al
    ul_ $ do
      asks hasRSS >>= rssLink
      li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
    div_ [class_ "articles"] (
        mapM_ (mDContent False . preview) =<< getArticles al
      )
    where
      otherLink =
        toHtml <$> template (if full then "latestLink" else "allLink") []
      rssLink :: Bool -> HtmlGenerator ()
      rssLink True = do
        (text, title) <- rssLinkTexts al
        li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
      rssLink False = return ()

mDContent :: Bool -> Markdown -> HtmlGenerator ()
mDContent raw markdown@(Markdown {key, body}) =
  article_ [id_ $ pack key] (do
      header_ . h1_ $ mDLink raw markdown
      pre_ . toHtml $ unlines body
    )

mDLink :: Bool -> Markdown -> HtmlGenerator ()
mDLink raw (Markdown {Markdown.path, title}) =
  a_ [href_ $ pack url] $ toHtml title
  where
    url = absoluteLink $ path <.> (if raw then "md" else "html")

tag :: String -> HtmlGenerator ()
tag name =
  a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name

defaultBanner :: HtmlGenerator ()
defaultBanner =
  div_ [id_ "header"] (
      a_ [href_ "/"] (
          h1_ . toHtml =<< asks name
        )
    )

faviconLink :: FilePath -> HtmlGenerator ()
faviconLink url = link_ [
    rel_ "shortcut icon", href_ . pack $ absoluteLink url, type_ "image/x-icon"
  ]

optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
optional = maybe (return ()) 

navigationSection ::
  Text -> String -> ((String, a) -> HtmlGenerator ()) -> Map String a -> HtmlGenerator ()
navigationSection sectionId templateKey generator collection
  | null collection = return ()
  | otherwise =
      div_ [id_ sectionId, class_ "navigator"] (do
          h2_ . toHtml =<< template templateKey []
          ul_ . mapM_  (li_ . generator) $ Map.toList collection
        )

htmlDocument :: HasContent a => a -> HtmlGenerator ()
htmlDocument someContent =
  doctypehtml_ (do
      head_ (do
          meta_ [charset_ "utf-8"]
          title_ . toHtml =<< asks name
          script_ [src_ "/js/remarkable.min.js"] empty
          script_ [src_ "/js/hablo.js"] empty
          optional faviconLink =<< (asks $skin.$favicon)
          optional (Card.make someContent) =<< (asks $urls.$cards)
          optional toHtmlRaw =<< (asks $skin.$head)
        )
      body_ (do
          maybe defaultBanner toHtmlRaw =<< (asks $skin.$banner)
          asks tags >>= navigationSection "tags" "tagsList"
                          (\(key, _) -> tag key)
          asks pages >>= navigationSection "pages" "pagesList"
                          (\(_, page) -> mDLink False $ getMarkdown page)
          div_ [id_ "contents"] $ content someContent
        )
    )