From cbfc7c18e1aa6c498d2fc7bdecf2f127b6582dbd Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <m@jaspervdj.be>
Date: Thu, 4 Apr 2013 00:26:05 +0200
Subject: Debug info for Alternative instances

See #126
---
 src/Hakyll/Core/Compiler/Internal.hs | 24 +++++++++++++++---------
 src/Hakyll/Core/Compiler/Require.hs  |  6 +++---
 2 files changed, 18 insertions(+), 12 deletions(-)

(limited to 'src/Hakyll/Core/Compiler')

diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index 9aa441d..bf384bf 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -28,6 +28,7 @@ module Hakyll.Core.Compiler.Internal
 import           Control.Applicative            (Alternative (..),
                                                  Applicative (..), (<$>))
 import           Control.Exception              (SomeException, handle)
+import           Control.Monad                  (forM_)
 import           Data.Monoid                    (Monoid (..))
 import           Data.Set                       (Set)
 import qualified Data.Set                       as S
@@ -38,7 +39,8 @@ import           Hakyll.Core.Configuration
 import           Hakyll.Core.Dependencies
 import           Hakyll.Core.Identifier
 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.Provider
 import           Hakyll.Core.Routes
@@ -82,7 +84,7 @@ instance Monoid CompilerWrite where
 --------------------------------------------------------------------------------
 data CompilerResult a where
     CompilerDone    :: a -> CompilerWrite -> CompilerResult a
-    CompilerError   :: String -> CompilerResult a
+    CompilerError   :: [String] -> CompilerResult a
     CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
 
 
@@ -126,7 +128,7 @@ instance Monad Compiler where
             CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
     {-# INLINE (>>=) #-}
 
-    fail = compilerThrow
+    fail = compilerThrow . return
     {-# INLINE fail #-}
 
 
@@ -150,13 +152,17 @@ 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 [show e]
 
 
 --------------------------------------------------------------------------------
 instance Alternative Compiler where
-    empty   = compilerThrow "Hakyll.Core.Compiler.Internal: empty alternative"
-    x <|> y = compilerCatch x (\_ -> y)
+    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
     {-# INLINE (<|>) #-}
 
 
@@ -173,13 +179,13 @@ compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
 
 
 --------------------------------------------------------------------------------
-compilerThrow :: String -> Compiler a
-compilerThrow e = Compiler $ \_ -> return $ CompilerError e
+compilerThrow :: [String] -> Compiler a
+compilerThrow es = Compiler $ \_ -> return $ CompilerError es
 {-# 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
     res <- x r
     case res of
diff --git a/src/Hakyll/Core/Compiler/Require.hs b/src/Hakyll/Core/Compiler/Require.hs
index ef3b11b..0811e5d 100644
--- a/src/Hakyll/Core/Compiler/Require.hs
+++ b/src/Hakyll/Core/Compiler/Require.hs
@@ -67,14 +67,14 @@ loadSnapshot id' snapshot = do
     universe <- compilerUniverse <$> compilerAsk
 
     -- Quick check for better error messages
-    when (id' `S.notMember` universe) $ compilerThrow notFound
+    when (id' `S.notMember` universe) $ fail notFound
 
     compilerTellDependencies [IdentifierDependency id']
     compilerResult $ CompilerRequire id' $ do
         result <- compilerUnsafeIO $ Store.get store (key id' snapshot)
         case result of
-            Store.NotFound      -> compilerThrow notFound
-            Store.WrongType e r -> compilerThrow $ wrongType e r
+            Store.NotFound      -> fail notFound
+            Store.WrongType e r -> fail $ wrongType e r
             Store.Found x       -> return $ Item id' x
   where
     notFound =
-- 
cgit v1.2.3