git.iko.soy/hakyll
on master help sign in
Alternative instance for Compiler
2834fd9Jasper Van der Jeugt
src/Hakyll/Core/Compiler/Internal.hs+72−31
compare with master
unifiedsplit
@@ -1,5 +1,5 @@
1+--------------------------------------------------------------------------------
1-- | Internally used compiler module
2-- | Internally used compiler module
2−--
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4module Hakyll.Core.Compiler.Internal
4module Hakyll.Core.Compiler.Internal
5 ( Dependencies
5 ( Dependencies
@@ -15,28 +15,38 @@ module Hakyll.Core.Compiler.Internal
15 , fromDependency
15 , fromDependency
16 ) where
16 ) where
17
17
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
33
18
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+--------------------------------------------------------------------------------
34-- | A set of dependencies
44-- | A set of dependencies
35−--
36type Dependencies = Set (Identifier ())
45type Dependencies = Set (Identifier ())
37
46
47+
48+--------------------------------------------------------------------------------
38-- | Environment in which the dependency analyzer runs
49-- | Environment in which the dependency analyzer runs
39−--
40data DependencyEnvironment = DependencyEnvironment
50data DependencyEnvironment = DependencyEnvironment
41 { -- | Target identifier
51 { -- | Target identifier
42 dependencyIdentifier :: Identifier ()
52 dependencyIdentifier :: Identifier ()
@@ -44,8 +54,9 @@ data DependencyEnvironment = DependencyEnvironment
44 dependencyUniverse :: [Identifier ()]
54 dependencyUniverse :: [Identifier ()]
45 }
55 }
46
56
57+
58+--------------------------------------------------------------------------------
47-- | Environment in which a compiler runs
59-- | Environment in which a compiler runs
48−--
49data CompilerEnvironment = CompilerEnvironment
60data CompilerEnvironment = CompilerEnvironment
50 { -- | Target identifier
61 { -- | Target identifier
51 compilerIdentifier :: Identifier ()
62 compilerIdentifier :: Identifier ()
@@ -63,49 +74,72 @@ data CompilerEnvironment = CompilerEnvironment
63 compilerLogger :: Logger
74 compilerLogger :: Logger
64 }
75 }
65
76
77+
78+--------------------------------------------------------------------------------
66-- | A calculation possibly throwing an error
79-- | A calculation possibly throwing an error
67−--
68type Throwing a = Either String a
80type Throwing a = Either String a
69
81
82+
83+--------------------------------------------------------------------------------
70-- | The compiler monad
84-- | The compiler monad
71−--
72newtype CompilerM a = CompilerM
85newtype CompilerM a = CompilerM
73 { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
86 { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
74 } deriving (Monad, Functor, Applicative)
87 } deriving (Monad, Functor, Applicative)
75
88
89+
90+--------------------------------------------------------------------------------
76-- | The compiler arrow
91-- | The compiler arrow
77−--
78data Compiler a b = Compiler
92data Compiler a b = Compiler
79 { compilerDependencies :: Reader DependencyEnvironment Dependencies
93 { compilerDependencies :: Reader DependencyEnvironment Dependencies
80 , compilerJob :: a -> CompilerM b
94 , compilerJob :: a -> CompilerM b
81 }
95 }
82
96
97+
98+--------------------------------------------------------------------------------
83instance Functor (Compiler a) where
99instance Functor (Compiler a) where
84 fmap f ~(Compiler d j) = Compiler d $ fmap f . j
100 fmap f ~(Compiler d j) = Compiler d $ fmap f . j
85
101
102+
103+--------------------------------------------------------------------------------
86instance Applicative (Compiler a) where
104instance Applicative (Compiler a) where
87− pure = Compiler (return S.empty) . const . return
105+ pure = fromJob . const . return
88− ~(Compiler d1 f) <*> ~(Compiler d2 j) =
106+ ~(Compiler d1 j1) <*> ~(Compiler d2 j2) =
89− Compiler (liftM2 S.union d1 d2) $ \x -> f x <*> j x
107+ Compiler (liftM2 S.union d1 d2) $ \x -> j1 x <*> j2 x
90
108
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+--------------------------------------------------------------------------------
91instance Category Compiler where
120instance Category Compiler where
92 id = Compiler (return S.empty) return
121 id = Compiler (return S.empty) return
93 ~(Compiler d1 j1) . ~(Compiler d2 j2) =
122 ~(Compiler d1 j1) . ~(Compiler d2 j2) =
94 Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
123 Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
95
124
125+
126+--------------------------------------------------------------------------------
96instance Arrow Compiler where
127instance Arrow Compiler where
97− arr f = Compiler (return S.empty) (return . f)
128+ arr f = fromJob (return . f)
98 first ~(Compiler d j) = Compiler d $ \(x, y) -> do
129 first ~(Compiler d j) = Compiler d $ \(x, y) -> do
99 x' <- j x
130 x' <- j x
100 return (x', y)
131 return (x', y)
101
132
133+
134+--------------------------------------------------------------------------------
102instance ArrowChoice Compiler where
135instance ArrowChoice Compiler where
103 left ~(Compiler d j) = Compiler d $ \e -> case e of
136 left ~(Compiler d j) = Compiler d $ \e -> case e of
104 Left l -> Left <$> j l
137 Left l -> Left <$> j l
105 Right r -> Right <$> return r
138 Right r -> Right <$> return r
106
139
140+
141+--------------------------------------------------------------------------------
107-- | Run a compiler, yielding the resulting target
142-- | Run a compiler, yielding the resulting target
108−--
109runCompilerJob :: Compiler () a -- ^ Compiler to run
143runCompilerJob :: Compiler () a -- ^ Compiler to run
110 -> Identifier () -- ^ Target identifier
144 -> Identifier () -- ^ Target identifier
111 -> ResourceProvider -- ^ Resource provider
145 -> ResourceProvider -- ^ Resource provider
@@ -128,6 +162,8 @@ runCompilerJob compiler id' provider universe route store modified logger =
128 , compilerLogger = logger
162 , compilerLogger = logger
129 }
163 }
130
164
165+
166+--------------------------------------------------------------------------------
131runCompilerDependencies :: Compiler () a
167runCompilerDependencies :: Compiler () a
132 -> Identifier ()
168 -> Identifier ()
133 -> [Identifier ()]
169 -> [Identifier ()]
@@ -140,17 +176,22 @@ runCompilerDependencies compiler identifier universe =
140 , dependencyUniverse = universe
176 , dependencyUniverse = universe
141 }
177 }
142
178
143−fromJob :: (a -> CompilerM b)
144− -> Compiler a b
145−fromJob = Compiler (return S.empty)
146
179
180+--------------------------------------------------------------------------------
181+fromJob :: (a -> CompilerM b) -> Compiler a b
182+fromJob = Compiler $ return S.empty
183+{-# INLINE fromJob #-}
184+
185+
186+--------------------------------------------------------------------------------
147fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])
187fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])
148 -> Compiler b b
188 -> Compiler b b
149fromDependencies collectDeps = flip Compiler return $ do
189fromDependencies collectDeps = flip Compiler return $ do
150 DependencyEnvironment identifier universe <- ask
190 DependencyEnvironment identifier universe <- ask
151 return $ S.fromList $ collectDeps identifier universe
191 return $ S.fromList $ collectDeps identifier universe
152
192
193+
194+--------------------------------------------------------------------------------
153-- | Wait until another compiler has finished before running this compiler
195-- | Wait until another compiler has finished before running this compiler
154−--
155fromDependency :: Identifier a -> Compiler b b
196fromDependency :: Identifier a -> Compiler b b
156fromDependency = fromDependencies . const . const . return . castIdentifier
197fromDependency = fromDependencies . const . const . return . castIdentifier