@@ -1,6 +1,7 @@
11--------------------------------------------------------------------------------
22-- | Internally used compiler module
33{-# LANGUAGE CPP #-}
4+{-# LANGUAGE DeriveFunctor #-}
45{-# LANGUAGE FlexibleInstances #-}
56{-# LANGUAGE GADTs #-}
67{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -10,19 +11,26 @@ module Hakyll.Core.Compiler.Internal
1011 Snapshot
1112 , CompilerRead (..)
1213 , CompilerWrite (..)
14+ , CompilerErrors (..)
1315 , CompilerResult (..)
1416 , Compiler (..)
1517 , runCompiler
1618
1719 -- * Core operations
20+ , compilerResult
1821 , compilerTell
1922 , compilerAsk
23+ , compilerUnsafeIO
24+
25+ -- * Error operations
2026 , compilerThrow
27+ , compilerNoResult
2128 , compilerCatch
22− , compilerResult
23− , compilerUnsafeIO
29+ , compilerTry
30+ , compilerErrorMessages
2431
2532 -- * Utilities
33+ , compilerDebugEntries
2634 , compilerTellDependencies
2735 , compilerTellCacheHits
2836 ) where
@@ -32,7 +40,9 @@ module Hakyll.Core.Compiler.Internal
3240import Control.Applicative (Alternative (..))
3341import Control.Exception (SomeException, handle)
3442import Control.Monad (forM_)
35−import Control.Monad.Except (MonadError (..))
43+import Control.Monad.Except (MonadError (..))
44+import Data.List.NonEmpty (NonEmpty (..))
45+import qualified Data.List.NonEmpty as NonEmpty
3646#if MIN_VERSION_base(4,9,0)
3747import Data.Semigroup (Semigroup (..))
3848#endif
@@ -45,7 +55,6 @@ import Hakyll.Core.Configuration
4555import Hakyll.Core.Dependencies
4656import Hakyll.Core.Identifier
4757import Hakyll.Core.Identifier.Pattern
48−import Hakyll.Core.Logger (Logger)
4958import qualified Hakyll.Core.Logger as Logger
5059import Hakyll.Core.Metadata
5160import Hakyll.Core.Provider
@@ -75,7 +84,7 @@ data CompilerRead = CompilerRead
7584 , -- | Compiler store
7685 compilerStore :: Store
7786 , -- | Logger
78− compilerLogger :: Logger
87+ compilerLogger :: Logger.Logger
7988 }
8089
8190
@@ -104,11 +113,29 @@ instance Monoid CompilerWrite where
104113
105114
106115--------------------------------------------------------------------------------
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
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)
112139
113140
114141--------------------------------------------------------------------------------
@@ -126,14 +153,14 @@ instance Functor Compiler where
126153 return $ case res of
127154 CompilerDone x w -> CompilerDone (f x) w
128155 CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')
129− CompilerError e -> CompilerError e
130156 CompilerRequire i c' -> CompilerRequire i (fmap f c')
157+ CompilerError e -> CompilerError e
131158 {-# INLINE fmap #-}
132159
133160
134161--------------------------------------------------------------------------------
135162instance Monad Compiler where
136− return x = Compiler $ \_ -> return $ CompilerDone x mempty
163+ return x = compilerResult $ CompilerDone x mempty
137164 {-# INLINE return #-}
138165
139166 Compiler c >>= f = Compiler $ \r -> do
@@ -146,14 +173,14 @@ instance Monad Compiler where
146173 CompilerSnapshot s c' -> CompilerSnapshot s $ do
147174 compilerTell w -- Save dependencies!
148175 c'
149− CompilerError e -> CompilerError e
150176 CompilerRequire i c' -> CompilerRequire i $ do
151177 compilerTell w -- Save dependencies!
152178 c'
179+ CompilerError e -> CompilerError e
153180
154181 CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)
155− CompilerError e -> return $ CompilerError e
156182 CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)
183+ CompilerError e -> return $ CompilerError e
157184 {-# INLINE (>>=) #-}
158185
159186 fail = compilerThrow . return
@@ -170,87 +197,145 @@ instance Applicative Compiler where
170197
171198
172199--------------------------------------------------------------------------------
200+-- | Access provided metadata from anywhere
173201instance MonadMetadata Compiler where
174202 getMetadata = compilerGetMetadata
175203 getMatches = compilerGetMatches
176204
177205
178206--------------------------------------------------------------------------------
207+-- | Compilation may fail with multiple error messages.
208+-- 'catchError' handles errors from 'throwError', 'fail' and 'Hakyll.Core.Compiler.noResult'
179209instance MonadError [String] Compiler where
180− throwError = compilerThrow
181− catchError = compilerCatch
210+ throwError = compilerThrow
211+ catchError c = compilerCatch c . (. compilerErrorMessages)
182212
183213
184214--------------------------------------------------------------------------------
215+-- | Like 'unCompiler' but treating IO exceptions as 'CompilerError's
185216runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
186217runCompiler compiler read' = handle handler $ unCompiler compiler read'
187218 where
188219 handler :: SomeException -> IO (CompilerResult a)
189− handler e = return $ CompilerError [show e]
220+ handler e = return $ CompilerError $ CompilationFailure $ show e :| []
190221
191222
192223--------------------------------------------------------------------------------
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.
193227instance Alternative Compiler where
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
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"
200241 {-# INLINE (<|>) #-}
201242
202243
203244--------------------------------------------------------------------------------
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
204253compilerAsk :: Compiler CompilerRead
205254compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
206255{-# INLINE compilerAsk #-}
207256
208257
209258--------------------------------------------------------------------------------
259+-- | Put a 'CompilerWrite'
210260compilerTell :: CompilerWrite -> Compiler ()
211−compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
261+compilerTell = compilerResult . CompilerDone ()
212262{-# INLINE compilerTell #-}
213263
214264
215265--------------------------------------------------------------------------------
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.
216279compilerThrow :: [String] -> Compiler a
217−compilerThrow es = Compiler $ \_ -> return $ CompilerError es
218−{-# INLINE compilerThrow #-}
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
219287
220288
221289--------------------------------------------------------------------------------
222−compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
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
223310compilerCatch (Compiler x) f = Compiler $ \r -> do
224311 res <- x r
225312 case res of
226313 CompilerDone res' w -> return (CompilerDone res' w)
227314 CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))
228− CompilerError e -> unCompiler (f e) r
229315 CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
316+ CompilerError e -> unCompiler (f e) r
230317{-# INLINE compilerCatch #-}
231318
232319
233320--------------------------------------------------------------------------------
234−-- | Put the result back in a compiler
235−compilerResult :: CompilerResult a -> Compiler a
236−compilerResult x = Compiler $ \_ -> return x
237−{-# INLINE compilerResult #-}
238−
321+compilerDebugLog :: [String] -> Compiler ()
322+compilerDebugLog ms = do
323+ logger <- compilerLogger <$> compilerAsk
324+ compilerUnsafeIO $ forM_ ms $ Logger.debug logger
239325
240326--------------------------------------------------------------------------------
241−compilerUnsafeIO :: IO a -> Compiler a
242−compilerUnsafeIO io = Compiler $ \_ -> do
243− x <- io
244− return $ CompilerDone x mempty
245−{-# INLINE compilerUnsafeIO #-}
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
246332
247333
248334--------------------------------------------------------------------------------
249335compilerTellDependencies :: [Dependency] -> Compiler ()
250336compilerTellDependencies ds = do
251− logger <- compilerLogger <$> compilerAsk
252− forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $
253− "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d
337+ compilerDebugLog $ map (\d ->
338+ "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds
254339 compilerTell mempty {compilerDependencies = ds}
255340{-# INLINE compilerTellDependencies #-}
256341