summaryrefslogtreecommitdiff
path: root/src/Hakyll/Core/Compiler/Internal.hs
blob: 8ed822dc17afa77ecd42e67d2a44cf4229033281 (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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
-- | Internally used compiler module
--
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hakyll.Core.Compiler.Internal
    ( Dependencies
    , DependencyEnvironment (..)
    , CompilerEnvironment (..)
    , Throwing
    , CompilerM (..)
    , Compiler (..)
    , runCompilerJob
    , runCompilerDependencies
    , fromJob
    , fromDependencies
    , fromDependency
    ) where

import Prelude hiding ((.), id)
import Control.Applicative (Applicative, pure, (<*>), (<$>))
import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader)
import Control.Monad.Error (ErrorT, runErrorT)
import Control.Monad ((<=<), liftM2)
import Data.Set (Set)
import qualified Data.Set as S
import Control.Category (Category, (.), id)
import Control.Arrow (Arrow, ArrowChoice, arr, first, left)

import Hakyll.Core.Identifier
import Hakyll.Core.Resource.Provider
import Hakyll.Core.Store
import Hakyll.Core.Routes
import Hakyll.Core.Logger

-- | A set of dependencies
--
type Dependencies = Set (Identifier ())

-- | Environment in which the dependency analyzer runs
--
data DependencyEnvironment = DependencyEnvironment
    { -- | Target identifier
      dependencyIdentifier :: Identifier ()
    , -- | List of available identifiers we can depend upon
      dependencyUniverse   :: [Identifier ()]
    }

-- | Environment in which a compiler runs
--
data CompilerEnvironment = CompilerEnvironment
    { -- | Target identifier
      compilerIdentifier       :: Identifier ()
    , -- | Resource provider
      compilerResourceProvider :: ResourceProvider
    , -- | List of all known identifiers
      compilerUniverse         :: [Identifier ()]
    , -- | Site routes
      compilerRoutes           :: Routes
    , -- | Compiler store
      compilerStore            :: Store
    , -- | Flag indicating if the underlying resource was modified
      compilerResourceModified :: Bool
    , -- | Logger
      compilerLogger           :: Logger
    }

-- | A calculation possibly throwing an error
--
type Throwing a = Either String a

-- | The compiler monad
--
newtype CompilerM a = CompilerM
    { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
    } deriving (Monad, Functor, Applicative)

-- | The compiler arrow
--
data Compiler a b = Compiler
    { compilerDependencies :: Reader DependencyEnvironment Dependencies
    , compilerJob          :: a -> CompilerM b
    }

instance Functor (Compiler a) where
    fmap f ~(Compiler d j) = Compiler d $ fmap f . j

instance Applicative (Compiler a) where
    pure = Compiler (return S.empty) . const . return
    ~(Compiler d1 f) <*> ~(Compiler d2 j) =
        Compiler (liftM2 S.union d1 d2) $ \x -> f x <*> j x

instance Category Compiler where
    id = Compiler (return S.empty) return
    ~(Compiler d1 j1) . ~(Compiler d2 j2) =
        Compiler (liftM2 S.union d1 d2) (j1 <=< j2)

instance Arrow Compiler where
    arr f = Compiler (return S.empty) (return . f)
    first ~(Compiler d j) = Compiler d $ \(x, y) -> do
        x' <- j x
        return (x', y)

instance ArrowChoice Compiler where
    left ~(Compiler d j) = Compiler d $ \e -> case e of
        Left l  -> Left  <$> j l
        Right r -> Right <$> return r

-- | Run a compiler, yielding the resulting target
--
runCompilerJob :: Compiler () a     -- ^ Compiler to run
               -> Identifier ()     -- ^ Target identifier
               -> ResourceProvider  -- ^ Resource provider
               -> [Identifier ()]   -- ^ Universe
               -> Routes            -- ^ Route
               -> Store             -- ^ Store
               -> Bool              -- ^ Was the resource modified?
               -> Logger            -- ^ Logger
               -> IO (Throwing a)   -- ^ Result
runCompilerJob compiler id' provider universe route store modified logger =
    runReaderT (runErrorT $ unCompilerM $ compilerJob compiler ()) env
  where
    env = CompilerEnvironment
            { compilerIdentifier       = id'
            , compilerResourceProvider = provider
            , compilerUniverse         = universe
            , compilerRoutes           = route
            , compilerStore            = store
            , compilerResourceModified = modified
            , compilerLogger           = logger
            }

runCompilerDependencies :: Compiler () a
                        -> Identifier ()
                        -> [Identifier ()]
                        -> Dependencies
runCompilerDependencies compiler identifier universe =
    runReader (compilerDependencies compiler) env
  where
    env = DependencyEnvironment
            { dependencyIdentifier = identifier
            , dependencyUniverse   = universe
            }

fromJob :: (a -> CompilerM b)
        -> Compiler a b
fromJob = Compiler (return S.empty)

fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])
                 -> Compiler b b
fromDependencies collectDeps = flip Compiler return $ do
    DependencyEnvironment identifier universe <- ask
    return $ S.fromList $ collectDeps identifier universe

-- | Wait until another compiler has finished before running this compiler
--
fromDependency :: Identifier a -> Compiler b b
fromDependency = fromDependencies . const . const . return . castIdentifier