@@ -1,5 +1,5 @@
1+--------------------------------------------------------------------------------
12-- | Internally used compiler module
2−--
33{-# LANGUAGE GeneralizedNewtypeDeriving #-}
44module Hakyll.Core.Compiler.Internal
55 ( Dependencies
@@ -15,28 +15,38 @@ module Hakyll.Core.Compiler.Internal
1515 , fromDependency
1616 ) where
1717
18−import Prelude hiding ((.), id)
19−import Control.Applicative (Applicative, pure, (<*>), (<$>))
20−import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader)
21−import Control.Monad.Error (ErrorT, runErrorT)
22−import Control.Monad ((<=<), liftM2)
23−import Data.Set (Set)
24−import qualified Data.Set as S
25−import Control.Category (Category, (.), id)
26−import Control.Arrow (Arrow, ArrowChoice, arr, first, left)
27−
28−import Hakyll.Core.Identifier
29−import Hakyll.Core.ResourceProvider
30−import Hakyll.Core.Store
31−import Hakyll.Core.Routes
32−import Hakyll.Core.Logger
3318
19+--------------------------------------------------------------------------------
20+import Control.Applicative (Alternative (..), Applicative,
21+ pure, (<$>), (<*>))
22+import Control.Arrow (Arrow, ArrowChoice, arr, first,
23+ left)
24+import Control.Category (Category, id, (.))
25+import Control.Monad (liftM2, (<=<))
26+import Control.Monad.Error (ErrorT, catchError, runErrorT,
27+ throwError)
28+import Control.Monad.Reader (Reader, ReaderT, ask, runReader,
29+ runReaderT)
30+import Data.Set (Set)
31+import qualified Data.Set as S
32+import Prelude hiding (id, (.))
33+
34+
35+--------------------------------------------------------------------------------
36+import Hakyll.Core.Identifier
37+import Hakyll.Core.Logger
38+import Hakyll.Core.ResourceProvider
39+import Hakyll.Core.Routes
40+import Hakyll.Core.Store
41+
42+
43+--------------------------------------------------------------------------------
3444-- | A set of dependencies
35−--
3645type Dependencies = Set (Identifier ())
3746
47+
48+--------------------------------------------------------------------------------
3849-- | Environment in which the dependency analyzer runs
39−--
4050data DependencyEnvironment = DependencyEnvironment
4151 { -- | Target identifier
4252 dependencyIdentifier :: Identifier ()
@@ -44,8 +54,9 @@ data DependencyEnvironment = DependencyEnvironment
4454 dependencyUniverse :: [Identifier ()]
4555 }
4656
57+
58+--------------------------------------------------------------------------------
4759-- | Environment in which a compiler runs
48−--
4960data CompilerEnvironment = CompilerEnvironment
5061 { -- | Target identifier
5162 compilerIdentifier :: Identifier ()
@@ -63,49 +74,72 @@ data CompilerEnvironment = CompilerEnvironment
6374 compilerLogger :: Logger
6475 }
6576
77+
78+--------------------------------------------------------------------------------
6679-- | A calculation possibly throwing an error
67−--
6880type Throwing a = Either String a
6981
82+
83+--------------------------------------------------------------------------------
7084-- | The compiler monad
71−--
7285newtype CompilerM a = CompilerM
7386 { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
7487 } deriving (Monad, Functor, Applicative)
7588
89+
90+--------------------------------------------------------------------------------
7691-- | The compiler arrow
77−--
7892data Compiler a b = Compiler
7993 { compilerDependencies :: Reader DependencyEnvironment Dependencies
8094 , compilerJob :: a -> CompilerM b
8195 }
8296
97+
98+--------------------------------------------------------------------------------
8399instance Functor (Compiler a) where
84100 fmap f ~(Compiler d j) = Compiler d $ fmap f . j
85101
102+
103+--------------------------------------------------------------------------------
86104instance Applicative (Compiler a) where
87− pure = Compiler (return S.empty) . const . return
88− ~(Compiler d1 f) <*> ~(Compiler d2 j) =
89− Compiler (liftM2 S.union d1 d2) $ \x -> f x <*> j x
105+ pure = fromJob . const . return
106+ ~(Compiler d1 j1) <*> ~(Compiler d2 j2) =
107+ Compiler (liftM2 S.union d1 d2) $ \x -> j1 x <*> j2 x
90108
109+
110+--------------------------------------------------------------------------------
111+instance Alternative (Compiler a) where
112+ empty = fromJob $ const $ CompilerM $
113+ throwError "Hakyll.Core.Compiler.Internal: empty alternative"
114+ ~(Compiler d1 j1) <|> ~(Compiler d2 j2) =
115+ Compiler (liftM2 S.union d1 d2) $ \x -> CompilerM $
116+ catchError (unCompilerM $ j1 x) (\_ -> unCompilerM $ j2 x)
117+
118+
119+--------------------------------------------------------------------------------
91120instance Category Compiler where
92121 id = Compiler (return S.empty) return
93122 ~(Compiler d1 j1) . ~(Compiler d2 j2) =
94123 Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
95124
125+
126+--------------------------------------------------------------------------------
96127instance Arrow Compiler where
97− arr f = Compiler (return S.empty) (return . f)
128+ arr f = fromJob (return . f)
98129 first ~(Compiler d j) = Compiler d $ \(x, y) -> do
99130 x' <- j x
100131 return (x', y)
101132
133+
134+--------------------------------------------------------------------------------
102135instance ArrowChoice Compiler where
103136 left ~(Compiler d j) = Compiler d $ \e -> case e of
104137 Left l -> Left <$> j l
105138 Right r -> Right <$> return r
106139
140+
141+--------------------------------------------------------------------------------
107142-- | Run a compiler, yielding the resulting target
108−--
109143runCompilerJob :: Compiler () a -- ^ Compiler to run
110144 -> Identifier () -- ^ Target identifier
111145 -> ResourceProvider -- ^ Resource provider
@@ -128,6 +162,8 @@ runCompilerJob compiler id' provider universe route store modified logger =
128162 , compilerLogger = logger
129163 }
130164
165+
166+--------------------------------------------------------------------------------
131167runCompilerDependencies :: Compiler () a
132168 -> Identifier ()
133169 -> [Identifier ()]
@@ -140,17 +176,22 @@ runCompilerDependencies compiler identifier universe =
140176 , dependencyUniverse = universe
141177 }
142178
143−fromJob :: (a -> CompilerM b)
144− -> Compiler a b
145−fromJob = Compiler (return S.empty)
146179
180+--------------------------------------------------------------------------------
181+fromJob :: (a -> CompilerM b) -> Compiler a b
182+fromJob = Compiler $ return S.empty
183+{-# INLINE fromJob #-}
184+
185+
186+--------------------------------------------------------------------------------
147187fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])
148188 -> Compiler b b
149189fromDependencies collectDeps = flip Compiler return $ do
150190 DependencyEnvironment identifier universe <- ask
151191 return $ S.fromList $ collectDeps identifier universe
152192
193+
194+--------------------------------------------------------------------------------
153195-- | Wait until another compiler has finished before running this compiler
154−--
155196fromDependency :: Identifier a -> Compiler b b
156197fromDependency = fromDependencies . const . const . return . castIdentifier