parent
c40cf286af
commit
cbfc7c18e1
8 changed files with 40 additions and 33 deletions
|
@ -116,7 +116,7 @@ getResourceWith reader = do
|
||||||
let filePath = toFilePath id'
|
let filePath = toFilePath id'
|
||||||
if resourceExists provider id'
|
if resourceExists provider id'
|
||||||
then compilerUnsafeIO $ Item id' <$> reader provider id'
|
then compilerUnsafeIO $ Item id' <$> reader provider id'
|
||||||
else compilerThrow $ error' filePath
|
else fail $ error' filePath
|
||||||
where
|
where
|
||||||
error' fp = "Hakyll.Core.Compiler.getResourceWith: resource " ++
|
error' fp = "Hakyll.Core.Compiler.getResourceWith: resource " ++
|
||||||
show fp ++ " not found"
|
show fp ++ " not found"
|
||||||
|
@ -156,7 +156,7 @@ cached name compiler = do
|
||||||
x <- compilerUnsafeIO $ Store.get store [name, show id']
|
x <- compilerUnsafeIO $ Store.get store [name, show id']
|
||||||
progName <- compilerUnsafeIO getProgName
|
progName <- compilerUnsafeIO getProgName
|
||||||
case x of Store.Found x' -> return x'
|
case x of Store.Found x' -> return x'
|
||||||
_ -> compilerThrow (error' progName)
|
_ -> fail $ error' progName
|
||||||
where
|
where
|
||||||
error' progName =
|
error' progName =
|
||||||
"Hakyll.Core.Compiler.cached: Cache corrupt! " ++
|
"Hakyll.Core.Compiler.cached: Cache corrupt! " ++
|
||||||
|
|
|
@ -28,6 +28,7 @@ module Hakyll.Core.Compiler.Internal
|
||||||
import Control.Applicative (Alternative (..),
|
import Control.Applicative (Alternative (..),
|
||||||
Applicative (..), (<$>))
|
Applicative (..), (<$>))
|
||||||
import Control.Exception (SomeException, handle)
|
import Control.Exception (SomeException, handle)
|
||||||
|
import Control.Monad (forM_)
|
||||||
import Data.Monoid (Monoid (..))
|
import Data.Monoid (Monoid (..))
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
|
@ -38,7 +39,8 @@ import Hakyll.Core.Configuration
|
||||||
import Hakyll.Core.Dependencies
|
import Hakyll.Core.Dependencies
|
||||||
import Hakyll.Core.Identifier
|
import Hakyll.Core.Identifier
|
||||||
import Hakyll.Core.Identifier.Pattern
|
import Hakyll.Core.Identifier.Pattern
|
||||||
import Hakyll.Core.Logger
|
import Hakyll.Core.Logger (Logger)
|
||||||
|
import qualified Hakyll.Core.Logger as Logger
|
||||||
import Hakyll.Core.Metadata
|
import Hakyll.Core.Metadata
|
||||||
import Hakyll.Core.Provider
|
import Hakyll.Core.Provider
|
||||||
import Hakyll.Core.Routes
|
import Hakyll.Core.Routes
|
||||||
|
@ -82,7 +84,7 @@ instance Monoid CompilerWrite where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
data CompilerResult a where
|
data CompilerResult a where
|
||||||
CompilerDone :: a -> CompilerWrite -> CompilerResult a
|
CompilerDone :: a -> CompilerWrite -> CompilerResult a
|
||||||
CompilerError :: String -> CompilerResult a
|
CompilerError :: [String] -> CompilerResult a
|
||||||
CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
|
CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
|
||||||
|
|
||||||
|
|
||||||
|
@ -126,7 +128,7 @@ instance Monad Compiler where
|
||||||
CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
|
CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
|
||||||
{-# INLINE (>>=) #-}
|
{-# INLINE (>>=) #-}
|
||||||
|
|
||||||
fail = compilerThrow
|
fail = compilerThrow . return
|
||||||
{-# INLINE fail #-}
|
{-# INLINE fail #-}
|
||||||
|
|
||||||
|
|
||||||
|
@ -150,13 +152,17 @@ runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
|
||||||
runCompiler compiler read' = handle handler $ unCompiler compiler read'
|
runCompiler compiler read' = handle handler $ unCompiler compiler read'
|
||||||
where
|
where
|
||||||
handler :: SomeException -> IO (CompilerResult a)
|
handler :: SomeException -> IO (CompilerResult a)
|
||||||
handler e = return $ CompilerError $ show e
|
handler e = return $ CompilerError [show e]
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
instance Alternative Compiler where
|
instance Alternative Compiler where
|
||||||
empty = compilerThrow "Hakyll.Core.Compiler.Internal: empty alternative"
|
empty = compilerThrow []
|
||||||
x <|> y = compilerCatch x (\_ -> y)
|
x <|> y = compilerCatch x $ \es -> do
|
||||||
|
logger <- compilerLogger <$> compilerAsk
|
||||||
|
forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $
|
||||||
|
"Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e
|
||||||
|
y
|
||||||
{-# INLINE (<|>) #-}
|
{-# INLINE (<|>) #-}
|
||||||
|
|
||||||
|
|
||||||
|
@ -173,13 +179,13 @@ compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
compilerThrow :: String -> Compiler a
|
compilerThrow :: [String] -> Compiler a
|
||||||
compilerThrow e = Compiler $ \_ -> return $ CompilerError e
|
compilerThrow es = Compiler $ \_ -> return $ CompilerError es
|
||||||
{-# INLINE compilerThrow #-}
|
{-# INLINE compilerThrow #-}
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
compilerCatch :: Compiler a -> (String -> Compiler a) -> Compiler a
|
compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
|
||||||
compilerCatch (Compiler x) f = Compiler $ \r -> do
|
compilerCatch (Compiler x) f = Compiler $ \r -> do
|
||||||
res <- x r
|
res <- x r
|
||||||
case res of
|
case res of
|
||||||
|
|
|
@ -67,14 +67,14 @@ loadSnapshot id' snapshot = do
|
||||||
universe <- compilerUniverse <$> compilerAsk
|
universe <- compilerUniverse <$> compilerAsk
|
||||||
|
|
||||||
-- Quick check for better error messages
|
-- Quick check for better error messages
|
||||||
when (id' `S.notMember` universe) $ compilerThrow notFound
|
when (id' `S.notMember` universe) $ fail notFound
|
||||||
|
|
||||||
compilerTellDependencies [IdentifierDependency id']
|
compilerTellDependencies [IdentifierDependency id']
|
||||||
compilerResult $ CompilerRequire id' $ do
|
compilerResult $ CompilerRequire id' $ do
|
||||||
result <- compilerUnsafeIO $ Store.get store (key id' snapshot)
|
result <- compilerUnsafeIO $ Store.get store (key id' snapshot)
|
||||||
case result of
|
case result of
|
||||||
Store.NotFound -> compilerThrow notFound
|
Store.NotFound -> fail notFound
|
||||||
Store.WrongType e r -> compilerThrow $ wrongType e r
|
Store.WrongType e r -> fail $ wrongType e r
|
||||||
Store.Found x -> return $ Item id' x
|
Store.Found x -> return $ Item id' x
|
||||||
where
|
where
|
||||||
notFound =
|
notFound =
|
||||||
|
|
|
@ -200,7 +200,9 @@ chase trail id'
|
||||||
result <- liftIO $ runCompiler compiler read'
|
result <- liftIO $ runCompiler compiler read'
|
||||||
case result of
|
case result of
|
||||||
-- Rethrow error
|
-- Rethrow error
|
||||||
CompilerError e -> throwError e
|
CompilerError [] -> throwError
|
||||||
|
"Compiler failed but no info given, try running with -v?"
|
||||||
|
CompilerError es -> throwError $ intercalate "; " es
|
||||||
|
|
||||||
-- Huge success
|
-- Huge success
|
||||||
CompilerDone (SomeItem item) cwrite -> do
|
CompilerDone (SomeItem item) cwrite -> do
|
||||||
|
|
|
@ -16,15 +16,13 @@ import qualified Data.ByteString.Lazy as LB
|
||||||
import Data.IORef (newIORef, readIORef, writeIORef)
|
import Data.IORef (newIORef, readIORef, writeIORef)
|
||||||
import Data.Monoid (Monoid, mempty)
|
import Data.Monoid (Monoid, mempty)
|
||||||
import System.Exit (ExitCode (..))
|
import System.Exit (ExitCode (..))
|
||||||
import System.IO (Handle, hClose, hFlush,
|
import System.IO (Handle, hClose, hFlush, hGetContents,
|
||||||
hGetContents, hPutStr,
|
hPutStr, hSetEncoding, localeEncoding)
|
||||||
hSetEncoding, localeEncoding)
|
|
||||||
import System.Process
|
import System.Process
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Hakyll.Core.Compiler
|
import Hakyll.Core.Compiler
|
||||||
import Hakyll.Core.Compiler.Internal
|
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -92,7 +90,7 @@ unixFilterWith writer reader programName args input = do
|
||||||
forM_ (lines err) debugCompiler
|
forM_ (lines err) debugCompiler
|
||||||
case exitCode of
|
case exitCode of
|
||||||
ExitSuccess -> return output
|
ExitSuccess -> return output
|
||||||
ExitFailure e -> compilerThrow $
|
ExitFailure e -> fail $
|
||||||
"Hakyll.Core.UnixFilter.unixFilterWith: " ++
|
"Hakyll.Core.UnixFilter.unixFilterWith: " ++
|
||||||
unwords (programName : args) ++ " gave exit code " ++ show e
|
unwords (programName : args) ++ " gave exit code " ++ show e
|
||||||
|
|
||||||
|
|
|
@ -226,6 +226,6 @@ modificationTimeFieldWith locale key fmt = field key $ \i -> do
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
missingField :: Context a
|
missingField :: Context a
|
||||||
missingField = Context $ \k i -> compilerThrow $
|
missingField = Context $ \k i -> fail $
|
||||||
"Missing field $" ++ k ++ "$ in context for item " ++
|
"Missing field $" ++ k ++ "$ in context for item " ++
|
||||||
show (itemIdentifier i)
|
show (itemIdentifier i)
|
||||||
|
|
|
@ -49,7 +49,7 @@ unixFilterFalse = do
|
||||||
provider <- newTestProvider store
|
provider <- newTestProvider store
|
||||||
result <- testCompiler store provider "russian.md" compiler
|
result <- testCompiler store provider "russian.md" compiler
|
||||||
H.assert $ case result of
|
H.assert $ case result of
|
||||||
CompilerError e -> "exit code" `isInfixOf` e
|
CompilerError es -> any ("exit code" `isInfixOf`) es
|
||||||
_ -> False
|
_ -> False
|
||||||
cleanTestEnv
|
cleanTestEnv
|
||||||
where
|
where
|
||||||
|
|
|
@ -12,6 +12,7 @@ module TestSuite.Util
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
import Data.List (intercalate)
|
||||||
import Data.Monoid (mempty)
|
import Data.Monoid (mempty)
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
import Test.Framework
|
import Test.Framework
|
||||||
|
@ -78,7 +79,7 @@ testCompilerDone store provider underlying compiler = do
|
||||||
CompilerDone x _ -> return x
|
CompilerDone x _ -> return x
|
||||||
CompilerError e -> error $
|
CompilerError e -> error $
|
||||||
"TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++
|
"TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++
|
||||||
" threw: " ++ e
|
" threw: " ++ intercalate "; " e
|
||||||
CompilerRequire i _ -> error $
|
CompilerRequire i _ -> error $
|
||||||
"TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++
|
"TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++
|
||||||
" requires: " ++ show i
|
" requires: " ++ show i
|
||||||
|
|
Loading…
Reference in a new issue