summaryrefslogtreecommitdiff
path: root/src/Hakyll
diff options
context:
space:
mode:
Diffstat (limited to 'src/Hakyll')
-rw-r--r--src/Hakyll/Core/Logger.hs34
-rw-r--r--src/Hakyll/Core/Runtime.hs26
2 files changed, 23 insertions, 37 deletions
diff --git a/src/Hakyll/Core/Logger.hs b/src/Hakyll/Core/Logger.hs
index bff4adc..17bff32 100644
--- a/src/Hakyll/Core/Logger.hs
+++ b/src/Hakyll/Core/Logger.hs
@@ -7,8 +7,7 @@ module Hakyll.Core.Logger
, flush
, error
, header
- , item
- , subitem
+ , message
, debug
) where
@@ -20,14 +19,12 @@ 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)
@@ -40,7 +37,6 @@ data Logger = Logger
, loggerSync :: MVar () -- ^ Used for sync on quit
, loggerSink :: String -> IO () -- ^ Out sink
, loggerVerbosity :: Verbosity -- ^ Verbosity
- , loggerColumns :: Int -- ^ Preferred number of columns
}
@@ -49,7 +45,7 @@ data Logger = Logger
new :: Verbosity -> (String -> IO ()) -> IO Logger
new vbty sink = do
logger <- Logger <$>
- newChan <*> newEmptyMVar <*> pure sink <*> pure vbty <*> pure 80
+ newChan <*> newEmptyMVar <*> pure sink <*> pure vbty
_ <- forkIO $ loggerThread logger
return logger
where
@@ -84,35 +80,19 @@ 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] " ++ m
--------------------------------------------------------------------------------
header :: MonadIO m => Logger -> String -> m ()
-header l = string l Header
+header l = string l Message
--------------------------------------------------------------------------------
-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
+message :: MonadIO m => Logger -> String -> m ()
+message l m = string l Message $ " " ++ m
--------------------------------------------------------------------------------
debug :: MonadIO m => Logger -> String -> m ()
-debug l m = string l Debug $ " DEBUG: " ++ m
+debug l m = string l Debug $ " [DEBUG] " ++ m
diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs
index 9f4fc7a..23c24b1 100644
--- a/src/Hakyll/Core/Runtime.hs
+++ b/src/Hakyll/Core/Runtime.hs
@@ -43,13 +43,13 @@ run :: Configuration -> Rules a -> IO RuleSet
run configuration rules = do
-- Initialization
logger <- Logger.new Logger.Debug putStrLn
- Logger.header logger "Initialising"
- Logger.item logger ["Creating store"]
+ Logger.header logger "Initialising..."
+ Logger.message logger "Creating store..."
store <- Store.new (inMemoryCache configuration) $
storeDirectory configuration
- Logger.item logger ["Creating provider"]
+ Logger.message logger "Creating provider..."
provider <- newResourceProvider store (ignoreFile configuration) "."
- Logger.item logger ["Running rules"]
+ Logger.message logger "Running rules..."
ruleSet <- runRules rules provider
-- Get old facts
@@ -123,6 +123,7 @@ build = do
--------------------------------------------------------------------------------
scheduleOutOfDate :: Runtime ()
scheduleOutOfDate = do
+ logger <- runtimeLogger <$> ask
provider <- runtimeProvider <$> ask
universe <- runtimeUniverse <$> ask
facts <- runtimeFacts <$> get
@@ -131,10 +132,13 @@ scheduleOutOfDate = do
let identifiers = map fst universe
modified <- fmap S.fromList $ flip filterM identifiers $
liftIO . resourceModified provider
- let (ood, facts', _) = outOfDate identifiers modified facts
- todo' = M.fromList
+ let (ood, facts', msgs) = outOfDate identifiers modified facts
+ todo' = M.fromList
[(id', c) | (id', c) <- universe, id' `S.member` ood]
+ -- Print messages
+ mapM_ (Logger.debug logger) msgs
+
-- Update facts and todo items
modify $ \s -> s
{ runtimeDone = runtimeDone s `S.union`
@@ -187,18 +191,20 @@ chase trail id'
CompilerDone (CompiledItem compiled) cwrite -> do
let facts = compilerDependencies cwrite
cacheHits
- | compilerCacheHits cwrite <= 0 = "modified"
- | otherwise = "cache hit"
- Logger.item logger [show id', cacheHits]
+ | compilerCacheHits cwrite <= 0 = "updated"
+ | otherwise = "cached "
+
+ -- Print some info
+ Logger.message logger $ cacheHits ++ " " ++ show id'
-- Write if necessary
case runRoutes routes id' of
Nothing -> return ()
Just url -> do
let path = destinationDirectory config </> url
- Logger.subitem logger ["-> " ++ path]
liftIO $ makeDirectories path
liftIO $ write path compiled
+ Logger.debug logger $ "Routed to " ++ path
-- Save! (For require)
liftIO $ save store id' compiled