@@ -1,63 +1,35 @@
11--------------------------------------------------------------------------------
22-- | Internally used compiler module
3+{-# LANGUAGE GADTs #-}
34{-# LANGUAGE GeneralizedNewtypeDeriving #-}
45module Hakyll.Core.Compiler.Internal
5− ( Dependencies
6− , DependencyEnvironment (..)
7− , CompilerEnvironment (..)
8− , Throwing
9− , CompilerM (..)
6+ ( CompilerRead (..)
107 , Compiler (..)
11− , runCompilerJob
12− , runCompilerDependencies
13− , fromJob
14− , fromDependencies
15− , fromDependency
8+ , compilerTell
9+ , compilerAsk
10+ , compilerThrow
11+ , compilerCatch
1612 ) where
1713
1814
1915--------------------------------------------------------------------------------
20−import Control.Applicative (Alternative (..), Applicative,
21− pure, (<$>), (<*>))
22−import Control.Arrow
23−import Control.Category (Category, id, (.))
24−import Control.Monad (liftM2, (<=<))
25−import Control.Monad.Error (ErrorT, catchError, runErrorT,
26− throwError)
27−import Control.Monad.Reader (Reader, ReaderT, ask, runReader,
28− runReaderT)
29−import Data.Set (Set)
30−import qualified Data.Set as S
31−import Prelude hiding (id, (.))
16+import Control.Applicative (Alternative (..),
17+ Applicative (..))
18+import Data.Monoid (mappend, mempty)
3219
3320
3421--------------------------------------------------------------------------------
22+import Hakyll.Core.Dependencies
3523import Hakyll.Core.Identifier
3624import Hakyll.Core.Logger
3725import Hakyll.Core.ResourceProvider
3826import Hakyll.Core.Routes
3927import Hakyll.Core.Store
40−import Hakyll.Core.Util.Arrow
41−
42−
43−--------------------------------------------------------------------------------
44−-- | A set of dependencies
45−type Dependencies = Set (Identifier ())
46−
47−
48−--------------------------------------------------------------------------------
49−-- | Environment in which the dependency analyzer runs
50−data DependencyEnvironment = DependencyEnvironment
51− { -- | Target identifier
52− dependencyIdentifier :: Identifier ()
53− , -- | List of available identifiers we can depend upon
54− dependencyUniverse :: [Identifier ()]
55− }
5628
5729
5830--------------------------------------------------------------------------------
5931-- | Environment in which a compiler runs
60−data CompilerEnvironment = CompilerEnvironment
32+data CompilerRead = CompilerRead
6133 { -- | Target identifier
6234 compilerIdentifier :: Identifier ()
6335 , -- | Resource provider
@@ -76,164 +48,127 @@ data CompilerEnvironment = CompilerEnvironment
7648
7749
7850--------------------------------------------------------------------------------
79−-- | A calculation possibly throwing an error
80−type Throwing a = Either String a
51+type CompilerWrite = [Dependency]
8152
8253
8354--------------------------------------------------------------------------------
84−-- | The compiler monad
85−newtype CompilerM a = CompilerM
86− { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
87− } deriving (Monad, Functor, Applicative)
55+data CompilerResult a where
56+ CompilerDone :: a -> CompilerWrite -> CompilerResult a
57+ CompilerError :: String -> CompilerResult a
58+ CompilerRequire :: Identifier b -> (b -> Compiler a) -> CompilerResult a
8859
8960
9061--------------------------------------------------------------------------------
91−-- | The compiler arrow
92−data Compiler a b = Compiler
93− { compilerDependencies :: Reader DependencyEnvironment Dependencies
94− , compilerJob :: a -> CompilerM b
62+newtype Compiler a = Compiler
63+ { unCompiler :: CompilerRead -> IO (CompilerResult a)
9564 }
9665
9766
9867--------------------------------------------------------------------------------
99−instance Functor (Compiler a) where
100− fmap f (Compiler d j) = Compiler d $ fmap f . j
68+instance Functor Compiler where
69+ fmap f (Compiler c) = Compiler $ \r -> do
70+ res <- c r
71+ return $ case res of
72+ CompilerDone x w -> CompilerDone (f x) w
73+ CompilerError e -> CompilerError e
74+ CompilerRequire i g -> CompilerRequire i (\x -> fmap f (g x))
10175 {-# INLINE fmap #-}
10276
10377
10478--------------------------------------------------------------------------------
105−instance Applicative (Compiler a) where
106− pure = fromJob . const . return
107− {-# INLINE pure #-}
79+instance Monad Compiler where
80+ return x = Compiler $ \_ -> return $ CompilerDone x mempty
81+ {-# INLINE return #-}
10882
109− Compiler d1 j1 <*> Compiler d2 j2 =
110− Compiler (liftM2 S.union d1 d2) $ \x -> j1 x <*> j2 x
111− {-# INLINE (<*>) #-}
112−
113−
114−--------------------------------------------------------------------------------
115−instance Alternative (Compiler a) where
116− empty = fromJob $ const $ CompilerM $
117− throwError "Hakyll.Core.Compiler.Internal: empty alternative"
83+ Compiler c >>= f = Compiler $ \r -> do
84+ res <- c r
85+ case res of
86+ CompilerDone x w -> do
87+ res' <- unCompiler (f x) r
88+ return $ case res' of
89+ CompilerDone y w' -> CompilerDone y (w `mappend` w')
90+ CompilerError e -> CompilerError e
91+ CompilerRequire i g -> CompilerRequire i $ \z -> do
92+ compilerTell w -- Save dependencies!
93+ g z
11894
119− Compiler d1 j1 <|> Compiler d2 j2 =
120− Compiler (liftM2 S.union d1 d2) $ \x -> CompilerM $
121− catchError (unCompilerM $ j1 x) (\_ -> unCompilerM $ j2 x)
122− {-# INLINE (<|>) #-}
95+ CompilerError e -> return $ CompilerError e
96+ CompilerRequire i g -> return $ CompilerRequire i $ \z -> g z >>= f
97+ {-# INLINE (>>=) #-}
12398
12499
125100--------------------------------------------------------------------------------
126−instance Category Compiler where
127− id = Compiler (return S.empty) return
128− {-# INLINE id #-}
101+instance Applicative Compiler where
102+ pure x = return x
103+ {-# INLINE pure #-}
129104
130− Compiler d1 j1 . Compiler d2 j2 =
131− Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
132− {-# INLINE (.) #-}
105+ f <*> x = f >>= \f' -> fmap f' x
106+ {-# INLINE (<*>) #-}
133107
134108
135109--------------------------------------------------------------------------------
136−instance Arrow Compiler where
137− arr f = fromJob (return . f)
138− {-# INLINE arr #-}
139−
140− first (Compiler d j) = Compiler d $ \(x, y) -> do
141− x' <- j x
142− return (x', y)
143− {-# INLINE first #-}
144−
145− second (Compiler d j) = Compiler d $ \(x, y) -> do
146− y' <- j y
147− return (x, y')
148− {-# INLINE second #-}
110+instance Alternative Compiler where
111+ empty = compilerThrow "Hakyll.Core.Compiler.Internal: empty alternative"
112+ x <|> y = compilerCatch x (\_ -> y)
113+ {-# INLINE (<|>) #-}
149114
150− Compiler d1 j1 *** Compiler d2 j2 =
151− Compiler (liftM2 S.union d1 d2) $ \(x, y) -> do
152− x' <- j1 x
153− y' <- j2 y
154− return (x', y')
155− {-# INLINE (***) #-}
156115
157− Compiler d1 j1 &&& Compiler d2 j2 =
158− Compiler (liftM2 S.union d1 d2) $ \x -> do
159− y1 <- j1 x
160− y2 <- j2 x
161− return (y1, y2)
162− {-# INLINE (&&&) #-}
116+--------------------------------------------------------------------------------
117+compilerAsk :: Compiler CompilerRead
118+compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
119+{-# INLINE compilerAsk #-}
163120
164121
165122--------------------------------------------------------------------------------
166−instance ArrowChoice Compiler where
167− left (Compiler d j) = Compiler d $ \e -> case e of
168− Left l -> Left <$> j l
169− Right r -> Right <$> return r
170− {-# INLINE left #-}
171−
172− Compiler d1 j1 ||| Compiler d2 j2 = Compiler (liftM2 S.union d1 d2) $
173− \e -> case e of Left x -> j1 x; Right y -> j2 y
174− {-# INLINE (|||) #-}
123+compilerTell :: [Dependency] -> Compiler ()
124+compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
125+{-# INLINE compilerTell #-}
175126
176127
177128--------------------------------------------------------------------------------
178−instance ArrowMap Compiler where
179− mapA (Compiler d j) = Compiler d $ mapM j
180− {-# INLINE mapA #-}
129+compilerThrow :: String -> Compiler a
130+compilerThrow e = Compiler $ \_ -> return $ CompilerError e
131+{-# INLINE compilerThrow #-}
181132
182133
183134--------------------------------------------------------------------------------
184−-- | Run a compiler, yielding the resulting target
185−runCompilerJob :: Compiler () a -- ^ Compiler to run
186− -> Identifier () -- ^ Target identifier
187− -> ResourceProvider -- ^ Resource provider
188− -> [Identifier ()] -- ^ Universe
189− -> Routes -- ^ Route
190− -> Store -- ^ Store
191− -> Bool -- ^ Was the resource modified?
192− -> Logger -- ^ Logger
193− -> IO (Throwing a) -- ^ Result
194−runCompilerJob compiler id' provider universe route store modified logger =
195− runReaderT (runErrorT $ unCompilerM $ compilerJob compiler ()) env
196− where
197− env = CompilerEnvironment
198− { compilerIdentifier = id'
199− , compilerResourceProvider = provider
200− , compilerUniverse = universe
201− , compilerRoutes = route
202− , compilerStore = store
203− , compilerResourceModified = modified
204− , compilerLogger = logger
205− }
135+compilerCatch :: Compiler a -> (String -> Compiler a) -> Compiler a
136+compilerCatch (Compiler x) f = Compiler $ \r -> do
137+ res <- x r
138+ case res of
139+ CompilerError e -> unCompiler (f e) r
140+ _ -> return res
141+{-# INLINE compilerCatch #-}
206142
207143
144+{-
208145--------------------------------------------------------------------------------
209−runCompilerDependencies :: Compiler () a
210− -> Identifier ()
211− -> [Identifier ()]
212− -> Dependencies
213−runCompilerDependencies compiler identifier universe =
214− runReader (compilerDependencies compiler) env
215− where
216− env = DependencyEnvironment
217− { dependencyIdentifier = identifier
218− , dependencyUniverse = universe
219− }
146+-- | The compiler monad
147+newtype CompilerM a = CompilerM
148+ { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
149+ } deriving (Monad, Functor, Applicative)
220150
221151
222152--------------------------------------------------------------------------------
223−fromJob :: (a -> CompilerM b) -> Compiler a b
224−fromJob = Compiler $ return S.empty
225−{-# INLINE fromJob #-}
153+-- | The compiler arrow
154+data Compiler a = Compiler
155+ { compilerDependencies :: Reader DependencyEnvironment Dependencies
156+ , compilerJob :: CompilerM a
157+ }
226158
227159
228160--------------------------------------------------------------------------------
229−fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])
230− -> Compiler b b
231−fromDependencies collectDeps = flip Compiler return $ do
232− DependencyEnvironment identifier universe <- ask
233− return $ S.fromList $ collectDeps identifier universe
161+instance Functor Compiler where
162+ fmap f (Compiler d j) = Compiler d $ fmap f j
163+ {-# INLINE fmap #-}
234164
235165
236166--------------------------------------------------------------------------------
237−-- | Wait until another compiler has finished before running this compiler
238−fromDependency :: Identifier a -> Compiler b b
239−fromDependency = fromDependencies . const . const . return . castIdentifier
167+instance Applicative Compiler where
168+ pure = fromJob . return
169+ {-# INLINE pure #-}
170+
171+ Compiler d1 j1 <*> Compiler d2 j2 =
172+ Compiler (liftM2 S.union d1 d2) $ j1 <*> j2
173+ {-# INLINE (<*>) #-}
174+-}