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