summaryrefslogtreecommitdiff
path: root/src/Text/Hakyll/HakyllMonad.hs
blob: f51cf2c9649c09153442722adff362b1e2eeaaa9 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
-- | Module describing the Hakyll monad stack.
module Text.Hakyll.HakyllMonad
    ( HakyllConfiguration (..)
    , PreviewMode (..)
    , Hakyll
    , askHakyll
    , getAdditionalContext
    , logHakyll
    , forkHakyllWait
    , concurrentHakyll
    ) where

import Control.Monad.Trans (liftIO)
import Control.Concurrent.MVar (MVar, putMVar, newEmptyMVar, readMVar)
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad (liftM, forM, forM_)
import qualified Data.Map as M
import System.IO (hPutStrLn, stderr)

import Text.Pandoc (ParserState, WriterOptions)
import Text.Hamlet (HamletSettings)

import Text.Hakyll.Context (Context (..))

-- | Our custom monad stack.
--
type Hakyll = ReaderT HakyllConfiguration IO

-- | Preview mode.
--
data PreviewMode = BuildOnRequest
                 | BuildOnInterval
                 deriving (Show, Eq, Ord)

-- | Hakyll global configuration type.
--
data HakyllConfiguration = HakyllConfiguration
    { -- | Absolute URL of the site.
      absoluteUrl         :: String
    , -- | An additional context to use when rendering. This additional context
      --   is used globally.
      additionalContext   :: Context
    , -- | Directory where the site is placed.
      siteDirectory       :: FilePath
    , -- | Directory for cache files.
      cacheDirectory      :: FilePath
    , -- | Enable index links.
      enableIndexUrl      :: Bool
    , -- | The preview mode used
      previewMode         :: PreviewMode
    , -- | Pandoc parsing options
      pandocParserState   :: ParserState
    , -- | Pandoc writer options
      pandocWriterOptions :: WriterOptions
    , -- | Hamlet settings (if you use hamlet for templates)
      hamletSettings      :: HamletSettings
    }

-- | Simplified @ask@ function for the Hakyll monad stack.
--
--   Usage would typically be something like:
--
--   > doSomething :: a -> b -> Hakyll c
--   > doSomething arg1 arg2 = do
--   >     siteDirectory' <- askHakyll siteDirectory
--   >     ...
--
askHakyll :: (HakyllConfiguration -> a) -> Hakyll a
askHakyll = flip liftM ask

-- | Obtain the globally available, additional context.
--
getAdditionalContext :: HakyllConfiguration -> Context
getAdditionalContext configuration =
    let (Context c) = additionalContext configuration
    in Context $ M.insert "absolute" (absoluteUrl configuration) c

-- | Write some log information.
--
logHakyll :: String -> Hakyll ()
logHakyll = liftIO . hPutStrLn stderr

-- | Perform a concurrent hakyll action. Returns an MVar you can wait on
--
forkHakyllWait :: Hakyll () -> Hakyll (MVar ())
forkHakyllWait action = do
    mvar <- liftIO newEmptyMVar
    config <- ask
    liftIO $ do
        runReaderT action config
        putMVar mvar ()
    return mvar

-- | Perform a number of concurrent hakyll actions, and waits for them to finish
--
concurrentHakyll :: [Hakyll ()] -> Hakyll ()
concurrentHakyll actions = do
    mvars <- forM actions forkHakyllWait
    forM_ mvars (liftIO . readMVar)