{-# 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 (
      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 (head, lookup)
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))

type HtmlGenerator = HtmlT (ReaderT Blog IO)

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_ . toHtml =<< 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, body}) =
  article_ [id_ $ pack key] (do
      header_ . h1_ $ mDLink raw base markdown
      pre_ . toHtml $ unlines body
    )

mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator ()
mDLink raw base (Markdown {Markdown.path, 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 ()) 

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

htmlDocument :: PageType a => a -> HtmlGenerator ()
htmlDocument someContent =
  let base = pathToRoot someContent in
  doctypehtml_ (do
      head_ (do
          meta_ [charset_ "utf-8"]
          title_ . toHtml =<< asks name
          script_ [src_ $ prefix base "js/remarkable.min.js"] empty
          script_ [src_ $ prefix base "js/hablo.js"] empty
          optional (faviconLink base) =<< (asks $skin.$favicon)
          optional (Card.make someContent) =<< (asks $urls.$cards)
          optional toHtmlRaw =<< (asks $skin.$head)
        )
      body_ (do
          maybe (defaultBanner base) toHtmlRaw =<< (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
        )
    )