Better error messages

lib/Hakyll/Core/Compiler.hs

@@ -62,6 +62,7 @@ getUnderlyingExtension = takeExtension . toFilePath <$> getUnderlying
 
 
 --------------------------------------------------------------------------------
+-- | Create an item from the underlying identifier and a given value.
 makeItem :: a -> Compiler (Item a)
 makeItem x = do
     identifier <- getUnderlying
@@ -141,6 +142,10 @@ saveSnapshot snapshot item = do
 
 
 --------------------------------------------------------------------------------
+-- | Turn on caching for a compilation value to avoid recomputing it
+-- on subsequent Hakyll runs.
+-- The storage key consists of the underlying identifier of the compiled
+-- ressource and the given name.
 cached :: (Binary a, Typeable a)
        => String
        -> Compiler a

lib/Hakyll/Core/Compiler/Internal.hs

@@ -9,6 +9,7 @@ module Hakyll.Core.Compiler.Internal
       Snapshot
     , CompilerRead (..)
     , CompilerWrite (..)
+    , Reason (..)
     , CompilerResult (..)
     , Compiler (..)
     , runCompiler
@@ -17,11 +18,15 @@ module Hakyll.Core.Compiler.Internal
     , compilerTell
     , compilerAsk
     , compilerThrow
+    , compilerFailMessage
+    , compilerTry
     , compilerCatch
     , compilerResult
     , compilerUnsafeIO
+    , compilerDebugLog
 
       -- * Utilities
+    , getReason
     , compilerTellDependencies
     , compilerTellCacheHits
     ) where
@@ -31,7 +36,7 @@ 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.Set                       (Set)
 import qualified Data.Set                       as S
 
@@ -41,7 +46,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
@@ -71,7 +75,7 @@ data CompilerRead = CompilerRead
     , -- | Compiler store
       compilerStore      :: Store
     , -- | Logger
-      compilerLogger     :: Logger
+      compilerLogger     :: Logger.Logger
     }
 
 
@@ -89,11 +93,25 @@ instance Monoid CompilerWrite where
         CompilerWrite (d1 ++ d2) (h1 + h2)
 
 
+--------------------------------------------------------------------------------
+data Reason a
+    -- | An exception occured during compilation
+    = CompilationFailure a
+    -- | Absence of any result, most notably in template contexts
+    | NoCompilationResult a
+
+
+-- | Unwrap a `Reason`
+getReason :: Reason a -> a
+getReason (CompilationFailure x)  = x
+getReason (NoCompilationResult x) = x
+
+
 --------------------------------------------------------------------------------
 data CompilerResult a where
     CompilerDone     :: a -> CompilerWrite -> CompilerResult a
     CompilerSnapshot :: Snapshot -> Compiler a -> CompilerResult a
-    CompilerError    :: [String] -> CompilerResult a
+    CompilerError    :: Reason [String] -> CompilerResult a
     CompilerRequire  :: (Identifier, Snapshot) -> Compiler a -> CompilerResult a
 
 
@@ -112,8 +130,8 @@ 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 #-}
 
 
@@ -132,14 +150,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
@@ -164,25 +182,30 @@ instance MonadMetadata Compiler where
 --------------------------------------------------------------------------------
 instance MonadError [String] Compiler where
   throwError = compilerThrow
-  catchError = compilerCatch
+  catchError c = compilerCatch c . (. getReason)
 
 
 --------------------------------------------------------------------------------
 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]
 
 
 --------------------------------------------------------------------------------
 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   = compilerMissing []
+    x <|> y = x `compilerCatch` (\rx -> y `compilerCatch` (\ry ->
+        case (rx, ry) of
+          (CompilationFailure xs,  CompilationFailure ys)  -> compilerThrow $ xs ++ ys
+          (CompilationFailure xs,  NoCompilationResult ys) -> debug ys >> compilerThrow xs
+          (NoCompilationResult xs, CompilationFailure ys)  -> debug xs >> compilerThrow ys
+          (NoCompilationResult xs, NoCompilationResult ys) -> compilerMissing $ xs ++ ys
+        ))
+      where
+        debug = compilerDebugLog . map
+            ("Hakyll.Core.Compiler.Internal: Alternative fail suppressed: " ++)
     {-# INLINE (<|>) #-}
 
 
@@ -194,49 +217,70 @@ compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
 
 --------------------------------------------------------------------------------
 compilerTell :: CompilerWrite -> Compiler ()
-compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
+compilerTell = compilerResult . CompilerDone ()
 {-# INLINE compilerTell #-}
 
 
+--------------------------------------------------------------------------------
+-- | Put the result back in a compiler
+compilerResult :: CompilerResult a -> Compiler a
+compilerResult x = Compiler $ \_ -> return x
+{-# INLINE compilerResult #-}
+
+
 --------------------------------------------------------------------------------
 compilerThrow :: [String] -> Compiler a
-compilerThrow es = Compiler $ \_ -> return $ CompilerError es
-{-# INLINE compilerThrow #-}
+compilerThrow = compilerResult . CompilerError . CompilationFailure
+
+compilerMissing :: [String] -> Compiler a
+compilerMissing = compilerResult . CompilerError . NoCompilationResult
+
+compilerFailMessage :: String -> Compiler a
+compilerFailMessage = compilerMissing . return
 
 
 --------------------------------------------------------------------------------
-compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
+compilerTry :: Compiler a -> Compiler (Either (Reason [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 #-}
+
+--------------------------------------------------------------------------------
+-- compilerCatch f = compilerTry >=> either f return
+compilerCatch :: Compiler a -> (Reason [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 #-}
-
-
 --------------------------------------------------------------------------------
 compilerUnsafeIO :: IO a -> Compiler a
 compilerUnsafeIO io = Compiler $ \_ -> do
     x <- io
     return $ CompilerDone x mempty
 {-# INLINE compilerUnsafeIO #-}
 
+--------------------------------------------------------------------------------
+compilerDebugLog :: [String] -> Compiler ()
+compilerDebugLog ms = do
+  logger <- compilerLogger <$> compilerAsk
+  compilerUnsafeIO $ forM_ ms $ Logger.debug logger
 
 --------------------------------------------------------------------------------
 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 #-}
 

lib/Hakyll/Core/Logger.hs

@@ -18,6 +18,7 @@ import           Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
 import           Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
 import           Control.Monad           (forever)
 import           Control.Monad.Trans     (MonadIO, liftIO)
+import           Data.List               (intercalate)
 import           Prelude                 hiding (error)
 
 
@@ -79,7 +80,7 @@ string l v m
 
 --------------------------------------------------------------------------------
 error :: MonadIO m => Logger -> String -> m ()
-error l m = string l Error $ "  [ERROR] " ++ m
+error l m = string l Error $ "  [ERROR] " ++ indent m
 
 
 --------------------------------------------------------------------------------
@@ -89,9 +90,14 @@ header l = string l Message
 
 --------------------------------------------------------------------------------
 message :: MonadIO m => Logger -> String -> m ()
-message l m = string l Message $ "  " ++ m
+message l m = string l Message $ "  " ++ indent m
 
 
 --------------------------------------------------------------------------------
 debug :: MonadIO m => Logger -> String -> m ()
-debug l m = string l Debug $ "  [DEBUG] " ++ m
+debug l m = string l Debug $ "  [DEBUG] " ++ indent m
+
+
+--------------------------------------------------------------------------------
+indent :: String -> String
+indent = intercalate "\n    " . lines

lib/Hakyll/Core/Runtime.hs

@@ -199,9 +199,9 @@ chase trail id'
         result <- liftIO $ runCompiler compiler read'
         case result of
             -- Rethrow error
-            CompilerError [] -> throwError
-                "Compiler failed but no info given, try running with -v?"
-            CompilerError es -> throwError $ intercalate "; " es
+            CompilerError e -> throwError $ case getReason e of
+                [] -> "Compiler failed but no info given, try running with -v?"
+                es -> intercalate "; " es
 
             -- Signal that a snapshot was saved ->
             CompilerSnapshot snapshot c -> do

lib/Hakyll/Web/Feed.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 --------------------------------------------------------------------------------
 -- | A Module that allows easy rendering of RSS feeds.
@@ -41,20 +42,20 @@ import qualified Data.Text.Encoding          as T
 
 
 --------------------------------------------------------------------------------
-rssTemplate :: String
-rssTemplate = T.unpack $
+rssTemplate :: Item String
+rssTemplate = Item "templates/rss.xml" $ T.unpack $
     T.decodeUtf8 $(embedFile "data/templates/rss.xml")
 
-rssItemTemplate :: String
-rssItemTemplate = T.unpack $
+rssItemTemplate :: Item String
+rssItemTemplate = Item "templates/rss-item.xml" $ T.unpack $
     T.decodeUtf8 $(embedFile "data/templates/rss-item.xml")
 
-atomTemplate :: String
-atomTemplate = T.unpack $
+atomTemplate :: Item String
+atomTemplate = Item "templates/atom.xml" $ T.unpack $
     T.decodeUtf8 $(embedFile "data/templates/atom.xml")
 
-atomItemTemplate :: String
-atomItemTemplate = T.unpack $
+atomItemTemplate :: Item String
+atomItemTemplate = Item "templates/atom-item.xml" $ T.unpack $
     T.decodeUtf8 $(embedFile "data/templates/atom-item.xml")
 
 
@@ -76,15 +77,15 @@ data FeedConfiguration = FeedConfiguration
 
 --------------------------------------------------------------------------------
 -- | Abstract function to render any feed.
-renderFeed :: String                  -- ^ Default feed template
-           -> String                  -- ^ Default item template
+renderFeed :: Item String             -- ^ Default feed template
+           -> Item String             -- ^ Default item template
            -> FeedConfiguration       -- ^ Feed configuration
            -> Context String          -- ^ Context for the items
            -> [Item String]           -- ^ Input items
            -> Compiler (Item String)  -- ^ Resulting item
 renderFeed defFeed defItem config itemContext items = do
-    feedTpl <- readTemplateFile defFeed
-    itemTpl <- readTemplateFile defItem
+    feedTpl <- compileTemplateItem defFeed
+    itemTpl <- compileTemplateItem defItem
 
     protectedItems <- mapM (applyFilter protectCDATA) items
     body <- makeItem =<< applyTemplateList itemTpl itemContext' protectedItems
@@ -119,12 +120,8 @@ renderFeed defFeed defItem config itemContext items = do
     updatedField = field "updated" $ \_ -> case items of
         []      -> return "Unknown"
         (x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of
-            ListField _ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error"
             StringField s -> return s
-
-    readTemplateFile :: String -> Compiler Template
-    readTemplateFile value = pure $ template $ readTemplateElems value
-
+            _             -> fail "Hakyll.Web.Feed.renderFeed: Internal error"
 
 --------------------------------------------------------------------------------
 -- | Render an RSS feed with a number of items.

lib/Hakyll/Web/Template.hs

@@ -140,14 +140,13 @@
 --
 module Hakyll.Web.Template
     ( Template
-    , template
-    , readTemplateElems
     , templateBodyCompiler
     , templateCompiler
     , applyTemplate
     , loadAndApplyTemplate
     , applyAsTemplate
     , readTemplate
+    , compileTemplateItem
     , unsafeReadTemplateFile
     ) where