Improve error messages

7 files changed, 198 insertions, 71 deletions

diff --git a/lib/Hakyll/Core/Compiler.hs b/lib/Hakyll/Core/Compiler.hs
index 42b24d6..870d0af 100644
--- a/lib/Hakyll/Core/Compiler.hs
+++ b/lib/Hakyll/Core/Compiler.hs
@@ -24,13 +24,16 @@ module Hakyll.Core.Compiler
     , cached
     , unsafeCompiler
     , debugCompiler
+    , noResult
+    , withErrorMessage
     ) where
 
 
 --------------------------------------------------------------------------------
-import           Control.Monad                 (when, unless)
+import           Control.Monad                 (unless, when, (>=>))
 import           Data.Binary                   (Binary)
 import           Data.ByteString.Lazy          (ByteString)
+import qualified Data.List.NonEmpty            as NonEmpty
 import           Data.Typeable                 (Typeable)
 import           System.Environment            (getProgName)
 import           System.FilePath               (takeExtension)
@@ -62,6 +65,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 +145,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
@@ -177,12 +185,37 @@ cached name compiler = do
 
 
 --------------------------------------------------------------------------------
+-- | Run an IO computation without dependencies in a Compiler
 unsafeCompiler :: IO a -> Compiler a
 unsafeCompiler = compilerUnsafeIO
 
 
 --------------------------------------------------------------------------------
--- | Compiler for debugging purposes
+-- | Fail so that it is treated as non-defined in an @\$if()\$@ branching
+-- "Hakyll.Web.Template" macro, and alternative
+-- 'Hakyll.Web.Template.Context.Context's are tried
+--
+-- @since 4.13.0
+noResult :: String -> Compiler a
+noResult = compilerNoResult . return
+
+
+--------------------------------------------------------------------------------
+-- | Prepend an error line to the error, if there is one.  This allows you to
+-- add helpful context to error messages.
+--
+-- @since 4.13.0
+withErrorMessage :: String -> Compiler a -> Compiler a
+withErrorMessage x = do
+    compilerTry >=> either (compilerResult . CompilerError . prepend) return
+  where
+    prepend (CompilationFailure  es) = CompilationFailure  (x `NonEmpty.cons` es)
+    prepend (CompilationNoResult es) = CompilationNoResult (x : es)
+
+
+--------------------------------------------------------------------------------
+-- | Compiler for debugging purposes.
+-- Passes a message to the debug logger that is printed in verbose mode.
 debugCompiler :: String -> Compiler ()
 debugCompiler msg = do
     logger <- compilerLogger <$> compilerAsk
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
diff --git a/lib/Hakyll/Core/Logger.hs b/lib/Hakyll/Core/Logger.hs
index 6f950a6..9b7de17 100644
--- a/lib/Hakyll/Core/Logger.hs
+++ b/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
diff --git a/lib/Hakyll/Core/Provider/Metadata.hs b/lib/Hakyll/Core/Provider/Metadata.hs
index 6285ce1..c74627b 100644
--- a/lib/Hakyll/Core/Provider/Metadata.hs
+++ b/lib/Hakyll/Core/Provider/Metadata.hs
@@ -27,6 +27,7 @@ import           Hakyll.Core.Identifier
 import           Hakyll.Core.Metadata
 import           Hakyll.Core.Provider.Internal
 import           System.IO                     as IO
+import           System.IO.Error               (modifyIOError, ioeSetLocation)
 
 
 --------------------------------------------------------------------------------
@@ -51,7 +52,7 @@ loadMetadata p identifier = do
 --------------------------------------------------------------------------------
 loadMetadataHeader :: FilePath -> IO (Metadata, String)
 loadMetadataHeader fp = do
-    fileContent <- readFile fp
+    fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataHeader") $ readFile fp
     case parsePage fileContent of
         Right x   -> return x
         Left  err -> throwIO $ MetadataException fp err
@@ -60,7 +61,7 @@ loadMetadataHeader fp = do
 --------------------------------------------------------------------------------
 loadMetadataFile :: FilePath -> IO Metadata
 loadMetadataFile fp = do
-    fileContent <- B.readFile fp
+    fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataFile") $ B.readFile fp
     let errOrMeta = Yaml.decodeEither' fileContent
     either (fail . show) return errOrMeta
 
diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs
index 16a5d9e..922b676 100644
--- a/lib/Hakyll/Core/Runtime.hs
+++ b/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 compilerErrorMessages 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
diff --git a/lib/Hakyll/Core/Store.hs b/lib/Hakyll/Core/Store.hs
index 89d6047..f65a00b 100644
--- a/lib/Hakyll/Core/Store.hs
+++ b/lib/Hakyll/Core/Store.hs
@@ -16,7 +16,6 @@ module Hakyll.Core.Store
 
 
 --------------------------------------------------------------------------------
-import           Control.Exception    (IOException, handle)
 import qualified Crypto.Hash.MD5      as MD5
 import           Data.Binary          (Binary, decode, encodeFile)
 import qualified Data.ByteString      as B
@@ -32,6 +31,8 @@ import           System.Directory     (createDirectoryIfMissing)
 import           System.Directory     (doesFileExist, removeFile)
 import           System.FilePath      ((</>))
 import           System.IO            (IOMode (..), hClose, openFile)
+import           System.IO.Error      (catchIOError, ioeSetFileName,
+                                       ioeSetLocation, modifyIOError)
 
 
 --------------------------------------------------------------------------------
@@ -84,6 +85,14 @@ new inMemory directory = do
   where
     csize = Just 500
 
+--------------------------------------------------------------------------------
+withStore :: Store -> String -> (String -> FilePath -> IO a) -> [String] -> IO a
+withStore store loc run identifier = modifyIOError handle $ run key path
+  where
+    key = hash identifier
+    path = storeDirectory store </> key
+    handle e = e `ioeSetFileName` (path ++ " for " ++ intercalate "/" identifier)
+                 `ioeSetLocation` ("Store." ++ loc)
 
 --------------------------------------------------------------------------------
 -- | Auxiliary: add an item to the in-memory cache
@@ -124,17 +133,16 @@ cacheDelete (Store _ (Just lru)) key = do
 --------------------------------------------------------------------------------
 -- | Store an item
 set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
-set store identifier value = do
-    encodeFile (storeDirectory store </> key) value
+set store identifier value = withStore store "set" (\key path -> do
+    encodeFile path value
     cacheInsert store key value
-  where
-    key = hash identifier
+  ) identifier
 
 
 --------------------------------------------------------------------------------
 -- | Load an item
 get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
-get store identifier = do
+get store = withStore store "get" $ \key path -> do
     -- First check the in-memory map
     ref <- cacheLookup store key
     case ref of
@@ -146,17 +154,14 @@ get store identifier = do
                 then return NotFound
                 -- Found in the filesystem
                 else do
-                    v <- decodeClose
+                    v <- decodeClose path
                     cacheInsert store key v
                     return $ Found v
         -- Found in the in-memory map (or wrong type), just return
         s -> return s
   where
-    key  = hash identifier
-    path = storeDirectory store </> key
-
     -- 'decodeFile' from Data.Binary which closes the file ASAP
-    decodeClose = do
+    decodeClose path = do
         h   <- openFile path ReadMode
         lbs <- BL.hGetContents h
         BL.length lbs `seq` hClose h
@@ -166,28 +171,23 @@ get store identifier = do
 --------------------------------------------------------------------------------
 -- | Strict function
 isMember :: Store -> [String] -> IO Bool
-isMember store identifier = do
+isMember store = withStore store "isMember" $ \key path -> do
     inCache <- cacheIsMember store key
     if inCache then return True else doesFileExist path
-  where
-    key  = hash identifier
-    path = storeDirectory store </> key
 
 
 --------------------------------------------------------------------------------
 -- | Delete an item
 delete :: Store -> [String] -> IO ()
-delete store identifier = do
+delete store = withStore store "delete" $ \key path -> do
     cacheDelete store key
-    deleteFile $ storeDirectory store </> key
-  where
-    key  = hash identifier
+    deleteFile path
 
 
 --------------------------------------------------------------------------------
 -- | Delete a file unless it doesn't exist...
 deleteFile :: FilePath -> IO ()
-deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile
+deleteFile = (`catchIOError` \_ -> return ()) . removeFile
 
 
 --------------------------------------------------------------------------------