hablo/src/Dom.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Dom (
      article
    , articlesList
    , page
  ) where

import Article (Article(..))
import ArticlesList (ArticlesList(..), otherLink, otherUrl, pageTitle)
import Blog (Blog(..))
import qualified Blog (get)
import Control.Monad.Reader (ReaderT)
import qualified Data.Map as Map (keys)
import Data.Text (pack, empty)
import Lucid
import System.FilePath.Posix ((</>), (<.>))

type HtmlGenerator = HtmlT (ReaderT Blog IO)

previewArticle :: Article -> HtmlGenerator ()
previewArticle (Article {urlPath, title, preview}) =
  article_ (do
    a_ [href_ . pack $ "/" </> urlPath <.> "html"] . h3_ $ toHtml title
    pre_ $ toHtml preview
  )

tag :: String -> HtmlGenerator ()
tag tagName = li_ (a_ [href_ $ pack ("/" </> tagName)] $ toHtml tagName)

banner :: HtmlGenerator ()
banner = do
  maybe defaultBanner toHtmlRaw =<< Blog.get customBanner

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

article :: Article -> HtmlGenerator ()
article (Article {fullContents, urlPath}) =
  article_ (do
      a_ [href_ . pack $ "/" </> urlPath <.> "md"] "Raw"
      pre_ $ toHtml fullContents
    )

articlesList :: ArticlesList -> HtmlGenerator ()
articlesList al@(ArticlesList {featured}) =
  div_ [id_ "contents"] (do
      h2_ . toHtml $ pageTitle al
      p_ . a_ [href_ $ otherUrl al] . toHtml $ otherLink al
      div_ [class_ "articles"] (mapM_ previewArticle featured)
    )

page :: HtmlGenerator () -> HtmlGenerator ()
page contents =
  doctypehtml_ (do
      head_ (do
          meta_ [charset_ "utf-8"]
          title_ . toHtml =<< Blog.get name
          script_ [src_ "/UnitJS/async.js"] empty
          script_ [src_ "/UnitJS/dom.js"] empty
          maybe (toHtml empty) toHtmlRaw =<< Blog.get customHead
        )
      body_ (do
          banner
          div_ [id_ "navigator"] (do
              h2_ "Tags"
              ul_ . mapM_ tag . Map.keys =<< Blog.get tags
            )
          div_ [id_ "contents"] contents
        )
    )