{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module HTML ( generate ) where import Article(Article(..)) import ArticlesList (ArticlesList(..)) import Blog (Blog(..), Path(..), Skin(..)) import qualified Blog (get) import Control.Monad (forM) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT) import Data.List (sortOn) import Data.Map ((!)) import qualified Data.Map as Map (elems, filterWithKey, toList) import Data.Ord (Down(..)) import qualified Data.Set as Set (member) import qualified Data.Text.Lazy.IO as TextIO (writeFile) import Dom (page) import Lucid import Pretty ((.$)) import System.Directory (createDirectoryIfMissing) import System.FilePath.Posix ((), (<.>)) data Collection = Collection { articlesFeatured :: [Article] , basePath :: FilePath , tag :: Maybe String } collection :: Monad m => [Article] -> Maybe String -> ReaderT Blog m Collection collection articlesFeatured tag = do root <- Blog.get $path.$root return $ Collection { articlesFeatured = sortByDate articlesFeatured , basePath = maybe root (root ) tag , tag } where sortByDate = sortOn (Down . (! "date") . metadata) articlesLists :: Monad m => Collection -> ReaderT Blog m [(FilePath, ArticlesList)] articlesLists (Collection {articlesFeatured, basePath, tag}) = do limit <- take <$> (Blog.get $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 <- () <$> (Blog.get $path.$root) <*> (Blog.get $path.$articlesPath) (renderTextT $ page article) >>= liftIO . TextIO.writeFile (baseDir key article <.> "html") generateCollection :: Collection -> ReaderT Blog IO () generateCollection (Collection {articlesFeatured = []}) = return () generateCollection aCollection = do liftIO . createDirectoryIfMissing False $ basePath aCollection articlesLists aCollection >>= (mapM_ $ \(filePath, articlesList) -> (renderTextT $ page articlesList) >>= liftIO . TextIO.writeFile filePath ) generate :: ReaderT Blog IO () generate = do Blog {articles, tags} <- ask generateArticles $ Map.elems articles collection (Map.elems articles) Nothing >>= generateCollection forM (Map.toList tags) $ \(tag, tagged) -> collection (getArticles tagged articles) $ Just tag >>= mapM_ generateCollection where getArticles tagged = Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged)