From 8cfa962005938cc441523ca55f3770fe55602036 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 6 Mar 2011 15:56:22 +0100 Subject: Add ErrorT to CompilerM monad stack --- src/Hakyll/Core/Compiler.hs | 35 ++++++++++++++++++----------------- src/Hakyll/Core/Compiler/Internal.hs | 14 ++++++++++---- src/Hakyll/Core/Logger.hs | 9 +++++++++ src/Hakyll/Core/Run.hs | 9 +++++++-- 4 files changed, 44 insertions(+), 23 deletions(-) (limited to 'src') diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index e5da9b8..79ebb5e 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -112,6 +112,7 @@ import Control.Arrow ((>>>), (&&&), arr) import Control.Applicative ((<$>)) import Control.Monad.Reader (ask) import Control.Monad.Trans (liftIO) +import Control.Monad.Error (throwError) import Control.Category (Category, (.), id) import Data.Maybe (fromMaybe) import System.FilePath (takeExtension) @@ -133,14 +134,14 @@ import Hakyll.Core.Logger -- | Run a compiler, yielding the resulting target and it's dependencies. This -- version of 'runCompilerJob' also stores the result -- -runCompiler :: Compiler () CompileRule -- ^ Compiler to run - -> Identifier -- ^ Target identifier - -> ResourceProvider -- ^ Resource provider - -> Routes -- ^ Route - -> Store -- ^ Store - -> Bool -- ^ Was the resource modified? - -> Logger -- ^ Logger - -> IO CompileRule -- ^ Resulting item +runCompiler :: Compiler () CompileRule -- ^ Compiler to run + -> Identifier -- ^ Target identifier + -> ResourceProvider -- ^ Resource provider + -> Routes -- ^ Route + -> Store -- ^ Store + -> Bool -- ^ Was the resource modified? + -> Logger -- ^ Logger + -> IO (Throwing CompileRule) -- ^ Resulting item runCompiler compiler identifier provider routes store modified logger = do -- Run the compiler job result <- @@ -151,7 +152,7 @@ runCompiler compiler identifier provider routes store modified logger = do -- In case we compiled an item, we will store a copy in the cache first, -- before we return control. This makes sure the compiled item can later -- be accessed by e.g. require. - CompileRule (CompiledItem x) -> + Right (CompileRule (CompiledItem x)) -> storeSet store "Hakyll.Core.Compiler.runCompiler" identifier x -- Otherwise, we do nothing here @@ -187,16 +188,16 @@ getResourceString = fromJob $ \resource -> CompilerM $ do -- getDependency :: (Binary a, Writable a, Typeable a) => Identifier -> CompilerM a -getDependency identifier = CompilerM $ do +getDependency id' = CompilerM $ do store <- compilerStore <$> ask - fmap (fromMaybe error') $ liftIO $ - storeGet store "Hakyll.Core.Compiler.runCompiler" identifier + result <- liftIO $ storeGet store "Hakyll.Core.Compiler.runCompiler" id' + case result of + Nothing -> throwError error' + Just x -> return x where - error' = error $ "Hakyll.Core.Compiler.getDependency: " - ++ show identifier - ++ " not found in the cache, the cache might be corrupted or" - ++ " the item you are referring to might not exist" - + error' = "Hakyll.Core.Compiler.getDependency: " ++ show id' + ++ " not found in the cache, the cache might be corrupted or" + ++ " the item you are referring to might not exist" -- | Variant of 'require' which drops the current value -- diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 53df044..4eef91c 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -5,6 +5,7 @@ module Hakyll.Core.Compiler.Internal ( Dependencies , DependencyEnvironment (..) , CompilerEnvironment (..) + , Throwing , CompilerM (..) , Compiler (..) , runCompilerJob @@ -17,6 +18,7 @@ module Hakyll.Core.Compiler.Internal import Prelude hiding ((.), id) import Control.Applicative (Applicative, pure, (<*>), (<$>)) import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader) +import Control.Monad.Error (ErrorT, runErrorT) import Control.Monad ((<=<), liftM2) import Data.Set (Set) import qualified Data.Set as S @@ -59,10 +61,14 @@ data CompilerEnvironment = CompilerEnvironment compilerLogger :: Logger } +-- | A calculation possibly throwing an error +-- +type Throwing a = Either String a + -- | The compiler monad -- newtype CompilerM a = CompilerM - { unCompilerM :: ReaderT CompilerEnvironment IO a + { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a } deriving (Monad, Functor, Applicative) -- | The compiler arrow @@ -96,7 +102,7 @@ instance ArrowChoice Compiler where Left l -> Left <$> j l Right r -> Right <$> return r --- | Run a compiler, yielding the resulting target and it's dependencies +-- | Run a compiler, yielding the resulting target -- runCompilerJob :: Compiler () a -- ^ Compiler to run -> Identifier -- ^ Target identifier @@ -105,9 +111,9 @@ runCompilerJob :: Compiler () a -- ^ Compiler to run -> Store -- ^ Store -> Bool -- ^ Was the resource modified? -> Logger -- ^ Logger - -> IO a + -> IO (Throwing a) -- ^ Result runCompilerJob compiler identifier provider route store modified logger = - runReaderT (unCompilerM $ compilerJob compiler ()) env + runReaderT (runErrorT $ unCompilerM $ compilerJob compiler ()) env where env = CompilerEnvironment { compilerIdentifier = identifier diff --git a/src/Hakyll/Core/Logger.hs b/src/Hakyll/Core/Logger.hs index 720dee0..5d75fa9 100644 --- a/src/Hakyll/Core/Logger.hs +++ b/src/Hakyll/Core/Logger.hs @@ -8,6 +8,7 @@ module Hakyll.Core.Logger , section , timed , report + , thrown ) where import Control.Monad (forever) @@ -88,3 +89,11 @@ report :: MonadIO m -> String -- ^ Message -> m () -- ^ No result report logger msg = liftIO $ message logger $ " [ ] " ++ msg + +-- | Log an error that was thrown in the compilation phase +-- +thrown :: MonadIO m + => Logger -- ^ Logger + -> String -- ^ Message + -> m () -- ^ No result +thrown logger msg = liftIO $ message logger $ " [ ERROR] " ++ msg diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 09864be..1fefff8 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -188,7 +188,7 @@ runCompilers ((id', compiler) : compilers) = Runtime $ do case result of -- Compile rule for one item, easy stuff - CompileRule compiled -> do + Right (CompileRule compiled) -> do case runRoutes routes id' of Nothing -> return () Just url -> timed logger ("Routing to " ++ url) $ do @@ -202,6 +202,11 @@ runCompilers ((id', compiler) : compilers) = Runtime $ do unRuntime $ runCompilers compilers -- Metacompiler, slightly more complicated - MetaCompileRule newCompilers -> + Right (MetaCompileRule newCompilers) -> -- Actually I was just kidding, it's not hard at all unRuntime $ addNewCompilers compilers newCompilers + + -- Some error happened, log and continue + Left err -> do + thrown logger err + unRuntime $ runCompilers compilers -- cgit v1.2.3