127 lines
4.2 KiB
Haskell
127 lines
4.2 KiB
Haskell
{-# 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
|
|
}
|