diff options
Diffstat (limited to 'lib/Hakyll/Core/Compiler')
| -rw-r--r-- | lib/Hakyll/Core/Compiler/Internal.hs | 167 | ||||
| -rw-r--r-- | lib/Hakyll/Core/Compiler/Require.hs | 2 |
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 |