From 547030f53c27941eae0824f2a7226dc163f54b6e Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <m@jaspervdj.be>
Date: Wed, 14 Nov 2012 11:17:28 +0100
Subject: Refactor logger a bit
---
src/Hakyll/Core/Compiler.hs | 26 ++----
src/Hakyll/Core/Compiler/Internal.hs | 36 +++++++-
src/Hakyll/Core/Compiler/Require.hs | 4 +-
src/Hakyll/Core/Logger.hs | 166 +++++++++++++++++++----------------
src/Hakyll/Core/Runtime.hs | 47 ++++++----
src/Hakyll/Core/UnixFilter.hs | 6 +-
6 files changed, 166 insertions(+), 119 deletions(-)
(limited to 'src')
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
--------------------------------------------------------------------------------
--
cgit v1.2.3