hablo/src/HTML.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module HTML (
    generate
  ) where

import Article(Article(..))
import ArticlesList (ArticlesList(..))
import Blog (Blog(..), Path(..), Skin(..))
import Collection (Collection(..))
import qualified Collection (getAll)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (ReaderT, asks)
import qualified Data.Map as Map (elems)
import qualified Data.Text.Lazy.IO as TextIO (writeFile)
import DOM (page)
import Lucid (renderTextT)
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))

articlesLists :: Monad m => Collection -> ReaderT Blog m [(FilePath, ArticlesList)]
articlesLists (Collection {articlesFeatured, basePath, tag}) = do
  limit <- take <$> (asks $skin.$previewArticlesCount)
  return [
        (basePath </> "index" <.> "html", ArticlesList {
              tagged = tag
            , full = False
            , featured = limit articlesFeatured
          })
      , (basePath </> "all" <.> "html", ArticlesList {
              tagged = tag
            , full = True
            , featured = articlesFeatured
          })
    ]

generateArticles :: [Article] -> ReaderT Blog IO ()
generateArticles = mapM_ $ \article -> do
  baseDir <- (</>) <$> (asks $path.$root) <*> (asks $path.$articlesPath)
  (renderTextT $ page article)
    >>= liftIO . TextIO.writeFile (baseDir </> key article <.> "html")

generateCollection :: Collection -> ReaderT Blog IO ()
generateCollection (Collection {articlesFeatured = []}) = return ()
generateCollection aCollection = do
  articlesLists aCollection
  >>= (mapM_ $ \(filePath, articlesList) ->
    (renderTextT $ page articlesList)
    >>= liftIO . TextIO.writeFile filePath
  )

generate :: ReaderT Blog IO ()
generate = do
  asks articles >>= generateArticles . Map.elems
  Collection.getAll >>= mapM_ generateCollection