diff options
Diffstat (limited to 'src/Hakyll')
| -rw-r--r-- | src/Hakyll/Core/Logger.hs | 34 | ||||
| -rw-r--r-- | src/Hakyll/Core/Runtime.hs | 26 |
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 |