@@ -1,38 +1,51 @@
1--------------------------------------------------------------------------------
1--------------------------------------------------------------------------------
2-- | Internally used compiler module
2-- | Internally used compiler module
4+{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
7module Hakyll.Core.Compiler.Internal
9module Hakyll.Core.Compiler.Internal
8 ( -- * Types
10 ( -- * Types
9− CompilerRead (..)
12+ , CompilerRead (..)
10 , CompilerWrite (..)
13 , CompilerWrite (..)
14+ , CompilerErrors (..)
11 , CompilerResult (..)
15 , CompilerResult (..)
12 , Compiler (..)
16 , Compiler (..)
13 , runCompiler
17 , runCompiler
15 -- * Core operations
19 -- * Core operations
16 , compilerTell
21 , compilerTell
17 , compilerAsk
22 , compilerAsk
25+ -- * Error operations
18 , compilerThrow
26 , compilerThrow
19 , compilerCatch
28 , compilerCatch
20− , compilerResult
29+ , compilerTry
21− , compilerUnsafeIO
30+ , compilerErrorMessages
23 -- * Utilities
32 -- * Utilities
33+ , compilerDebugEntries
24 , compilerTellDependencies
34 , compilerTellDependencies
25 , compilerTellCacheHits
35 , compilerTellCacheHits
29--------------------------------------------------------------------------------
39--------------------------------------------------------------------------------
30−import Control.Applicative (Alternative (..),
40+import Control.Applicative (Alternative (..))
31− Applicative (..), (<$>))
32import Control.Exception (SomeException, handle)
41import Control.Exception (SomeException, handle)
33import Control.Monad (forM_)
42import Control.Monad (forM_)
34−import Control.Monad.Error (MonadError (..))
43+import Control.Monad.Except (MonadError (..))
35−import Data.Monoid (Monoid (..))
44+import Data.List.NonEmpty (NonEmpty (..))
45+import qualified Data.List.NonEmpty as NonEmpty
46+#if MIN_VERSION_base(4,9,0)
47+import Data.Semigroup (Semigroup (..))
36import Data.Set (Set)
49import Data.Set (Set)
37import qualified Data.Set as S
50import qualified Data.Set as S
@@ -42,7 +55,6 @@ import Hakyll.Core.Configuration
42import Hakyll.Core.Dependencies
55import Hakyll.Core.Dependencies
43import Hakyll.Core.Identifier
56import Hakyll.Core.Identifier
44import Hakyll.Core.Identifier.Pattern
57import Hakyll.Core.Identifier.Pattern
45−import Hakyll.Core.Logger (Logger)
46import qualified Hakyll.Core.Logger as Logger
58import qualified Hakyll.Core.Logger as Logger
47import Hakyll.Core.Metadata
59import Hakyll.Core.Metadata
48import Hakyll.Core.Provider
60import Hakyll.Core.Provider
@@ -50,6 +62,12 @@ import Hakyll.Core.Routes
50import Hakyll.Core.Store
62import Hakyll.Core.Store
65+--------------------------------------------------------------------------------
66+-- | Whilst compiling an item, it possible to save multiple snapshots of it, and
67+-- not just the final result.
68+type Snapshot = String
53--------------------------------------------------------------------------------
71--------------------------------------------------------------------------------
54-- | Environment in which a compiler runs
72-- | Environment in which a compiler runs
55data CompilerRead = CompilerRead
73data CompilerRead = CompilerRead
@@ -66,7 +84,7 @@ data CompilerRead = CompilerRead
66 , -- | Compiler store
84 , -- | Compiler store
67 compilerStore :: Store
85 compilerStore :: Store
68 , -- | Logger
86 , -- | Logger
69− compilerLogger :: Logger
87+ compilerLogger :: Logger.Logger
@@ -78,17 +96,46 @@ data CompilerWrite = CompilerWrite
80--------------------------------------------------------------------------------
98--------------------------------------------------------------------------------
99+#if MIN_VERSION_base(4,9,0)
100+instance Semigroup CompilerWrite where
101+ (<>) (CompilerWrite d1 h1) (CompilerWrite d2 h2) =
102+ CompilerWrite (d1 ++ d2) (h1 + h2)
104+instance Monoid CompilerWrite where
105+ mempty = CompilerWrite [] 0
81instance Monoid CompilerWrite where
108instance Monoid CompilerWrite where
82 mempty = CompilerWrite [] 0
109 mempty = CompilerWrite [] 0
83 mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =
110 mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =
84 CompilerWrite (d1 ++ d2) (h1 + h2)
111 CompilerWrite (d1 ++ d2) (h1 + h2)
115+--------------------------------------------------------------------------------
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]
126+-- | Unwrap a `CompilerErrors`
127+compilerErrorMessages :: CompilerErrors a -> [a]
128+compilerErrorMessages (CompilationFailure x) = NonEmpty.toList x
129+compilerErrorMessages (CompilationNoResult x) = x
87--------------------------------------------------------------------------------
132--------------------------------------------------------------------------------
133+-- | An intermediate result of a compilation step
88−data CompilerResult a where
134+data CompilerResult a
89− CompilerDone :: a -> CompilerWrite -> CompilerResult a
135+ = CompilerDone a CompilerWrite
90− CompilerError :: [String] -> CompilerResult a
136+ | CompilerSnapshot Snapshot (Compiler a)
91− CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
137+ | CompilerRequire (Identifier, Snapshot) (Compiler a)
138+ | CompilerError (CompilerErrors String)
94--------------------------------------------------------------------------------
141--------------------------------------------------------------------------------
@@ -104,15 +151,16 @@ instance Functor Compiler where
104 fmap f (Compiler c) = Compiler $ \r -> do
151 fmap f (Compiler c) = Compiler $ \r -> do
105 res <- c r
152 res <- c r
106 return $ case res of
153 return $ case res of
107− CompilerDone x w -> CompilerDone (f x) w
154+ CompilerDone x w -> CompilerDone (f x) w
108− CompilerError e -> CompilerError e
155+ CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')
109− CompilerRequire i c' -> CompilerRequire i (fmap f c')
156+ CompilerRequire i c' -> CompilerRequire i (fmap f c')
157+ CompilerError e -> CompilerError e
110 {-# INLINE fmap #-}
158 {-# INLINE fmap #-}
113--------------------------------------------------------------------------------
161--------------------------------------------------------------------------------
114instance Monad Compiler where
162instance Monad Compiler where
115− return x = Compiler $ \_ -> return $ CompilerDone x mempty
163+ return x = compilerResult $ CompilerDone x mempty
116 {-# INLINE return #-}
164 {-# INLINE return #-}
118 Compiler c >>= f = Compiler $ \r -> do
166 Compiler c >>= f = Compiler $ \r -> do
@@ -121,14 +169,18 @@ instance Monad Compiler where
121 CompilerDone x w -> do
169 CompilerDone x w -> do
122 res' <- unCompiler (f x) r
170 res' <- unCompiler (f x) r
123 return $ case res' of
171 return $ case res' of
124− CompilerDone y w' -> CompilerDone y (w `mappend` w')
172+ CompilerDone y w' -> CompilerDone y (w `mappend` w')
125− CompilerError e -> CompilerError e
173+ CompilerSnapshot s c' -> CompilerSnapshot s $ do
126− CompilerRequire i c' -> CompilerRequire i $ do
127 compilerTell w -- Save dependencies!
174 compilerTell w -- Save dependencies!
176+ CompilerRequire i c' -> CompilerRequire i $ do
177+ compilerTell w -- Save dependencies!
179+ CompilerError e -> CompilerError e
130− CompilerError e -> return $ CompilerError e
181+ CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)
131− CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
182+ CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)
183+ CompilerError e -> return $ CompilerError e
132 {-# INLINE (>>=) #-}
184 {-# INLINE (>>=) #-}
134 fail = compilerThrow . return
186 fail = compilerThrow . return
@@ -145,86 +197,145 @@ instance Applicative Compiler where
147--------------------------------------------------------------------------------
199--------------------------------------------------------------------------------
200+-- | Access provided metadata from anywhere
148instance MonadMetadata Compiler where
201instance MonadMetadata Compiler where
149 getMetadata = compilerGetMetadata
202 getMetadata = compilerGetMetadata
150 getMatches = compilerGetMatches
203 getMatches = compilerGetMatches
153--------------------------------------------------------------------------------
206--------------------------------------------------------------------------------
207+-- | Compilation may fail with multiple error messages.
208+-- 'catchError' handles errors from 'throwError', 'fail' and 'Hakyll.Core.Compiler.noResult'
154instance MonadError [String] Compiler where
209instance MonadError [String] Compiler where
155− throwError = compilerThrow
210+ throwError = compilerThrow
156− catchError = compilerCatch
211+ catchError c = compilerCatch c . (. compilerErrorMessages)
159--------------------------------------------------------------------------------
214--------------------------------------------------------------------------------
215+-- | Like 'unCompiler' but treating IO exceptions as 'CompilerError's
160runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
216runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
161runCompiler compiler read' = handle handler $ unCompiler compiler read'
217runCompiler compiler read' = handle handler $ unCompiler compiler read'
163 handler :: SomeException -> IO (CompilerResult a)
219 handler :: SomeException -> IO (CompilerResult a)
164− handler e = return $ CompilerError [show e]
220+ handler e = return $ CompilerError $ CompilationFailure $ show e :| []
167--------------------------------------------------------------------------------
223--------------------------------------------------------------------------------
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.
168instance Alternative Compiler where
227instance Alternative Compiler where
169− empty = compilerThrow []
228+ empty = compilerNoResult []
170− x <|> y = compilerCatch x $ \es -> do
229+ x <|> y = x `compilerCatch` (\rx -> y `compilerCatch` (\ry ->
171− logger <- compilerLogger <$> compilerAsk
230+ case (rx, ry) of
172− forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $
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
173− "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e
240+ debug = compilerDebugEntries "Hakyll.Core.Compiler.Internal: Alternative fail suppressed"
175 {-# INLINE (<|>) #-}
241 {-# INLINE (<|>) #-}
178--------------------------------------------------------------------------------
244--------------------------------------------------------------------------------
245+-- | Put the result back in a compiler
246+compilerResult :: CompilerResult a -> Compiler a
247+compilerResult x = Compiler $ \_ -> return x
248+{-# INLINE compilerResult #-}
251+--------------------------------------------------------------------------------
252+-- | Get the current environment
179compilerAsk :: Compiler CompilerRead
253compilerAsk :: Compiler CompilerRead
180compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
254compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
181{-# INLINE compilerAsk #-}
255{-# INLINE compilerAsk #-}
184--------------------------------------------------------------------------------
258--------------------------------------------------------------------------------
259+-- | Put a 'CompilerWrite'
185compilerTell :: CompilerWrite -> Compiler ()
260compilerTell :: CompilerWrite -> Compiler ()
186−compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
261+compilerTell = compilerResult . CompilerDone ()
187{-# INLINE compilerTell #-}
262{-# INLINE compilerTell #-}
190--------------------------------------------------------------------------------
265--------------------------------------------------------------------------------
266+-- | Run an IO computation without dependencies in a Compiler
267+compilerUnsafeIO :: IO a -> Compiler a
268+compilerUnsafeIO io = Compiler $ \_ -> do
270+ return $ CompilerDone x mempty
271+{-# INLINE compilerUnsafeIO #-}
274+--------------------------------------------------------------------------------
275+-- | Throw errors in the 'Compiler'.
277+-- If no messages are given, this is considered a 'CompilationNoResult' error.
278+-- Otherwise, it is treated as a proper compilation failure.
191compilerThrow :: [String] -> Compiler a
279compilerThrow :: [String] -> Compiler a
192−compilerThrow es = Compiler $ \_ -> return $ CompilerError es
280+compilerThrow = compilerResult . CompilerError .
193−{-# INLINE compilerThrow #-}
281+ maybe (CompilationNoResult []) CompilationFailure .
284+-- | Put a 'CompilerError' with multiple messages as 'CompilationNoResult'
285+compilerNoResult :: [String] -> Compiler a
286+compilerNoResult = compilerResult . CompilerError . CompilationNoResult
289+--------------------------------------------------------------------------------
290+-- | Allows to distinguish 'CompilerError's and branch on them with 'Either'
292+-- prop> compilerTry = (`compilerCatch` return . Left) . fmap Right
293+compilerTry :: Compiler a -> Compiler (Either (CompilerErrors String) a)
294+compilerTry (Compiler x) = Compiler $ \r -> do
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 #-}
196--------------------------------------------------------------------------------
304--------------------------------------------------------------------------------
305+-- | Allows you to recover from 'CompilerError's.
306+-- Uses the same parameter order as 'catchError' so that it can be used infix.
308+-- prop> c `compilerCatch` f = compilerTry c >>= either f return
197−compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
309+compilerCatch :: Compiler a -> (CompilerErrors String -> Compiler a) -> Compiler a
198compilerCatch (Compiler x) f = Compiler $ \r -> do
310compilerCatch (Compiler x) f = Compiler $ \r -> do
199 res <- x r
311 res <- x r
200 case res of
312 case res of
201− CompilerDone res' w -> return (CompilerDone res' w)
313+ CompilerDone res' w -> return (CompilerDone res' w)
314+ CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))
315+ CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
202− CompilerError e -> unCompiler (f e) r
316+ CompilerError e -> unCompiler (f e) r
203− CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
204{-# INLINE compilerCatch #-}
317{-# INLINE compilerCatch #-}
207--------------------------------------------------------------------------------
320--------------------------------------------------------------------------------
208−-- | Put the result back in a compiler
321+compilerDebugLog :: [String] -> Compiler ()
209−compilerResult :: CompilerResult a -> Compiler a
322+compilerDebugLog ms = do
210−compilerResult x = Compiler $ \_ -> return x
323+ logger <- compilerLogger <$> compilerAsk
211−{-# INLINE compilerResult #-}
324+ compilerUnsafeIO $ forM_ ms $ Logger.debug logger
214--------------------------------------------------------------------------------
326--------------------------------------------------------------------------------
215−compilerUnsafeIO :: IO a -> Compiler a
327+-- | Pass a list of messages with a heading to the debug logger
216−compilerUnsafeIO io = Compiler $ \_ -> do
328+compilerDebugEntries :: String -> [String] -> Compiler ()
217− x <- io
329+compilerDebugEntries msg = compilerDebugLog . (msg:) . map indent
218− return $ CompilerDone x mempty
330+ where
219−{-# INLINE compilerUnsafeIO #-}
331+ indent = unlines . map (" "++) . lines
222--------------------------------------------------------------------------------
334--------------------------------------------------------------------------------
223compilerTellDependencies :: [Dependency] -> Compiler ()
335compilerTellDependencies :: [Dependency] -> Compiler ()
224compilerTellDependencies ds = do
336compilerTellDependencies ds = do
225− logger <- compilerLogger <$> compilerAsk
337+ compilerDebugLog $ map (\d ->
226− forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $
227− "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d
338+ "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds
228 compilerTell mempty {compilerDependencies = ds}
339 compilerTell mempty {compilerDependencies = ds}
229{-# INLINE compilerTellDependencies #-}
340{-# INLINE compilerTellDependencies #-}
@@ -248,5 +359,6 @@ compilerGetMatches :: Pattern -> Compiler [Identifier]
248compilerGetMatches pattern = do
359compilerGetMatches pattern = do
249 universe <- compilerUniverse <$> compilerAsk
360 universe <- compilerUniverse <$> compilerAsk
250 let matching = filterMatches pattern $ S.toList universe
361 let matching = filterMatches pattern $ S.toList universe
362+ set' = S.fromList matching
251− compilerTellDependencies [PatternDependency pattern matching]
363+ compilerTellDependencies [PatternDependency pattern set']
252 return matching
364 return matching