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
100
101
102
103
104
105
106
107
108
109
|
-- | This is the module which exports @RenderAction@.
module Text.Hakyll.RenderAction
( RenderAction (..)
, createRenderAction
, createSimpleRenderAction
, createFileRenderAction
, createManipulationAction
, chain
, runRenderAction
, runRenderActionIfNeeded
, Renderable
) where
import Control.Arrow
import Control.Category
import Control.Monad ((<=<), mplus, unless)
import Control.Monad.Reader (liftIO)
import Prelude hiding ((.), id)
import System.IO (hPutStrLn, stderr)
import Text.Hakyll.Context
import Text.Hakyll.File (toDestination, isFileMoreRecent)
import Text.Hakyll.Hakyll
-- | Type used for rendering computations that carry along dependencies.
data RenderAction a b = RenderAction
{ -- | Dependencies of the @RenderAction@.
actionDependencies :: [FilePath]
, -- | URL pointing to the result of this @RenderAction@.
actionUrl :: Maybe (Hakyll FilePath)
, -- | The actual render function.
actionFunction :: a -> Hakyll b
}
-- | Create a @RenderAction@ from a function.
createRenderAction :: (a -> Hakyll b) -- ^ Function to execute.
-> RenderAction a b
createRenderAction f = id { actionFunction = f }
-- | Create a @RenderAction@ from a simple @Hakyll@ value.
createSimpleRenderAction :: Hakyll b -- ^ Hakyll value to pass on.
-> RenderAction () b
createSimpleRenderAction = createRenderAction . const
-- | Create a @RenderAction@ that operates on one file.
createFileRenderAction :: FilePath -- ^ File to operate on.
-> Hakyll b -- ^ Value to pass on.
-> RenderAction () b -- ^ The resulting action.
createFileRenderAction path action = RenderAction
{ actionDependencies = [path]
, actionUrl = Just $ return path
, actionFunction = const action
}
-- | Create a @RenderAction@ from a @ContextManipulation@.
createManipulationAction :: ContextManipulation -- ^ Manipulation to apply.
-> RenderAction Context Context
createManipulationAction = createRenderAction . (return .)
-- | Run a @RenderAction@ now.
runRenderAction :: RenderAction () a -- ^ Render action to run.
-> Hakyll a -- ^ Result of the action.
runRenderAction action = actionFunction action ()
-- | Run a @RenderAction@, but only when it is out-of-date. At this point, the
-- @actionUrl@ field must be set.
runRenderActionIfNeeded :: RenderAction () () -- ^ Action to run.
-> Hakyll () -- ^ Empty result.
runRenderActionIfNeeded action = do
url <- case actionUrl action of
(Just u) -> u
Nothing -> error "No url when checking dependencies."
destination <- toDestination url
valid <- isFileMoreRecent destination $ actionDependencies action
unless valid $ do liftIO $ hPutStrLn stderr $ "Rendering " ++ destination
runRenderAction action
-- | Chain a number of @RenderAction@ computations.
chain :: [RenderAction a a] -- ^ Actions to chain.
-> RenderAction a a -- ^ Resulting action.
chain [] = id
chain list@(_:_) = foldl1 (>>>) list
-- | This is a specialized version of @RenderAction@, a @Context@ that can be
-- rendered.
type Renderable = RenderAction () Context
instance Category RenderAction where
id = RenderAction
{ actionDependencies = []
, actionUrl = Nothing
, actionFunction = return
}
x . y = RenderAction
{ actionDependencies = actionDependencies x ++ actionDependencies y
, actionUrl = actionUrl y `mplus` actionUrl x
, actionFunction = actionFunction x <=< actionFunction y
}
instance Arrow RenderAction where
arr f = id { actionFunction = return . f }
first x = RenderAction
{ actionDependencies = actionDependencies x
, actionUrl = actionUrl x
, actionFunction = \(y, z) -> do y' <- actionFunction x y
return (y', z)
}
|
