summaryrefslogtreecommitdiff
path: root/lib/Hakyll/Core/Compiler
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Hakyll/Core/Compiler')
-rw-r--r--lib/Hakyll/Core/Compiler/Internal.hs167
-rw-r--r--lib/Hakyll/Core/Compiler/Require.hs2
2 files changed, 128 insertions, 41 deletions
diff --git a/lib/Hakyll/Core/Compiler/Internal.hs b/lib/Hakyll/Core/Compiler/Internal.hs
index 5b6d1aa..762630c 100644
--- a/lib/Hakyll/Core/Compiler/Internal.hs
+++ b/lib/Hakyll/Core/Compiler/Internal.hs
@@ -1,6 +1,7 @@
--------------------------------------------------------------------------------
-- | Internally used compiler module
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -10,19 +11,26 @@ module Hakyll.Core.Compiler.Internal
Snapshot
, CompilerRead (..)
, CompilerWrite (..)
+ , CompilerErrors (..)
, CompilerResult (..)
, Compiler (..)
, runCompiler
-- * Core operations
+ , compilerResult
, compilerTell
, compilerAsk
+ , compilerUnsafeIO
+
+ -- * Error operations
, compilerThrow
+ , compilerNoResult
, compilerCatch
- , compilerResult
- , compilerUnsafeIO
+ , compilerTry
+ , compilerErrorMessages
-- * Utilities
+ , compilerDebugEntries
, compilerTellDependencies
, compilerTellCacheHits
) where
@@ -32,7 +40,9 @@ module Hakyll.Core.Compiler.Internal
import Control.Applicative (Alternative (..))
import Control.Exception (SomeException, handle)
import Control.Monad (forM_)
-import Control.Monad.Except (MonadError (..))
+import Control.Monad.Except (MonadError (..))
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NonEmpty
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup (..))
#endif
@@ -45,7 +55,6 @@ import Hakyll.Core.Configuration
import Hakyll.Core.Dependencies
import Hakyll.Core.Identifier
import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Logger (Logger)
import qualified Hakyll.Core.Logger as Logger
import Hakyll.Core.Metadata
import Hakyll.Core.Provider
@@ -75,7 +84,7 @@ data CompilerRead = CompilerRead
, -- | Compiler store
compilerStore :: Store
, -- | Logger
- compilerLogger :: Logger
+ compilerLogger :: Logger.Logger
}
@@ -104,11 +113,29 @@ instance Monoid CompilerWrite where
--------------------------------------------------------------------------------
-data CompilerResult a where
- CompilerDone :: a -> CompilerWrite -> CompilerResult a
- CompilerSnapshot :: Snapshot -> Compiler a -> CompilerResult a
- CompilerError :: [String] -> CompilerResult a
- CompilerRequire :: (Identifier, Snapshot) -> Compiler a -> CompilerResult a
+-- | Distinguishes reasons in a 'CompilerError'
+data CompilerErrors a
+ -- | One or more exceptions occured during compilation
+ = CompilationFailure (NonEmpty a)
+ -- | Absence of any result, most notably in template contexts. May still
+ -- have error messages.
+ | CompilationNoResult [a]
+ deriving Functor
+
+
+-- | Unwrap a `CompilerErrors`
+compilerErrorMessages :: CompilerErrors a -> [a]
+compilerErrorMessages (CompilationFailure x) = NonEmpty.toList x
+compilerErrorMessages (CompilationNoResult x) = x
+
+
+--------------------------------------------------------------------------------
+-- | An intermediate result of a compilation step
+data CompilerResult a
+ = CompilerDone a CompilerWrite
+ | CompilerSnapshot Snapshot (Compiler a)
+ | CompilerRequire (Identifier, Snapshot) (Compiler a)
+ | CompilerError (CompilerErrors String)
--------------------------------------------------------------------------------
@@ -126,14 +153,14 @@ instance Functor Compiler where
return $ case res of
CompilerDone x w -> CompilerDone (f x) w
CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')
- CompilerError e -> CompilerError e
CompilerRequire i c' -> CompilerRequire i (fmap f c')
+ CompilerError e -> CompilerError e
{-# INLINE fmap #-}
--------------------------------------------------------------------------------
instance Monad Compiler where
- return x = Compiler $ \_ -> return $ CompilerDone x mempty
+ return x = compilerResult $ CompilerDone x mempty
{-# INLINE return #-}
Compiler c >>= f = Compiler $ \r -> do
@@ -146,14 +173,14 @@ instance Monad Compiler where
CompilerSnapshot s c' -> CompilerSnapshot s $ do
compilerTell w -- Save dependencies!
c'
- CompilerError e -> CompilerError e
CompilerRequire i c' -> CompilerRequire i $ do
compilerTell w -- Save dependencies!
c'
+ CompilerError e -> CompilerError e
CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)
- CompilerError e -> return $ CompilerError e
CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)
+ CompilerError e -> return $ CompilerError e
{-# INLINE (>>=) #-}
fail = compilerThrow . return
@@ -170,87 +197,145 @@ instance Applicative Compiler where
--------------------------------------------------------------------------------
+-- | Access provided metadata from anywhere
instance MonadMetadata Compiler where
getMetadata = compilerGetMetadata
getMatches = compilerGetMatches
--------------------------------------------------------------------------------
+-- | Compilation may fail with multiple error messages.
+-- 'catchError' handles errors from 'throwError', 'fail' and 'Hakyll.Core.Compiler.noResult'
instance MonadError [String] Compiler where
- throwError = compilerThrow
- catchError = compilerCatch
+ throwError = compilerThrow
+ catchError c = compilerCatch c . (. compilerErrorMessages)
--------------------------------------------------------------------------------
+-- | Like 'unCompiler' but treating IO exceptions as 'CompilerError's
runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
runCompiler compiler read' = handle handler $ unCompiler compiler read'
where
handler :: SomeException -> IO (CompilerResult a)
- handler e = return $ CompilerError [show e]
+ handler e = return $ CompilerError $ CompilationFailure $ show e :| []
--------------------------------------------------------------------------------
+-- | Trying alternative compilers if the first fails, regardless whether through
+-- 'fail', 'throwError' or 'Hakyll.Core.Compiler.noResult'.
+-- Aggregates error messages if all fail.
instance Alternative Compiler where
- empty = compilerThrow []
- x <|> y = compilerCatch x $ \es -> do
- logger <- compilerLogger <$> compilerAsk
- forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $
- "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e
- y
+ empty = compilerNoResult []
+ x <|> y = x `compilerCatch` (\rx -> y `compilerCatch` (\ry ->
+ case (rx, ry) of
+ (CompilationFailure xs, CompilationFailure ys) ->
+ compilerThrow $ NonEmpty.toList xs ++ NonEmpty.toList ys
+ (CompilationFailure xs, CompilationNoResult ys) ->
+ debug ys >> compilerThrow (NonEmpty.toList xs)
+ (CompilationNoResult xs, CompilationFailure ys) ->
+ debug xs >> compilerThrow (NonEmpty.toList ys)
+ (CompilationNoResult xs, CompilationNoResult ys) -> compilerNoResult $ xs ++ ys
+ ))
+ where
+ debug = compilerDebugEntries "Hakyll.Core.Compiler.Internal: Alternative fail suppressed"
{-# INLINE (<|>) #-}
--------------------------------------------------------------------------------
+-- | Put the result back in a compiler
+compilerResult :: CompilerResult a -> Compiler a
+compilerResult x = Compiler $ \_ -> return x
+{-# INLINE compilerResult #-}
+
+
+--------------------------------------------------------------------------------
+-- | Get the current environment
compilerAsk :: Compiler CompilerRead
compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
{-# INLINE compilerAsk #-}
--------------------------------------------------------------------------------
+-- | Put a 'CompilerWrite'
compilerTell :: CompilerWrite -> Compiler ()
-compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
+compilerTell = compilerResult . CompilerDone ()
{-# INLINE compilerTell #-}
--------------------------------------------------------------------------------
+-- | Run an IO computation without dependencies in a Compiler
+compilerUnsafeIO :: IO a -> Compiler a
+compilerUnsafeIO io = Compiler $ \_ -> do
+ x <- io
+ return $ CompilerDone x mempty
+{-# INLINE compilerUnsafeIO #-}
+
+
+--------------------------------------------------------------------------------
+-- | Throw errors in the 'Compiler'.
+--
+-- If no messages are given, this is considered a 'CompilationNoResult' error.
+-- Otherwise, it is treated as a proper compilation failure.
compilerThrow :: [String] -> Compiler a
-compilerThrow es = Compiler $ \_ -> return $ CompilerError es
-{-# INLINE compilerThrow #-}
+compilerThrow = compilerResult . CompilerError .
+ maybe (CompilationNoResult []) CompilationFailure .
+ NonEmpty.nonEmpty
+
+-- | Put a 'CompilerError' with multiple messages as 'CompilationNoResult'
+compilerNoResult :: [String] -> Compiler a
+compilerNoResult = compilerResult . CompilerError . CompilationNoResult
--------------------------------------------------------------------------------
-compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
+-- | Allows to distinguish 'CompilerError's and branch on them with 'Either'
+--
+-- prop> compilerTry = (`compilerCatch` return . Left) . fmap Right
+compilerTry :: Compiler a -> Compiler (Either (CompilerErrors String) a)
+compilerTry (Compiler x) = Compiler $ \r -> do
+ res <- x r
+ case res of
+ CompilerDone res' w -> return (CompilerDone (Right res') w)
+ CompilerSnapshot s c -> return (CompilerSnapshot s (compilerTry c))
+ CompilerRequire i c -> return (CompilerRequire i (compilerTry c))
+ CompilerError e -> return (CompilerDone (Left e) mempty)
+{-# INLINE compilerTry #-}
+
+
+--------------------------------------------------------------------------------
+-- | Allows you to recover from 'CompilerError's.
+-- Uses the same parameter order as 'catchError' so that it can be used infix.
+--
+-- prop> c `compilerCatch` f = compilerTry c >>= either f return
+compilerCatch :: Compiler a -> (CompilerErrors String -> Compiler a) -> Compiler a
compilerCatch (Compiler x) f = Compiler $ \r -> do
res <- x r
case res of
CompilerDone res' w -> return (CompilerDone res' w)
CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))
- CompilerError e -> unCompiler (f e) r
CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
+ CompilerError e -> unCompiler (f e) r
{-# INLINE compilerCatch #-}
--------------------------------------------------------------------------------
--- | Put the result back in a compiler
-compilerResult :: CompilerResult a -> Compiler a
-compilerResult x = Compiler $ \_ -> return x
-{-# INLINE compilerResult #-}
-
+compilerDebugLog :: [String] -> Compiler ()
+compilerDebugLog ms = do
+ logger <- compilerLogger <$> compilerAsk
+ compilerUnsafeIO $ forM_ ms $ Logger.debug logger
--------------------------------------------------------------------------------
-compilerUnsafeIO :: IO a -> Compiler a
-compilerUnsafeIO io = Compiler $ \_ -> do
- x <- io
- return $ CompilerDone x mempty
-{-# INLINE compilerUnsafeIO #-}
+-- | Pass a list of messages with a heading to the debug logger
+compilerDebugEntries :: String -> [String] -> Compiler ()
+compilerDebugEntries msg = compilerDebugLog . (msg:) . map indent
+ where
+ indent = unlines . map (" "++) . lines
--------------------------------------------------------------------------------
compilerTellDependencies :: [Dependency] -> Compiler ()
compilerTellDependencies ds = do
- logger <- compilerLogger <$> compilerAsk
- forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $
- "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d
+ compilerDebugLog $ map (\d ->
+ "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds
compilerTell mempty {compilerDependencies = ds}
{-# INLINE compilerTellDependencies #-}
diff --git a/lib/Hakyll/Core/Compiler/Require.hs b/lib/Hakyll/Core/Compiler/Require.hs
index c9373bf..6222eb8 100644
--- a/lib/Hakyll/Core/Compiler/Require.hs
+++ b/lib/Hakyll/Core/Compiler/Require.hs
@@ -91,6 +91,7 @@ loadBody id' = loadSnapshotBody id' final
--------------------------------------------------------------------------------
+-- | A shortcut for only requiring the body for a specific snapshot of an item
loadSnapshotBody :: (Binary a, Typeable a)
=> Identifier -> Snapshot -> Compiler a
loadSnapshotBody id' snapshot = fmap itemBody $ loadSnapshot id' snapshot
@@ -103,6 +104,7 @@ loadAll pattern = loadAllSnapshots pattern final
--------------------------------------------------------------------------------
+-- | Load a specific snapshot for each of dynamic list of items
loadAllSnapshots :: (Binary a, Typeable a)
=> Pattern -> Snapshot -> Compiler [Item a]
loadAllSnapshots pattern snapshot = do