diff options
Diffstat (limited to 'lib/Hakyll/Core')
| -rw-r--r-- | lib/Hakyll/Core/Compiler.hs | 37 | ||||
| -rw-r--r-- | lib/Hakyll/Core/Compiler/Internal.hs | 167 | ||||
| -rw-r--r-- | lib/Hakyll/Core/Compiler/Require.hs | 2 | ||||
| -rw-r--r-- | lib/Hakyll/Core/Logger.hs | 12 | ||||
| -rw-r--r-- | lib/Hakyll/Core/Provider/Metadata.hs | 5 | ||||
| -rw-r--r-- | lib/Hakyll/Core/Runtime.hs | 6 | ||||
| -rw-r--r-- | lib/Hakyll/Core/Store.hs | 40 |
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 -------------------------------------------------------------------------------- |