@@ -1,7 +1,6 @@
11--------------------------------------------------------------------------------
22-- | Internally used compiler module
33{-# LANGUAGE CPP #-}
4−{-# LANGUAGE DeriveFunctor #-}
54{-# LANGUAGE FlexibleInstances #-}
65{-# LANGUAGE GADTs #-}
76{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -11,26 +10,19 @@ module Hakyll.Core.Compiler.Internal
1110 Snapshot
1211 , CompilerRead (..)
1312 , CompilerWrite (..)
14− , CompilerErrors (..)
1513 , CompilerResult (..)
1614 , Compiler (..)
1715 , runCompiler
1816
1917 -- * Core operations
20− , compilerResult
2118 , compilerTell
2219 , compilerAsk
23− , compilerUnsafeIO
24−
25− -- * Error operations
2620 , compilerThrow
27− , compilerNoResult
2821 , compilerCatch
29− , compilerTry
30− , compilerErrorMessages
22+ , compilerResult
23+ , compilerUnsafeIO
3124
3225 -- * Utilities
33− , compilerDebugEntries
3426 , compilerTellDependencies
3527 , compilerTellCacheHits
3628 ) where
@@ -40,9 +32,7 @@ module Hakyll.Core.Compiler.Internal
4032import Control.Applicative (Alternative (..))
4133import Control.Exception (SomeException, handle)
4234import Control.Monad (forM_)
43−import Control.Monad.Except (MonadError (..))
44−import Data.List.NonEmpty (NonEmpty (..))
45−import qualified Data.List.NonEmpty as NonEmpty
35+import Control.Monad.Except (MonadError (..))
4636#if MIN_VERSION_base(4,9,0)
4737import Data.Semigroup (Semigroup (..))
4838#endif
@@ -55,6 +45,7 @@ import Hakyll.Core.Configuration
5545import Hakyll.Core.Dependencies
5646import Hakyll.Core.Identifier
5747import Hakyll.Core.Identifier.Pattern
48+import Hakyll.Core.Logger (Logger)
5849import qualified Hakyll.Core.Logger as Logger
5950import Hakyll.Core.Metadata
6051import Hakyll.Core.Provider
@@ -84,7 +75,7 @@ data CompilerRead = CompilerRead
8475 , -- | Compiler store
8576 compilerStore :: Store
8677 , -- | Logger
87− compilerLogger :: Logger.Logger
78+ compilerLogger :: Logger
8879 }
8980
9081
@@ -113,29 +104,11 @@ instance Monoid CompilerWrite where
113104
114105
115106--------------------------------------------------------------------------------
116−-- | Distinguishes reasons in a 'CompilerError'
117−data CompilerErrors a
118− -- | One or more exceptions occured during compilation
119− = CompilationFailure (NonEmpty a)
120− -- | Absence of any result, most notably in template contexts. May still
121− -- have error messages.
122− | CompilationNoResult [a]
123− deriving Functor
124−
125−
126−-- | Unwrap a `CompilerErrors`
127−compilerErrorMessages :: CompilerErrors a -> [a]
128−compilerErrorMessages (CompilationFailure x) = NonEmpty.toList x
129−compilerErrorMessages (CompilationNoResult x) = x
130−
131−
132−--------------------------------------------------------------------------------
133−-- | An intermediate result of a compilation step
134−data CompilerResult a
135− = CompilerDone a CompilerWrite
136− | CompilerSnapshot Snapshot (Compiler a)
137− | CompilerRequire (Identifier, Snapshot) (Compiler a)
138− | CompilerError (CompilerErrors String)
107+data CompilerResult a where
108+ CompilerDone :: a -> CompilerWrite -> CompilerResult a
109+ CompilerSnapshot :: Snapshot -> Compiler a -> CompilerResult a
110+ CompilerError :: [String] -> CompilerResult a
111+ CompilerRequire :: (Identifier, Snapshot) -> Compiler a -> CompilerResult a
139112
140113
141114--------------------------------------------------------------------------------
@@ -153,14 +126,14 @@ instance Functor Compiler where
153126 return $ case res of
154127 CompilerDone x w -> CompilerDone (f x) w
155128 CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')
156− CompilerRequire i c' -> CompilerRequire i (fmap f c')
157129 CompilerError e -> CompilerError e
130+ CompilerRequire i c' -> CompilerRequire i (fmap f c')
158131 {-# INLINE fmap #-}
159132
160133
161134--------------------------------------------------------------------------------
162135instance Monad Compiler where
163− return x = compilerResult $ CompilerDone x mempty
136+ return x = Compiler $ \_ -> return $ CompilerDone x mempty
164137 {-# INLINE return #-}
165138
166139 Compiler c >>= f = Compiler $ \r -> do
@@ -173,14 +146,14 @@ instance Monad Compiler where
173146 CompilerSnapshot s c' -> CompilerSnapshot s $ do
174147 compilerTell w -- Save dependencies!
175148 c'
149+ CompilerError e -> CompilerError e
176150 CompilerRequire i c' -> CompilerRequire i $ do
177151 compilerTell w -- Save dependencies!
178152 c'
179− CompilerError e -> CompilerError e
180153
181154 CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)
182− CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)
183155 CompilerError e -> return $ CompilerError e
156+ CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)
184157 {-# INLINE (>>=) #-}
185158
186159 fail = compilerThrow . return
@@ -197,145 +170,87 @@ instance Applicative Compiler where
197170
198171
199172--------------------------------------------------------------------------------
200−-- | Access provided metadata from anywhere
201173instance MonadMetadata Compiler where
202174 getMetadata = compilerGetMetadata
203175 getMatches = compilerGetMatches
204176
205177
206178--------------------------------------------------------------------------------
207−-- | Compilation may fail with multiple error messages.
208−-- 'catchError' handles errors from 'throwError', 'fail' and 'Hakyll.Core.Compiler.noResult'
209179instance MonadError [String] Compiler where
210− throwError = compilerThrow
211− catchError c = compilerCatch c . (. compilerErrorMessages)
180+ throwError = compilerThrow
181+ catchError = compilerCatch
212182
213183
214184--------------------------------------------------------------------------------
215−-- | Like 'unCompiler' but treating IO exceptions as 'CompilerError's
216185runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
217186runCompiler compiler read' = handle handler $ unCompiler compiler read'
218187 where
219188 handler :: SomeException -> IO (CompilerResult a)
220− handler e = return $ CompilerError $ CompilationFailure $ show e :| []
189+ handler e = return $ CompilerError [show e]
221190
222191
223192--------------------------------------------------------------------------------
224−-- | Trying alternative compilers if the first fails, regardless whether through
225−-- 'fail', 'throwError' or 'Hakyll.Core.Compiler.noResult'.
226−-- Aggregates error messages if all fail.
227193instance Alternative Compiler where
228− empty = compilerNoResult []
229− x <|> y = x `compilerCatch` (\rx -> y `compilerCatch` (\ry ->
230− case (rx, ry) of
231− (CompilationFailure xs, CompilationFailure ys) ->
232− compilerThrow $ NonEmpty.toList xs ++ NonEmpty.toList ys
233− (CompilationFailure xs, CompilationNoResult ys) ->
234− debug ys >> compilerThrow (NonEmpty.toList xs)
235− (CompilationNoResult xs, CompilationFailure ys) ->
236− debug xs >> compilerThrow (NonEmpty.toList ys)
237− (CompilationNoResult xs, CompilationNoResult ys) -> compilerNoResult $ xs ++ ys
238− ))
239− where
240− debug = compilerDebugEntries "Hakyll.Core.Compiler.Internal: Alternative fail suppressed"
194+ empty = compilerThrow []
195+ x <|> y = compilerCatch x $ \es -> do
196+ logger <- compilerLogger <$> compilerAsk
197+ forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $
198+ "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e
199+ y
241200 {-# INLINE (<|>) #-}
242201
243202
244203--------------------------------------------------------------------------------
245−-- | Put the result back in a compiler
246−compilerResult :: CompilerResult a -> Compiler a
247−compilerResult x = Compiler $ \_ -> return x
248−{-# INLINE compilerResult #-}
249−
250−
251−--------------------------------------------------------------------------------
252−-- | Get the current environment
253204compilerAsk :: Compiler CompilerRead
254205compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
255206{-# INLINE compilerAsk #-}
256207
257208
258209--------------------------------------------------------------------------------
259−-- | Put a 'CompilerWrite'
260210compilerTell :: CompilerWrite -> Compiler ()
261−compilerTell = compilerResult . CompilerDone ()
211+compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
262212{-# INLINE compilerTell #-}
263213
264214
265215--------------------------------------------------------------------------------
266−-- | Run an IO computation without dependencies in a Compiler
267−compilerUnsafeIO :: IO a -> Compiler a
268−compilerUnsafeIO io = Compiler $ \_ -> do
269− x <- io
270− return $ CompilerDone x mempty
271−{-# INLINE compilerUnsafeIO #-}
272−
273−
274−--------------------------------------------------------------------------------
275−-- | Throw errors in the 'Compiler'.
276−--
277−-- If no messages are given, this is considered a 'CompilationNoResult' error.
278−-- Otherwise, it is treated as a proper compilation failure.
279216compilerThrow :: [String] -> Compiler a
280−compilerThrow = compilerResult . CompilerError .
281− maybe (CompilationNoResult []) CompilationFailure .
282− NonEmpty.nonEmpty
283−
284−-- | Put a 'CompilerError' with multiple messages as 'CompilationNoResult'
285−compilerNoResult :: [String] -> Compiler a
286−compilerNoResult = compilerResult . CompilerError . CompilationNoResult
217+compilerThrow es = Compiler $ \_ -> return $ CompilerError es
218+{-# INLINE compilerThrow #-}
287219
288220
289221--------------------------------------------------------------------------------
290−-- | Allows to distinguish 'CompilerError's and branch on them with 'Either'
291−--
292−-- prop> compilerTry = (`compilerCatch` return . Left) . fmap Right
293−compilerTry :: Compiler a -> Compiler (Either (CompilerErrors String) a)
294−compilerTry (Compiler x) = Compiler $ \r -> do
295− res <- x r
296− case res of
297− CompilerDone res' w -> return (CompilerDone (Right res') w)
298− CompilerSnapshot s c -> return (CompilerSnapshot s (compilerTry c))
299− CompilerRequire i c -> return (CompilerRequire i (compilerTry c))
300− CompilerError e -> return (CompilerDone (Left e) mempty)
301−{-# INLINE compilerTry #-}
302−
303−
304−--------------------------------------------------------------------------------
305−-- | Allows you to recover from 'CompilerError's.
306−-- Uses the same parameter order as 'catchError' so that it can be used infix.
307−--
308−-- prop> c `compilerCatch` f = compilerTry c >>= either f return
309−compilerCatch :: Compiler a -> (CompilerErrors String -> Compiler a) -> Compiler a
222+compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
310223compilerCatch (Compiler x) f = Compiler $ \r -> do
311224 res <- x r
312225 case res of
313226 CompilerDone res' w -> return (CompilerDone res' w)
314227 CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))
315− CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
316228 CompilerError e -> unCompiler (f e) r
229+ CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
317230{-# INLINE compilerCatch #-}
318231
319232
320233--------------------------------------------------------------------------------
321−compilerDebugLog :: [String] -> Compiler ()
322−compilerDebugLog ms = do
323− logger <- compilerLogger <$> compilerAsk
324− compilerUnsafeIO $ forM_ ms $ Logger.debug logger
234+-- | Put the result back in a compiler
235+compilerResult :: CompilerResult a -> Compiler a
236+compilerResult x = Compiler $ \_ -> return x
237+{-# INLINE compilerResult #-}
238+
325239
326240--------------------------------------------------------------------------------
327−-- | Pass a list of messages with a heading to the debug logger
328−compilerDebugEntries :: String -> [String] -> Compiler ()
329−compilerDebugEntries msg = compilerDebugLog . (msg:) . map indent
330− where
331− indent = unlines . map (" "++) . lines
241+compilerUnsafeIO :: IO a -> Compiler a
242+compilerUnsafeIO io = Compiler $ \_ -> do
243+ x <- io
244+ return $ CompilerDone x mempty
245+{-# INLINE compilerUnsafeIO #-}
332246
333247
334248--------------------------------------------------------------------------------
335249compilerTellDependencies :: [Dependency] -> Compiler ()
336250compilerTellDependencies ds = do
337− compilerDebugLog $ map (\d ->
338− "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds
251+ logger <- compilerLogger <$> compilerAsk
252+ forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $
253+ "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d
339254 compilerTell mempty {compilerDependencies = ds}
340255{-# INLINE compilerTellDependencies #-}
341256