78 lines
2.1 KiB
Haskell
78 lines
2.1 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Dom (
|
|
Page(..)
|
|
, render
|
|
) where
|
|
|
|
import Article (Article(..))
|
|
import Blog (Blog(..))
|
|
import Control.Monad.Reader (MonadReader(..), 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)
|
|
|
|
data Page = Page {
|
|
category :: Maybe String
|
|
, full :: Bool
|
|
, articlesFeatured :: [Article]
|
|
}
|
|
|
|
blog :: (Blog -> a) -> HtmlGenerator a
|
|
blog = (<$> ask)
|
|
|
|
previewArticle :: Article -> HtmlGenerator ()
|
|
previewArticle (Article {urlPath, title, preview}) =
|
|
article_ (do
|
|
a_ [href_ urlPath] . 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 customBanner
|
|
|
|
defaultBanner :: HtmlGenerator ()
|
|
defaultBanner = do
|
|
div_ [id_ "header"] (
|
|
a_ [href_ "/"] (
|
|
h1_ . toHtml =<< blog name
|
|
)
|
|
)
|
|
|
|
render :: Page -> HtmlGenerator ()
|
|
render (Page {category, full, articlesFeatured}) =
|
|
doctypehtml_ (do
|
|
head_ (do
|
|
meta_ [charset_ "utf-8"]
|
|
title_ . toHtml =<< blog name
|
|
script_ [src_ "/UnitJS/async.js"] empty
|
|
script_ [src_ "/UnitJS/dom.js"] empty
|
|
maybe (toHtml empty) toHtmlRaw =<< blog customHead
|
|
)
|
|
body_ (do
|
|
banner
|
|
div_ [id_ "navigator"] (do
|
|
h2_ "Tags"
|
|
ul_ . mapM_ tag . Map.keys =<< blog tags
|
|
)
|
|
div_ [id_ "contents"] (do
|
|
h2_ $ toHtml pageTitle
|
|
p_ $ if full
|
|
then a_ [href_ . pack $ url category] "See only latest"
|
|
else a_ [href_ . pack $ url category </> "all.html"] "See all"
|
|
div_ [class_ "articles"] (mapM_ previewArticle articlesFeatured)
|
|
)
|
|
)
|
|
)
|
|
where
|
|
pageTitle =
|
|
(if full then "All" else "Latest") ++ " articles" ++ maybe "" (" tagged " ++) category
|
|
url = maybe "/" ("/" </>)
|