summaryrefslogtreecommitdiff
path: root/src/Text/Hakyll/HakyllAction.hs
blob: 491f1f1b1c9db4313c7c32327355e8aea93376cf (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
-- | This is the module which exports @HakyllAction@.
module Text.Hakyll.HakyllAction
    ( HakyllAction (..)
    , createHakyllAction
    , createSimpleHakyllAction
    , createFileHakyllAction
    , chain
    , runHakyllAction
    , runHakyllActionIfNeeded
    ) where

import Control.Arrow
import Control.Category
import Control.Monad ((<=<), unless)
import Prelude hiding ((.), id)

import Text.Hakyll.File (toDestination, isFileMoreRecent)
import Text.Hakyll.HakyllMonad

-- | Type used for rendering computations that carry along dependencies.
data HakyllAction a b = HakyllAction
    { -- | Dependencies of the @HakyllAction@.
      actionDependencies :: [FilePath]
    , -- | URL pointing to the result of this @HakyllAction@.
      actionUrl          :: Either (Hakyll FilePath)
                                   (Hakyll FilePath -> Hakyll FilePath)
    , -- | The actual render function.
      actionFunction     :: a -> Hakyll b
    }

-- | Create a @HakyllAction@ from a function.
createHakyllAction :: (a -> Hakyll b)  -- ^ Function to execute.
                   -> HakyllAction a b
createHakyllAction f = id { actionFunction = f }

-- | Create a @HakyllAction@ from a simple @Hakyll@ value.
createSimpleHakyllAction :: Hakyll b -- ^ Hakyll value to pass on.
                         -> HakyllAction () b
createSimpleHakyllAction = createHakyllAction . const

-- | Create a @HakyllAction@ that operates on one file.
createFileHakyllAction :: FilePath          -- ^ File to operate on.
                       -> Hakyll b          -- ^ Value to pass on.
                       -> HakyllAction () b -- ^ The resulting action.
createFileHakyllAction path action = HakyllAction
    { actionDependencies = [path]
    , actionUrl          = Left $ return path
    , actionFunction     = const action
    }

-- | Run a @HakyllAction@ now.
runHakyllAction :: HakyllAction () a -- ^ Render action to run.
                -> Hakyll a          -- ^ Result of the action.
runHakyllAction action = actionFunction action ()

-- | Run a @HakyllAction@, but only when it is out-of-date. At this point, the
--   @actionUrl@ field must be set.
runHakyllActionIfNeeded :: HakyllAction () () -- ^ Action to run.
                        -> Hakyll ()          -- ^ Empty result.
runHakyllActionIfNeeded action = do
    url <- case actionUrl action of
        Left u  -> u
        Right _ -> error "No url when checking dependencies."
    destination <- toDestination url
    valid <- isFileMoreRecent destination $ actionDependencies action
    unless valid $ do logHakyll $ "Rendering " ++ destination
                      runHakyllAction action

-- | Chain a number of @HakyllAction@ computations.
chain :: [HakyllAction a a] -- ^ Actions to chain.
      -> HakyllAction a a   -- ^ Resulting action.
chain []   = id
chain list = foldl1 (>>>) list

instance Category HakyllAction where
    id = HakyllAction
        { actionDependencies = []
        , actionUrl          = Right id
        , actionFunction     = return
        }

    x . y = HakyllAction
        { actionDependencies = actionDependencies x ++ actionDependencies y
        , actionUrl          = case actionUrl x of
            Left ux  -> Left ux
            Right fx -> case actionUrl y of
                Left uy  -> Left (fx uy)
                Right fy -> Right (fx . fy)
        , actionFunction     = actionFunction x <=< actionFunction y
        }

instance Arrow HakyllAction where
    arr f = id { actionFunction = return . f }

    first x = x
        { actionFunction = \(y, z) -> do y' <- actionFunction x y
                                         return (y', z)
        }