hablo-1.1.0.1: src/Collection.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Collection (
      Collection(..)
    , getAll
    , title
  ) where

import Article(Article)
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 Markdown (Markdown(metadata), MarkdownContent(..))
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 . getMarkdown)

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