{-# 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 {
      Blog -> Collection Article
articles :: Collection Article
    , Blog -> Bool
hasRSS :: Bool
    , Blog -> String
name :: String
    , Blog -> Collection Page
pages :: Collection Page
    , Blog -> Path
path :: Path
    , Blog -> Skin
skin :: Skin
    , Blog -> Collection (Set String)
tags :: Collection (Set String)
    , Blog -> Templates
templates :: Templates
    , Blog -> URL
urls :: URL
    , Blog -> Wording
wording :: Wording
  }

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

template :: Renderer m => String -> Environment -> m Text
template :: String -> Environment -> m Text
template String
key Environment
environment = (Blog -> Templates) -> m Templates
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Blog -> Templates
templates m Templates -> (Templates -> m Text) -> m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Environment -> Templates -> m Text
forall (m :: * -> *).
MonadIO m =>
String -> Environment -> Templates -> m Text
render String
key Environment
environment

keepOrWarn :: Collection a -> Parsed a -> IO (Collection a)
keepOrWarn :: Collection a -> Parsed a -> IO (Collection a)
keepOrWarn Collection a
accumulator (Left ParseError
parseErrors) =
  [String] -> (String -> IO ()) -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ParseError -> String
forall a. Show a => a -> String
show ParseError
parseErrors, String
"=> Ignoring this text"] String -> IO ()
putStrLn
  IO [()] -> IO (Collection a) -> IO (Collection a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Collection a -> IO (Collection a)
forall (m :: * -> *) a. Monad m => a -> m a
return Collection a
accumulator
keepOrWarn Collection a
accumulator (Right (String
key, a
article)) =
  Collection a -> IO (Collection a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Collection a -> IO (Collection a))
-> Collection a -> IO (Collection a)
forall a b. (a -> b) -> a -> b
$ String -> a -> Collection a -> Collection a
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert String
key a
article Collection a
accumulator

find :: (FilePath -> IO (Parsed a)) -> FilePath -> IO (Collection a)
find :: (String -> IO (Parsed a)) -> String -> IO (Collection a)
find String -> IO (Parsed a)
parser =
  String -> IO [String]
Files.find
  (String -> IO [String])
-> ([String] -> IO (Collection a)) -> String -> IO (Collection a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
isMarkDownFile
  ([String] -> IO [String])
-> ([String] -> IO (Collection a)) -> [String] -> IO (Collection a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (String -> IO (Parsed a)) -> [String] -> IO [Parsed a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Parsed a)
parser
  ([String] -> IO [Parsed a])
-> ([Parsed a] -> IO (Collection a))
-> [String]
-> IO (Collection a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Collection a -> Parsed a -> IO (Collection a))
-> Collection a -> [Parsed a] -> IO (Collection a)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Collection a -> Parsed a -> IO (Collection a)
forall a. Collection a -> Parsed a -> IO (Collection a)
keepOrWarn Collection a
forall k a. Map k a
Map.empty
  where
    isMarkDownFile :: String -> IO Bool
isMarkDownFile String
path = do
      let correctExtension :: Bool
correctExtension = String -> String
takeExtension String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".md"
      (Bool
correctExtension Bool -> Bool -> Bool
&&) (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
doesFileExist String
path

tagged :: Collection Article -> FilePath -> IO (String, Set String)
tagged :: Collection Article -> String -> IO (String, Set String)
tagged Collection Article
collection String
path = do
  [String]
links <- String -> IO [String]
Files.find String
path
  [Set String]
keys <- [String] -> (String -> IO (Set String)) -> IO [Set String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
links ((String -> IO (Set String)) -> IO [Set String])
-> (String -> IO (Set String)) -> IO [Set String]
forall a b. (a -> b) -> a -> b
$ \String
link -> do
    Bool
fileExists <- String -> IO Bool
doesFileExist String
link
    Set String -> IO (Set String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set String -> IO (Set String)) -> Set String -> IO (Set String)
forall a b. (a -> b) -> a -> b
$ if Bool
fileExists
      then let articleKey :: String
articleKey = String -> String
getKey String
link in
        Set String
-> (Article -> Set String) -> Maybe Article -> Set String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set String
forall a. Set a
Set.empty (\Article
_ -> String -> Set String
forall a. a -> Set a
Set.singleton String
articleKey) (String -> Collection Article -> Maybe Article
forall k a. Ord k => k -> Map k a -> Maybe a
lookup String
articleKey Collection Article
collection)
      else Set String
forall a. Set a
Set.empty
  (String, Set String) -> IO (String, Set String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
takeFileName String
path, (Set String -> Set String -> Set String)
-> Set String -> [Set String] -> Set String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set String
forall a. Set a
Set.empty [Set String]
keys)

discover :: Path -> IO (Collection Article, Collection Page, Collection (Set String))
discover :: Path
-> IO
     (Collection Article, Collection Page, Collection (Set String))
discover Path
path = do
  (Collection Article
articles, Collection (Set String)
tags) <- Maybe String -> IO (Collection Article, Collection (Set String))
discoverArticles (Maybe String -> IO (Collection Article, Collection (Set String)))
-> Maybe String -> IO (Collection Article, Collection (Set String))
forall a b. (a -> b) -> a -> b
$ Path -> Maybe String
articlesPath Path
path
  Collection Page
pages <- IO (Collection Page)
-> (String -> IO (Collection Page))
-> Maybe String
-> IO (Collection Page)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Collection Page -> IO (Collection Page)
forall (m :: * -> *) a. Monad m => a -> m a
return Collection Page
forall k a. Map k a
Map.empty) ((String -> IO (Parsed Page)) -> String -> IO (Collection Page)
forall a. (String -> IO (Parsed a)) -> String -> IO (Collection a)
find String -> IO (Parsed Page)
Page.at) (Maybe String -> IO (Collection Page))
-> Maybe String -> IO (Collection Page)
forall a b. (a -> b) -> a -> b
$ Path -> Maybe String
pagesPath Path
path
  (Collection Article, Collection Page, Collection (Set String))
-> IO
     (Collection Article, Collection Page, Collection (Set String))
forall (m :: * -> *) a. Monad m => a -> m a
return (Collection Article
articles, Collection Page
pages, Collection (Set String)
tags)
  where
    discoverArticles :: Maybe String -> IO (Collection Article, Collection (Set String))
discoverArticles Maybe String
Nothing = (Collection Article, Collection (Set String))
-> IO (Collection Article, Collection (Set String))
forall (m :: * -> *) a. Monad m => a -> m a
return (Collection Article
forall k a. Map k a
Map.empty, Collection (Set String)
forall k a. Map k a
Map.empty)
    discoverArticles (Just String
somePath) = do
      Collection Article
articles <- (String -> IO (Parsed Article))
-> String -> IO (Collection Article)
forall a. (String -> IO (Parsed a)) -> String -> IO (Collection a)
find String -> IO (Parsed Article)
Article.at String
somePath
      Collection (Set String)
tags <- [(String, Set String)] -> Collection (Set String)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, Set String)] -> Collection (Set String))
-> ([(String, Set String)] -> [(String, Set String)])
-> [(String, Set String)]
-> Collection (Set String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Set String) -> Bool)
-> [(String, Set String)] -> [(String, Set String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, Set String) -> Bool) -> (String, Set String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set String -> Bool
forall a. Set a -> Bool
Set.null (Set String -> Bool)
-> ((String, Set String) -> Set String)
-> (String, Set String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Set String) -> Set String
forall a b. (a, b) -> b
snd)
        ([(String, Set String)] -> Collection (Set String))
-> IO [(String, Set String)] -> IO (Collection (Set String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]
Files.find (String
somePath String -> String -> String
</> String
"tags") IO [String]
-> ([String] -> IO [(String, Set String)])
-> IO [(String, Set String)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO (String, Set String))
-> [String] -> IO [(String, Set String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Collection Article
articles Collection Article -> String -> IO (String, Set String)
`tagged`))
      (Collection Article, Collection (Set String))
-> IO (Collection Article, Collection (Set String))
forall (m :: * -> *) a. Monad m => a -> m a
return (Collection Article
articles, Collection (Set String)
tags)

build :: Arguments -> IO Blog
build :: Arguments -> IO Blog
build Arguments
arguments = do
  URL
urls <- Arguments -> IO URL
URL.build Arguments
arguments
  let hasRSS :: Bool
hasRSS = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\String
_-> Bool
True) (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ URL -> Maybe String
rss URL
urls
  Wording
wording <- Arguments -> IO Wording
Wording.build Arguments
arguments
  Templates
templates <- Wording -> IO Templates
Template.build Wording
wording
  String
root <- (String -> IO String) -> Either String String -> IO String
forall a b. (a -> IO b) -> Either String a -> IO b
onRight String -> IO String
makeAbsolute (Either String String -> IO String)
-> IO (Either String String) -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< File -> IO (Either String String)
filePath (String -> File
Dir (String -> File) -> String -> File
forall a b. (a -> b) -> a -> b
$ Arguments -> String
Arguments.sourceDir Arguments
arguments)
  String -> IO Blog -> IO Blog
forall a. String -> IO a -> IO a
withCurrentDirectory String
root (IO Blog -> IO Blog) -> IO Blog -> IO Blog
forall a b. (a -> b) -> a -> b
$ do
    Path
path <- Either String Path -> IO Path
forall a. Either String a -> IO a
assertRight (Either String Path -> IO Path)
-> IO (Either String Path) -> IO Path
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Arguments -> IO (Either String Path)
Path.build String
root Arguments
arguments
    let name :: String
name = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> String
takeFileName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
dropTrailingPathSeparator String
root) String -> String
forall a. a -> a
id
              (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Arguments -> Maybe String
Arguments.name Arguments
arguments
    Skin
skin <- String -> Arguments -> IO Skin
Skin.build String
name Arguments
arguments
    (Collection Article
articles, Collection Page
pages, Collection (Set String)
tags) <- Path
-> IO
     (Collection Article, Collection Page, Collection (Set String))
discover Path
path
    Blog -> IO Blog
forall (m :: * -> *) a. Monad m => a -> m a
return (Blog -> IO Blog) -> Blog -> IO Blog
forall a b. (a -> b) -> a -> b
$ Blog :: Collection Article
-> Bool
-> String
-> Collection Page
-> Path
-> Skin
-> Collection (Set String)
-> Templates
-> URL
-> Wording
-> Blog
Blog {
        Collection Article
articles :: Collection Article
articles :: Collection Article
articles, Bool
hasRSS :: Bool
hasRSS :: Bool
hasRSS, String
name :: String
name :: String
name, Collection Page
pages :: Collection Page
pages :: Collection Page
pages, Path
path :: Path
path :: Path
path, Skin
skin :: Skin
skin :: Skin
skin, Collection (Set String)
tags :: Collection (Set String)
tags :: Collection (Set String)
tags, Templates
templates :: Templates
templates :: Templates
templates, URL
urls :: URL
urls :: URL
urls, Wording
wording :: Wording
wording :: Wording
wording
      }