hablo-1.1.0.1: src/Blog.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
module Blog (
      Blog(..)
    , Path(..)
    , Renderer
    , Skin(..)
    , URL(..)
    , Wording
    , build
    , template
  ) where

import Arguments (Arguments)
import qualified Arguments (name, sourceDir)
import Article (Article)
import qualified Article (at)
import Blog.Path (Path(..))
import qualified Blog.Path as Path (build)
import Blog.Template (Environment, Templates, render)
import qualified Blog.Template as Template (build)
import Blog.Skin (Skin(..))
import qualified Blog.Skin as Skin (build)
import Blog.URL (URL(..))
import qualified Blog.URL as URL (build)
import Blog.Wording (Wording)
import qualified Blog.Wording as Wording (build)
import Control.Monad ((>=>), filterM, foldM, forM)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader, asks)
import Data.Map (Map, insert, lookup)
import qualified Data.Map as Map (empty, fromList)
import Data.Set (Set)
import qualified Data.Set as Set (empty, null, singleton, union)
import Data.Text (Text)
import Files (File(..), filePath)
import qualified Files (find)
import Markdown (getKey)
import Page (Page)
import qualified Page (at)
import Prelude hiding (lookup)
import Pretty (assertRight, onRight)
import System.Directory (doesFileExist, makeAbsolute, withCurrentDirectory)
import System.FilePath ((</>), dropTrailingPathSeparator, takeExtension, takeFileName)
import Text.Parsec (ParseError)

type Collection = Map String
type Parsed a = Either ParseError (String, a)

data Blog = Blog {
      articles :: Collection Article
    , hasRSS :: Bool
    , name :: String
    , pages :: Collection Page
    , path :: Path
    , skin :: Skin
    , tags :: Collection (Set String)
    , templates :: Templates
    , urls :: URL
    , wording :: Wording
  }

type Renderer m = (MonadIO m, MonadReader Blog m)

template :: Renderer m => String -> Environment -> m Text
template key environment = asks templates >>= render key environment

keepOrWarn :: Collection a -> Parsed a -> IO (Collection a)
keepOrWarn accumulator (Left parseErrors) =
  forM [show parseErrors, "=> Ignoring this text"] putStrLn
  >> return accumulator
keepOrWarn accumulator (Right (key, article)) =
  return $ insert key article accumulator

find :: (FilePath -> IO (Parsed a)) -> FilePath -> IO (Collection a)
find parser =
  Files.find
  >=> filterM isMarkDownFile
  >=> mapM parser
  >=> foldM keepOrWarn Map.empty
  where
    isMarkDownFile path = do
      let correctExtension = takeExtension path == ".md"
      (correctExtension &&) <$> doesFileExist path

tagged :: Collection Article -> FilePath -> IO (String, Set String)
tagged collection path = do
  links <- Files.find path
  keys <- forM links $ \link -> do
    fileExists <- doesFileExist link
    return $ if fileExists
      then let articleKey = getKey link in
        maybe Set.empty (\_ -> Set.singleton articleKey) (lookup articleKey collection)
      else Set.empty
  return (takeFileName path, foldl Set.union Set.empty keys)

discover :: Path -> IO (Collection Article, Collection Page, Collection (Set String))
discover path = do
  (articles, tags) <- discoverArticles $ articlesPath path
  pages <- maybe (return Map.empty) (find Page.at) $ pagesPath path
  return (articles, pages, tags)
  where
    discoverArticles Nothing = return (Map.empty, Map.empty)
    discoverArticles (Just somePath) = do
      articles <- find Article.at somePath
      tags <- Map.fromList . filter (not . Set.null . snd)
        <$> (Files.find (somePath </> "tags") >>= mapM (articles `tagged`))
      return (articles, tags)

build :: Arguments -> IO Blog
build arguments = do
  urls <- URL.build arguments
  let hasRSS = maybe False (\_-> True) $ rss urls
  wording <- Wording.build arguments
  templates <- Template.build wording
  root <- onRight makeAbsolute =<< filePath (Dir $ Arguments.sourceDir arguments)
  withCurrentDirectory root $ do
    path <- assertRight =<< Path.build root arguments
    let name = maybe (takeFileName $ dropTrailingPathSeparator root) id
              $ Arguments.name arguments
    skin <- Skin.build name arguments
    (articles, pages, tags) <- discover path
    return $ Blog {
        articles, hasRSS, name, pages, path, skin, tags, templates, urls, wording
      }