54 lines
1.6 KiB
Haskell
54 lines
1.6 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Collection (
|
|
Collection(..)
|
|
, getAll
|
|
, title
|
|
) where
|
|
|
|
import Article(Article(metadata))
|
|
import Blog (Blog(..), Path(..))
|
|
import Control.Monad.IO.Class (MonadIO(..))
|
|
import Control.Monad.Reader (MonadReader(..), ReaderT, asks)
|
|
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 Pretty ((.$))
|
|
import System.Directory (createDirectoryIfMissing)
|
|
import System.FilePath ((</>))
|
|
|
|
data Collection = Collection {
|
|
featured :: [Article]
|
|
, basePath :: FilePath
|
|
, tag :: Maybe String
|
|
}
|
|
|
|
build :: MonadIO m => [Article] -> Maybe String -> ReaderT Blog m Collection
|
|
build featured tag = do
|
|
root <- asks $path.$root
|
|
let basePath = maybe root (root </>) tag
|
|
liftIO $ createDirectoryIfMissing False basePath
|
|
return $ Collection {
|
|
featured = sortByDate featured, basePath, tag
|
|
}
|
|
where
|
|
sortByDate = sortOn (Down . (! "date") . metadata)
|
|
|
|
getAll :: ReaderT Blog IO [Collection]
|
|
getAll = do
|
|
Blog {articles, tags} <- ask
|
|
(:)
|
|
<$> (build (Map.elems articles) Nothing)
|
|
<*> (flip mapM (Map.toList tags) $
|
|
\(tag, tagged) -> build (getArticles tagged articles) $ Just tag
|
|
)
|
|
where
|
|
getArticles tagged =
|
|
Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged)
|
|
|
|
title :: MonadReader Blog m => Collection -> m String
|
|
title (Collection {tag}) = do
|
|
asks $ (\name -> maybe name ((name ++ " - ") ++) tag) . name
|