114 lines
3.5 KiB
Haskell
114 lines
3.5 KiB
Haskell
{-# 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 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 (
|
|
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 = markdown True . getMarkdown
|
|
|
|
instance HasContent Page where
|
|
content = markdown 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_ (markdown 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 ()
|
|
|
|
markdown :: Bool -> Markdown -> HtmlGenerator ()
|
|
markdown raw (Markdown {key, Markdown.path, body, title}) =
|
|
let url = absoluteLink $ path <.> extension in
|
|
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 name = li_ (
|
|
a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name
|
|
)
|
|
|
|
defaultBanner :: HtmlGenerator ()
|
|
defaultBanner = do
|
|
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 ())
|
|
|
|
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)
|
|
div_ [id_ "navigator"] (do
|
|
h2_ . toHtml =<< template "tagsList" []
|
|
ul_ . mapM_ tag . Map.keys =<< asks tags
|
|
)
|
|
div_ [id_ "contents"] $ content someContent
|
|
)
|
|
)
|