hablo/src/DOM.hs

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

import Article (Article)
import qualified Article (preview)
import ArticlesList (
    ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
  )
import Blog (Blog(..), Skin(..), URLs(..), template)
import Blog.URL (localPrefix)
import qualified Collection (tag)
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 Lucid (
--      Attribute, 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 Network.URL (URL)
import Page (Page)
import Prelude hiding (div, head, id, lookup)
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))
import Text.Blaze.Html5 as H (
    (!), Html, ToValue(..), body, div, docTypeHtml, h2, head, li, meta, preEscapedText, script, text, title, ul
  )
import Text.Blaze.Html5.Attributes (
    charset, class_, id, src
  )

type HtmlGenerator = ReaderT Blog IO Html

class HasCard a => PageType a where
  content :: a -> HtmlGenerator
  pathToRoot :: a -> FilePath

instance PageType Article where
  content = mDContent True ".." . getMarkdown
  pathToRoot _ = ".."

instance PageType Page where
  content = mDContent True ".." . getMarkdown
  pathToRoot _ = ".."

instance PageType ArticlesList where
  content al@(ArticlesList {full}) = do
    preview <- Article.preview <$> (asks $skin.$previewLinesCount)
    h2_ . text =<< description al
    ul_ $ do
      asks hasRSS >>= rssLink
      li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
    div [class_ "articles"] (
        mapM_ (mDContent False (pathToRoot al) . 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 ()

  pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection

mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator
mDContent raw base markdown@(Markdown {key, Markdown.body}) =
  article_ ! id (toValue key) (do
      header_ . h1_ $ mDLink raw base markdown
      pre_ . toHtml $ unlines body
    )

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

prefix :: FilePath -> FilePath -> Text
prefix base = pack . (base </>)

tag :: FilePath -> String -> HtmlGenerator
tag base name =
  a_ [href_ . prefix base $ name ++ "/", class_ "tag"] $ toHtml name

defaultBanner :: FilePath -> HtmlGenerator
defaultBanner base =
  div ! id "header" $
    a_ [href_ $ pack base] (
        h1_ . toHtml =<< asks name
      )

faviconLink :: FilePath -> URL -> HtmlGenerator
faviconLink base url = link_ [
    rel_ "shortcut icon", href_ $ localPrefix base url, type_ "image/x-icon"
  ]

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

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 $ (li . generator) <$> Map.toList collection

htmlDocument :: PageType a => a -> HtmlGenerator
htmlDocument someContent =
  let base = pathToRoot someContent in
  docTypeHtml (do
      H.head (do
          meta ! charset "utf-8"
          H.title . text =<< asks name
          script ! src (prefix base "js/remarkable.min.js") mempty
          script ! src (prefix base "js/hablo.js") mempty
          optional (faviconLink base) =<< (asks $skin.$favicon)
          optional (Card.make someContent) =<< (asks $urls.$cards)
          optional preEscapedText =<< (asks $skin.$Blog.head)
        )
      H.body (do
          maybe (defaultBanner base) preEscapedText =<< (asks $skin.$banner)
          asks tags >>= navigationSection "tags" "tagsList"
                          (\(key, _) -> tag base key)
          asks pages >>= navigationSection "pages" "pagesList"
                          (\(_, page) -> mDLink False base $ getMarkdown page)
          div ! id "contents" $ content someContent
        )
    )