85 lines
2.8 KiB
Haskell
85 lines
2.8 KiB
Haskell
{-# 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)
|