diff options
Diffstat (limited to 'src/Hakyll')
| -rw-r--r-- | src/Hakyll/Core/Compiler.hs | 26 | ||||
| -rw-r--r-- | src/Hakyll/Core/Compiler/Internal.hs | 36 | ||||
| -rw-r--r-- | src/Hakyll/Core/Compiler/Require.hs | 4 | ||||
| -rw-r--r-- | src/Hakyll/Core/Logger.hs | 166 | ||||
| -rw-r--r-- | src/Hakyll/Core/Runtime.hs | 47 | ||||
| -rw-r--r-- | src/Hakyll/Core/UnixFilter.hs | 6 |
6 files changed, 166 insertions, 119 deletions
diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 67de7c8..e1b33d2 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -16,8 +16,7 @@ module Hakyll.Core.Compiler , requireAll , cached , unsafeCompiler - , logCompiler - , timedCompiler + , debugCompiler ) where @@ -35,7 +34,7 @@ import Hakyll.Core.Compiler.Internal import Hakyll.Core.Compiler.Require import Hakyll.Core.Dependencies import Hakyll.Core.Identifier -import Hakyll.Core.Logger +import Hakyll.Core.Logger as Logger import Hakyll.Core.Metadata import Hakyll.Core.ResourceProvider import Hakyll.Core.Routes @@ -72,7 +71,7 @@ getMetadata = getIdentifier >>= getMetadataFor getMetadataFor :: Identifier -> Compiler Metadata getMetadataFor identifier = do provider <- compilerProvider <$> compilerAsk - compilerTell [IdentifierDependency identifier] + compilerTellDependencies [IdentifierDependency identifier] compilerUnsafeIO $ resourceMetadata provider identifier @@ -116,19 +115,17 @@ cached :: (Binary a, Typeable a, Writable a) -> Compiler a -> Compiler a cached name compiler = do - logger <- compilerLogger <$> compilerAsk id' <- compilerIdentifier <$> compilerAsk store <- compilerStore <$> compilerAsk provider <- compilerProvider <$> compilerAsk modified <- compilerUnsafeIO $ resourceModified provider id' - compilerUnsafeIO $ report logger $ - "Checking cache: " ++ if modified then "modified" else "OK" if modified then do x <- compiler compilerUnsafeIO $ Store.set store [name, show id'] x return x else do + compilerTellCacheHits 1 x <- compilerUnsafeIO $ Store.get store [name, show id'] progName <- compilerUnsafeIO getProgName case x of Store.Found x' -> return x' @@ -146,16 +143,7 @@ unsafeCompiler = compilerUnsafeIO -------------------------------------------------------------------------------- -- | Compiler for debugging purposes -logCompiler :: String -> Compiler () -logCompiler msg = do +debugCompiler :: String -> Compiler () +debugCompiler msg = do logger <- compilerLogger <$> compilerAsk - compilerUnsafeIO $ report logger msg - - --------------------------------------------------------------------------------- --- | Log and time a compiler -timedCompiler :: String -- ^ Message - -> Compiler a -- ^ Compiler to time - -> Compiler a -- ^ Resulting compiler -timedCompiler msg compiler = Compiler $ \r -> - timed (compilerLogger r) msg $ unCompiler compiler r + compilerUnsafeIO $ Logger.debug logger msg diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index 5b7fb51..5987eb8 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -3,16 +3,24 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Compiler.Internal - ( CompilerRead (..) + ( -- * Types + CompilerRead (..) + , CompilerWrite (..) , CompilerResult (..) , Compiler (..) , runCompiler + + -- * Core operations , compilerTell , compilerAsk , compilerThrow , compilerCatch , compilerResult , compilerUnsafeIO + + -- * Utilities + , compilerTellDependencies + , compilerTellCacheHits ) where @@ -20,7 +28,7 @@ module Hakyll.Core.Compiler.Internal import Control.Applicative (Alternative (..), Applicative (..)) import Control.Exception (SomeException, handle) -import Data.Monoid (mappend, mempty) +import Data.Monoid (Monoid (..)) -------------------------------------------------------------------------------- @@ -51,7 +59,17 @@ data CompilerRead = CompilerRead -------------------------------------------------------------------------------- -type CompilerWrite = [Dependency] +data CompilerWrite = CompilerWrite + { compilerDependencies :: [Dependency] + , compilerCacheHits :: Int + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance Monoid CompilerWrite where + mempty = CompilerWrite [] 0 + mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) = + CompilerWrite (d1 ++ d2) (h1 + h2) -------------------------------------------------------------------------------- @@ -165,3 +183,15 @@ compilerUnsafeIO io = Compiler $ \_ -> do x <- io return $ CompilerDone x mempty {-# INLINE compilerUnsafeIO #-} + + +-------------------------------------------------------------------------------- +compilerTellDependencies :: [Dependency] -> Compiler () +compilerTellDependencies ds = compilerTell mempty {compilerDependencies = ds} +{-# INLINE compilerTellDependencies #-} + + +-------------------------------------------------------------------------------- +compilerTellCacheHits :: Int -> Compiler () +compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch} +{-# INLINE compilerTellCacheHits #-} diff --git a/src/Hakyll/Core/Compiler/Require.hs b/src/Hakyll/Core/Compiler/Require.hs index 5838852..861c1f1 100644 --- a/src/Hakyll/Core/Compiler/Require.hs +++ b/src/Hakyll/Core/Compiler/Require.hs @@ -31,7 +31,7 @@ require :: (Binary a, Typeable a) => Identifier -> Compiler a require id' = do store <- compilerStore <$> compilerAsk - compilerTell [IdentifierDependency id'] + compilerTellDependencies [IdentifierDependency id'] compilerResult $ CompilerRequire id' $ do result <- compilerUnsafeIO $ Store.get store (key id') case result of @@ -54,7 +54,7 @@ requireAll :: (Binary a, Typeable a) => Pattern -> Compiler [a] requireAll pattern = do universe <- compilerUniverse <$> compilerAsk let matching = filterMatches pattern universe - compilerTell [PatternDependency pattern matching] + compilerTellDependencies [PatternDependency pattern matching] mapM require matching diff --git a/src/Hakyll/Core/Logger.hs b/src/Hakyll/Core/Logger.hs index fb9b276..bff4adc 100644 --- a/src/Hakyll/Core/Logger.hs +++ b/src/Hakyll/Core/Logger.hs @@ -1,40 +1,56 @@ +-------------------------------------------------------------------------------- -- | Produce pretty, thread-safe logs --- -{-# LANGUAGE BangPatterns #-} module Hakyll.Core.Logger - ( Logger - , makeLogger - , flushLogger - , section - , timed - , report - , thrown + ( Verbosity (..) + , Logger + , new + , flush + , error + , header + , item + , subitem + , debug ) where -import Control.Monad (forever) -import Control.Monad.Trans (MonadIO, liftIO) -import Control.Applicative (pure, (<$>), (<*>)) -import Control.Concurrent (forkIO) -import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar) -import Text.Printf (printf) -import Data.Time (getCurrentTime, diffUTCTime) +-------------------------------------------------------------------------------- +import Control.Applicative (pure, (<$>), (<*>)) +import Control.Concurrent (forkIO) +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) + +-------------------------------------------------------------------------------- +data Verbosity + = Error + | Header + | Message + | Debug + deriving (Eq, Ord, Show) + + +-------------------------------------------------------------------------------- -- | Logger structure. Very complicated. --- data Logger = Logger - { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end - , loggerSync :: MVar () -- ^ Used for sync on quit - , loggerSink :: String -> IO () -- ^ Out sink + { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end + , loggerSync :: MVar () -- ^ Used for sync on quit + , loggerSink :: String -> IO () -- ^ Out sink + , loggerVerbosity :: Verbosity -- ^ Verbosity + , loggerColumns :: Int -- ^ Preferred number of columns } + +-------------------------------------------------------------------------------- -- | Create a new logger --- -makeLogger :: (String -> IO ()) -> IO Logger -makeLogger sink = do - logger <- Logger <$> newChan <*> newEmptyMVar <*> pure sink - _ <- forkIO $ loggerThread logger +new :: Verbosity -> (String -> IO ()) -> IO Logger +new vbty sink = do + logger <- Logger <$> + newChan <*> newEmptyMVar <*> pure sink <*> pure vbty <*> pure 80 + _ <- forkIO $ loggerThread logger return logger where loggerThread logger = forever $ do @@ -45,56 +61,58 @@ makeLogger sink = do -- Print and continue Just m -> loggerSink logger m + +-------------------------------------------------------------------------------- -- | Flush the logger (blocks until flushed) --- -flushLogger :: Logger -> IO () -flushLogger logger = do +flush :: Logger -> IO () +flush logger = do writeChan (loggerChan logger) Nothing () <- takeMVar $ loggerSync logger return () --- | Send a raw message to the logger --- -message :: Logger -> String -> IO () -message logger = writeChan (loggerChan logger) . Just - --- | Start a section in the log --- -section :: MonadIO m - => Logger -- ^ Logger - -> String -- ^ Section name - -> m () -- ^ No result -section logger = liftIO . message logger - --- | Execute a monadic action and log the duration --- -timed :: MonadIO m - => Logger -- ^ Logger - -> String -- ^ Message - -> m a -- ^ Action - -> m a -- ^ Timed and logged action -timed logger msg action = do - start <- liftIO getCurrentTime - !result <- action - stop <- liftIO getCurrentTime - let diff = fromEnum $ diffUTCTime stop start - ms = diff `div` 10 ^ (9 :: Int) - formatted = printf " [%4dms] %s" ms msg - liftIO $ message logger formatted - return result - --- | Log something at the same level as 'timed', but without the timing --- -report :: MonadIO m - => Logger -- ^ Logger - -> String -- ^ Message - -> m () -- ^ No result -report logger msg = liftIO $ message logger $ " [ ] " ++ msg - --- | Log an error that was thrown in the compilation phase --- -thrown :: MonadIO m - => Logger -- ^ Logger - -> String -- ^ Message - -> m () -- ^ No result -thrown logger msg = liftIO $ message logger $ " [ ERROR] " ++ msg + +-------------------------------------------------------------------------------- +string :: MonadIO m + => Logger -- ^ Logger + -> Verbosity -- ^ Verbosity of the string + -> String -- ^ Section name + -> m () -- ^ No result +string l v m + | loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m) + | otherwise = return () + + +-------------------------------------------------------------------------------- +error :: MonadIO m => Logger -> String -> m () +error l m = string l Error $ "ERROR: " ++ m + + +-------------------------------------------------------------------------------- +header :: MonadIO m => Logger -> String -> m () +header l = string l Header + + +-------------------------------------------------------------------------------- +item :: MonadIO m => Logger -> [String] -> m () +item = itemWith 2 + + +-------------------------------------------------------------------------------- +subitem :: MonadIO m => Logger -> [String] -> m () +subitem = itemWith 4 + + +-------------------------------------------------------------------------------- +itemWith :: MonadIO m => Int -> Logger -> [String] -> m () +itemWith _ _ [] = return () +itemWith i l [x] = string l Message $ replicate i ' ' ++ x +itemWith i l (x : ys) = string l Message $ indent ++ x ++ spaces ++ ys' + where + indent = replicate i ' ' + spaces = replicate (max 1 $ loggerColumns l - i - length x - length ys') ' ' + ys' = intercalate ", " ys + + +-------------------------------------------------------------------------------- +debug :: MonadIO m => Logger -> String -> m () +debug l m = string l Debug $ " DEBUG: " ++ m diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs index 2ed3d2c..9f4fc7a 100644 --- a/src/Hakyll/Core/Runtime.hs +++ b/src/Hakyll/Core/Runtime.hs @@ -27,7 +27,8 @@ import Hakyll.Core.Compiler.Require import Hakyll.Core.Configuration import Hakyll.Core.Dependencies import Hakyll.Core.Identifier -import Hakyll.Core.Logger +import Hakyll.Core.Logger (Logger) +import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.ResourceProvider import Hakyll.Core.Routes import Hakyll.Core.Rules.Internal @@ -41,13 +42,15 @@ import Hakyll.Core.Writable run :: Configuration -> Rules a -> IO RuleSet run configuration rules = do -- Initialization - logger <- makeLogger putStrLn - section logger "Initialising" - store <- timed logger "Creating store" $ - Store.new (inMemoryCache configuration) $ storeDirectory configuration - provider <- timed logger "Creating provider" $ - newResourceProvider store (ignoreFile configuration) "." - ruleSet <- timed logger "Running rules" $ runRules rules provider + logger <- Logger.new Logger.Debug putStrLn + Logger.header logger "Initialising" + Logger.item logger ["Creating store"] + store <- Store.new (inMemoryCache configuration) $ + storeDirectory configuration + Logger.item logger ["Creating provider"] + provider <- newResourceProvider store (ignoreFile configuration) "." + Logger.item logger ["Running rules"] + ruleSet <- runRules rules provider -- Get old facts mOldFacts <- Store.get store factsKey @@ -73,11 +76,11 @@ run configuration rules = do -- Run the program and fetch the resulting state result <- runErrorT $ runRWST build read' state case result of - Left e -> thrown logger e + Left e -> Logger.error logger e Right (_, s, _) -> Store.set store factsKey $ runtimeFacts s -- Flush and return - flushLogger logger + Logger.flush logger return ruleSet where factsKey = ["Hakyll.Core.Runtime.run", "facts"] @@ -109,23 +112,25 @@ type Runtime a = RWST RuntimeRead () RuntimeState (ErrorT String IO) a -------------------------------------------------------------------------------- build :: Runtime () build = do + logger <- runtimeLogger <$> ask + Logger.header logger "Checking for out-of-date items" scheduleOutOfDate + Logger.header logger "Compiling" pickAndChase + Logger.header logger "Success" -------------------------------------------------------------------------------- scheduleOutOfDate :: Runtime () scheduleOutOfDate = do - logger <- runtimeLogger <$> ask provider <- runtimeProvider <$> ask universe <- runtimeUniverse <$> ask facts <- runtimeFacts <$> get todo <- runtimeTodo <$> get let identifiers = map fst universe - modified <- timed logger "Checking for modified items" $ - fmap S.fromList $ flip filterM identifiers $ - liftIO . resourceModified provider + modified <- fmap S.fromList $ flip filterM identifiers $ + liftIO . resourceModified provider let (ood, facts', _) = outOfDate identifiers modified facts todo' = M.fromList [(id', c) | (id', c) <- universe, id' `S.member` ood] @@ -163,7 +168,6 @@ chase trail id' store <- runtimeStore <$> ask config <- runtimeConfiguration <$> ask - section logger $ "Processing " ++ show id' let compiler = todo M.! id' read' = CompilerRead { compilerIdentifier = id' @@ -174,18 +178,25 @@ chase trail id' , compilerLogger = logger } - result <- timed logger "Compiling" $ liftIO $ runCompiler compiler read' + result <- liftIO $ runCompiler compiler read' case result of -- Rethrow error CompilerError e -> throwError e -- Huge success - CompilerDone (CompiledItem compiled) facts -> do + CompilerDone (CompiledItem compiled) cwrite -> do + let facts = compilerDependencies cwrite + cacheHits + | compilerCacheHits cwrite <= 0 = "modified" + | otherwise = "cache hit" + Logger.item logger [show id', cacheHits] + -- Write if necessary case runRoutes routes id' of Nothing -> return () - Just url -> timed logger ("Routing to " ++ url) $ do + Just url -> do let path = destinationDirectory config </> url + Logger.subitem logger ["-> " ++ path] liftIO $ makeDirectories path liftIO $ write path compiled diff --git a/src/Hakyll/Core/UnixFilter.hs b/src/Hakyll/Core/UnixFilter.hs index e86c58a..ce1e9db 100644 --- a/src/Hakyll/Core/UnixFilter.hs +++ b/src/Hakyll/Core/UnixFilter.hs @@ -75,9 +75,9 @@ unixFilterWith :: (Handle -> i -> IO ()) -- ^ Writer -> [String] -- ^ Program args -> i -- ^ Program input -> Compiler o -- ^ Program output -unixFilterWith writer reader programName args input = - timedCompiler ("Executing external program " ++ programName) $ - unsafeCompiler $ unixFilterIO writer reader programName args input +unixFilterWith writer reader programName args input = do + debugCompiler ("Executing external program " ++ programName) + unsafeCompiler $ unixFilterIO writer reader programName args input -------------------------------------------------------------------------------- |