96 lines
3.0 KiB
Haskell
96 lines
3.0 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module DOM (
|
|
page
|
|
) where
|
|
|
|
import Article (Article(..))
|
|
import qualified Article (preview)
|
|
import ArticlesList (ArticlesList(..), otherUrl, pageTitle)
|
|
import Blog (Blog(..), Path(..), Skin(..), URL(..))
|
|
import qualified Blog (get)
|
|
import Blog.Wording (render)
|
|
import Control.Monad.Reader (ReaderT)
|
|
import qualified Data.Map as Map (keys)
|
|
import Data.Text (pack, empty)
|
|
import DOM.Card (HasCard)
|
|
import qualified DOM.Card as Card (make)
|
|
import Files (absoluteLink)
|
|
import Lucid
|
|
import Prelude hiding (head, lookup)
|
|
import Pretty ((.$))
|
|
import System.FilePath.Posix ((</>), (<.>))
|
|
|
|
type HtmlGenerator = HtmlT (ReaderT Blog IO)
|
|
|
|
class HasCard a => Page a where
|
|
content :: a -> HtmlGenerator ()
|
|
|
|
instance Page Article where
|
|
content = article True
|
|
|
|
instance Page ArticlesList where
|
|
content al@(ArticlesList {featured, full}) = do
|
|
preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
|
|
h2_ . toHtml =<< pageTitle al
|
|
a_ [href_ . pack $ otherUrl al] . toHtml =<< otherLink
|
|
div_ [class_ "articles"] (
|
|
mapM_ (article False . preview) featured
|
|
)
|
|
where
|
|
link = render (if full then "latestLink" else "allLink") []
|
|
otherLink = Blog.get $wording.$(link)
|
|
|
|
article :: Bool -> Article -> HtmlGenerator ()
|
|
article raw (Article {key, body, Article.title}) = do
|
|
url <- absoluteLink . (</> key <.> extension) <$> (Blog.get $path.$articlesPath)
|
|
article_ [id_ $ pack key] (do
|
|
header_ (do
|
|
a_ [href_ . pack $ url] . h1_ $ toHtml title
|
|
)
|
|
pre_ . toHtml $ unlines body
|
|
)
|
|
where extension = if raw then "md" else "html"
|
|
|
|
tag :: String -> HtmlGenerator ()
|
|
tag tagName = li_ (
|
|
a_ [href_ . pack $ absoluteLink tagName, class_ "tag"] $ toHtml tagName
|
|
)
|
|
|
|
defaultBanner :: HtmlGenerator ()
|
|
defaultBanner = do
|
|
div_ [id_ "header"] (
|
|
a_ [href_ "/"] (
|
|
h1_ . toHtml =<< Blog.get name
|
|
)
|
|
)
|
|
|
|
faviconLink :: FilePath -> HtmlGenerator ()
|
|
faviconLink url = link_ [rel_ "shortcut icon", href_ $ pack url, type_ "image/x-icon"]
|
|
|
|
optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
|
|
optional = maybe (return ())
|
|
|
|
page :: Page a => a -> HtmlGenerator ()
|
|
page aPage =
|
|
doctypehtml_ (do
|
|
head_ (do
|
|
meta_ [charset_ "utf-8"]
|
|
title_ . toHtml =<< Blog.get name
|
|
script_ [src_ "/js/unit.js"] empty
|
|
script_ [src_ "/js/remarkable.min.js"] empty
|
|
script_ [src_ "/js/hablo.js"] empty
|
|
optional faviconLink =<< (Blog.get $skin.$favicon)
|
|
optional (Card.make aPage) =<< (Blog.get $urls.$site)
|
|
(Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
|
|
)
|
|
body_ (do
|
|
maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
|
|
div_ [id_ "navigator"] (do
|
|
h2_ =<< (Blog.get $wording.$(render "tagsList" []).$toHtml)
|
|
ul_ . mapM_ tag . Map.keys =<< Blog.get tags
|
|
)
|
|
div_ [id_ "contents"] $ content aPage
|
|
)
|
|
)
|