547030f · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

Refactor logger a bit

547030fJasper Van der Jeugt14 years ago

src/Hakyll/Core/Compiler.hs+7−19

compare with master

unifiedsplit

@@ -16,8 +16,7 @@ module Hakyll.Core.Compiler

16 , requireAll

17 , cached

18 , unsafeCompiler

19− , logCompiler

19+ , debugCompiler

20− , timedCompiler

21 ) where

20 ) where

@@ -35,7 +34,7 @@ import Hakyll.Core.Compiler.Internal

35import Hakyll.Core.Compiler.Require

34import Hakyll.Core.Compiler.Require

36import Hakyll.Core.Dependencies

35import Hakyll.Core.Dependencies

37import Hakyll.Core.Identifier

36import Hakyll.Core.Identifier

38−import Hakyll.Core.Logger

37+import Hakyll.Core.Logger as Logger

39import Hakyll.Core.Metadata

38import Hakyll.Core.Metadata

40import Hakyll.Core.ResourceProvider

39import Hakyll.Core.ResourceProvider

41import Hakyll.Core.Routes

40import Hakyll.Core.Routes

@@ -72,7 +71,7 @@ getMetadata = getIdentifier >>= getMetadataFor

72getMetadataFor :: Identifier -> Compiler Metadata

71getMetadataFor :: Identifier -> Compiler Metadata

73getMetadataFor identifier = do

72getMetadataFor identifier = do

74 provider <- compilerProvider <$> compilerAsk

73 provider <- compilerProvider <$> compilerAsk

75− compilerTell [IdentifierDependency identifier]

74+ compilerTellDependencies [IdentifierDependency identifier]

76 compilerUnsafeIO $ resourceMetadata provider identifier

75 compilerUnsafeIO $ resourceMetadata provider identifier

@@ -116,19 +115,17 @@ cached :: (Binary a, Typeable a, Writable a)

116 -> Compiler a

115 -> Compiler a

117 -> Compiler a

116 -> Compiler a

118cached name compiler = do

117cached name compiler = do

119− logger <- compilerLogger <$> compilerAsk

120 id' <- compilerIdentifier <$> compilerAsk

118 id' <- compilerIdentifier <$> compilerAsk

121 store <- compilerStore <$> compilerAsk

119 store <- compilerStore <$> compilerAsk

122 provider <- compilerProvider <$> compilerAsk

120 provider <- compilerProvider <$> compilerAsk

123 modified <- compilerUnsafeIO $ resourceModified provider id'

121 modified <- compilerUnsafeIO $ resourceModified provider id'

124− compilerUnsafeIO $ report logger $

125− "Checking cache: " ++ if modified then "modified" else "OK"

126 if modified

122 if modified

127 then do

123 then do

128 x <- compiler

124 x <- compiler

129 compilerUnsafeIO $ Store.set store [name, show id'] x

125 compilerUnsafeIO $ Store.set store [name, show id'] x

130 return x

126 return x

131 else do

127 else do

128+ compilerTellCacheHits 1

132 x <- compilerUnsafeIO $ Store.get store [name, show id']

129 x <- compilerUnsafeIO $ Store.get store [name, show id']

133 progName <- compilerUnsafeIO getProgName

130 progName <- compilerUnsafeIO getProgName

134 case x of Store.Found x' -> return x'

131 case x of Store.Found x' -> return x'

@@ -146,16 +143,7 @@ unsafeCompiler = compilerUnsafeIO

146

143

147--------------------------------------------------------------------------------

144--------------------------------------------------------------------------------

148-- | Compiler for debugging purposes

145-- | Compiler for debugging purposes

149−logCompiler :: String -> Compiler ()

146+debugCompiler :: String -> Compiler ()

150−logCompiler msg = do

147+debugCompiler msg = do

151 logger <- compilerLogger <$> compilerAsk

148 logger <- compilerLogger <$> compilerAsk

152− compilerUnsafeIO $ report logger msg

149+ compilerUnsafeIO $ Logger.debug logger msg

153−

154−

155−--------------------------------------------------------------------------------

156−-- | Log and time a compiler

157−timedCompiler :: String -- ^ Message

158− -> Compiler a -- ^ Compiler to time

159− -> Compiler a -- ^ Resulting compiler

160−timedCompiler msg compiler = Compiler $ \r ->

161− timed (compilerLogger r) msg $ unCompiler compiler r

src/Hakyll/Core/Compiler/Internal.hs+33−3

@@ -3,16 +3,24 @@

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5module Hakyll.Core.Compiler.Internal

6+ ( -- * Types

6− ( CompilerRead (..)

7+ CompilerRead (..)

8+ , CompilerWrite (..)

7 , CompilerResult (..)

9 , CompilerResult (..)

8 , Compiler (..)

10 , Compiler (..)

9 , runCompiler

11 , runCompiler

12+

13+ -- * Core operations

10 , compilerTell

14 , compilerTell

11 , compilerAsk

15 , compilerAsk

12 , compilerThrow

16 , compilerThrow

13 , compilerCatch

17 , compilerCatch

14 , compilerResult

18 , compilerResult

15 , compilerUnsafeIO

19 , compilerUnsafeIO

20+

21+ -- * Utilities

22+ , compilerTellDependencies

23+ , compilerTellCacheHits

16 ) where

24 ) where

@@ -20,7 +28,7 @@ module Hakyll.Core.Compiler.Internal

20import Control.Applicative (Alternative (..),

28import Control.Applicative (Alternative (..),

21 Applicative (..))

29 Applicative (..))

22import Control.Exception (SomeException, handle)

30import Control.Exception (SomeException, handle)

23−import Data.Monoid (mappend, mempty)

31+import Data.Monoid (Monoid (..))

26--------------------------------------------------------------------------------

34--------------------------------------------------------------------------------

@@ -51,7 +59,17 @@ data CompilerRead = CompilerRead

53--------------------------------------------------------------------------------

61--------------------------------------------------------------------------------

54−type CompilerWrite = [Dependency]

62+data CompilerWrite = CompilerWrite

63+ { compilerDependencies :: [Dependency]

64+ , compilerCacheHits :: Int

65+ } deriving (Show)

66+

67+

68+--------------------------------------------------------------------------------

69+instance Monoid CompilerWrite where

70+ mempty = CompilerWrite [] 0

71+ mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =

72+ CompilerWrite (d1 ++ d2) (h1 + h2)

57--------------------------------------------------------------------------------

75--------------------------------------------------------------------------------

@@ -165,3 +183,15 @@ compilerUnsafeIO io = Compiler $ \_ -> do

165 x <- io

183 x <- io

166 return $ CompilerDone x mempty

184 return $ CompilerDone x mempty

167{-# INLINE compilerUnsafeIO #-}

185{-# INLINE compilerUnsafeIO #-}

186+

187+

188+--------------------------------------------------------------------------------

189+compilerTellDependencies :: [Dependency] -> Compiler ()

190+compilerTellDependencies ds = compilerTell mempty {compilerDependencies = ds}

191+{-# INLINE compilerTellDependencies #-}

192+

193+

194+--------------------------------------------------------------------------------

195+compilerTellCacheHits :: Int -> Compiler ()

196+compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch}

197+{-# INLINE compilerTellCacheHits #-}

src/Hakyll/Core/Compiler/Require.hs+2−2

@@ -31,7 +31,7 @@ require :: (Binary a, Typeable a) => Identifier -> Compiler a

31require id' = do

32 store <- compilerStore <$> compilerAsk

34− compilerTell [IdentifierDependency id']

34+ compilerTellDependencies [IdentifierDependency id']

35 compilerResult $ CompilerRequire id' $ do

36 result <- compilerUnsafeIO $ Store.get store (key id')

37 case result of

@@ -54,7 +54,7 @@ requireAll :: (Binary a, Typeable a) => Pattern -> Compiler [a]

54requireAll pattern = do

55 universe <- compilerUniverse <$> compilerAsk

56 let matching = filterMatches pattern universe

57− compilerTell [PatternDependency pattern matching]

57+ compilerTellDependencies [PatternDependency pattern matching]

58 mapM require matching

src/Hakyll/Core/Logger.hs+92−74

@@ -1,40 +1,56 @@

1+--------------------------------------------------------------------------------

1-- | Produce pretty, thread-safe logs

2-- | Produce pretty, thread-safe logs

2−--

3−{-# LANGUAGE BangPatterns #-}

4module Hakyll.Core.Logger

3module Hakyll.Core.Logger

4+ ( Verbosity (..)

5− ( Logger

5+ , Logger

6− , makeLogger

6+ , new

7− , flushLogger

7+ , flush

8− , section

8+ , error

9− , timed

9+ , header

10− , report

10+ , item

11− , thrown

11+ , subitem

12+ , debug

12 ) where

13 ) where

14−import Control.Monad (forever)

15−import Control.Monad.Trans (MonadIO, liftIO)

16−import Control.Applicative (pure, (<$>), (<*>))

17−import Control.Concurrent (forkIO)

18−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

19−import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)

20−import Text.Printf (printf)

22−import Data.Time (getCurrentTime, diffUTCTime)

16+--------------------------------------------------------------------------------

17+import Control.Applicative (pure, (<$>), (<*>))

18+import Control.Concurrent (forkIO)

19+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

20+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)

21+import Control.Monad (forever)

22+import Control.Monad.Trans (MonadIO, liftIO)

23+import Data.List (intercalate)

24+import Prelude hiding (error)

26+

27+--------------------------------------------------------------------------------

28+data Verbosity

29+ = Error

30+ | Header

31+ | Message

32+ | Debug

33+ deriving (Eq, Ord, Show)

34+

35+

36+--------------------------------------------------------------------------------

24-- | Logger structure. Very complicated.

37-- | Logger structure. Very complicated.

25−--

26data Logger = Logger

38data Logger = Logger

27− { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end

39+ { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end

28− , loggerSync :: MVar () -- ^ Used for sync on quit

40+ , loggerSync :: MVar () -- ^ Used for sync on quit

29− , loggerSink :: String -> IO () -- ^ Out sink

41+ , loggerSink :: String -> IO () -- ^ Out sink

42+ , loggerVerbosity :: Verbosity -- ^ Verbosity

43+ , loggerColumns :: Int -- ^ Preferred number of columns

30 }

44 }

46+

47+--------------------------------------------------------------------------------

32-- | Create a new logger

48-- | Create a new logger

33−--

34−makeLogger :: (String -> IO ()) -> IO Logger

49+new :: Verbosity -> (String -> IO ()) -> IO Logger

35−makeLogger sink = do

50+new vbty sink = do

51+ logger <- Logger <$>

36− logger <- Logger <$> newChan <*> newEmptyMVar <*> pure sink

52+ newChan <*> newEmptyMVar <*> pure sink <*> pure vbty <*> pure 80

37− _ <- forkIO $ loggerThread logger

53+ _ <- forkIO $ loggerThread logger

38 return logger

54 return logger

39 where

55 where

40 loggerThread logger = forever $ do

56 loggerThread logger = forever $ do

@@ -45,56 +61,58 @@ makeLogger sink = do

45 -- Print and continue

61 -- Print and continue

46 Just m -> loggerSink logger m

62 Just m -> loggerSink logger m

64+

65+--------------------------------------------------------------------------------

48-- | Flush the logger (blocks until flushed)

66-- | Flush the logger (blocks until flushed)

49−--

50−flushLogger :: Logger -> IO ()

67+flush :: Logger -> IO ()

51−flushLogger logger = do

68+flush logger = do

52 writeChan (loggerChan logger) Nothing

69 writeChan (loggerChan logger) Nothing

53 () <- takeMVar $ loggerSync logger

70 () <- takeMVar $ loggerSync logger

54 return ()

71 return ()

56−-- | Send a raw message to the logger

73+

57−--

74+--------------------------------------------------------------------------------

58−message :: Logger -> String -> IO ()

75+string :: MonadIO m

76+ => Logger -- ^ Logger

77+ -> Verbosity -- ^ Verbosity of the string

78+ -> String -- ^ Section name

79+ -> m () -- ^ No result

80+string l v m

59−message logger = writeChan (loggerChan logger) . Just

81+ | loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m)

60−

82+ | otherwise = return ()

61−-- | Start a section in the log

83+

62−--

84+

63−section :: MonadIO m

85+--------------------------------------------------------------------------------

64− => Logger -- ^ Logger

86+error :: MonadIO m => Logger -> String -> m ()

65− -> String -- ^ Section name

87+error l m = string l Error $ "ERROR: " ++ m

66− -> m () -- ^ No result

88+

67−section logger = liftIO . message logger

89+

68−

90+--------------------------------------------------------------------------------

69−-- | Execute a monadic action and log the duration

70−--

71−timed :: MonadIO m

91+header :: MonadIO m => Logger -> String -> m ()

72− => Logger -- ^ Logger

92+header l = string l Header

73− -> String -- ^ Message

93+

74− -> m a -- ^ Action

94+

75− -> m a -- ^ Timed and logged action

95+--------------------------------------------------------------------------------

76−timed logger msg action = do

96+item :: MonadIO m => Logger -> [String] -> m ()

77− start <- liftIO getCurrentTime

97+item = itemWith 2

78− !result <- action

98+

79− stop <- liftIO getCurrentTime

99+

80− let diff = fromEnum $ diffUTCTime stop start

100+--------------------------------------------------------------------------------

81− ms = diff `div` 10 ^ (9 :: Int)

101+subitem :: MonadIO m => Logger -> [String] -> m ()

82− formatted = printf " [%4dms] %s" ms msg

102+subitem = itemWith 4

83− liftIO $ message logger formatted

103+

84− return result

104+

85−

105+--------------------------------------------------------------------------------

86−-- | Log something at the same level as 'timed', but without the timing

106+itemWith :: MonadIO m => Int -> Logger -> [String] -> m ()

87−--

107+itemWith _ _ [] = return ()

88−report :: MonadIO m

108+itemWith i l [x] = string l Message $ replicate i ' ' ++ x

89− => Logger -- ^ Logger

109+itemWith i l (x : ys) = string l Message $ indent ++ x ++ spaces ++ ys'

90− -> String -- ^ Message

110+ where

91− -> m () -- ^ No result

111+ indent = replicate i ' '

92−report logger msg = liftIO $ message logger $ " [ ] " ++ msg

112+ spaces = replicate (max 1 $ loggerColumns l - i - length x - length ys') ' '

93−

113+ ys' = intercalate ", " ys

94−-- | Log an error that was thrown in the compilation phase

114+

95−--

115+

116+--------------------------------------------------------------------------------

96−thrown :: MonadIO m

117+debug :: MonadIO m => Logger -> String -> m ()

97− => Logger -- ^ Logger

118+debug l m = string l Debug $ " DEBUG: " ++ m

98− -> String -- ^ Message

99− -> m () -- ^ No result

100−thrown logger msg = liftIO $ message logger $ " [ ERROR] " ++ msg

src/Hakyll/Core/Runtime.hs+29−18

@@ -27,7 +27,8 @@ import Hakyll.Core.Compiler.Require

27import Hakyll.Core.Configuration

28import Hakyll.Core.Dependencies

29import Hakyll.Core.Identifier

30−import Hakyll.Core.Logger

30+import Hakyll.Core.Logger (Logger)

31+import qualified Hakyll.Core.Logger as Logger

31import Hakyll.Core.ResourceProvider

32import Hakyll.Core.ResourceProvider

32import Hakyll.Core.Routes

33import Hakyll.Core.Routes

33import Hakyll.Core.Rules.Internal

34import Hakyll.Core.Rules.Internal

@@ -41,13 +42,15 @@ import Hakyll.Core.Writable

41run :: Configuration -> Rules a -> IO RuleSet

42run :: Configuration -> Rules a -> IO RuleSet

42run configuration rules = do

43run configuration rules = do

43 -- Initialization

44 -- Initialization

44− logger <- makeLogger putStrLn

45+ logger <- Logger.new Logger.Debug putStrLn

45− section logger "Initialising"

46+ Logger.header logger "Initialising"

46− store <- timed logger "Creating store" $

47+ Logger.item logger ["Creating store"]

47− Store.new (inMemoryCache configuration) $ storeDirectory configuration

48+ store <- Store.new (inMemoryCache configuration) $

49+ storeDirectory configuration

48− provider <- timed logger "Creating provider" $

50+ Logger.item logger ["Creating provider"]

49− newResourceProvider store (ignoreFile configuration) "."

51+ provider <- newResourceProvider store (ignoreFile configuration) "."

52+ Logger.item logger ["Running rules"]

50− ruleSet <- timed logger "Running rules" $ runRules rules provider

53+ ruleSet <- runRules rules provider

52 -- Get old facts

55 -- Get old facts

53 mOldFacts <- Store.get store factsKey

56 mOldFacts <- Store.get store factsKey

@@ -73,11 +76,11 @@ run configuration rules = do

73 -- Run the program and fetch the resulting state

76 -- Run the program and fetch the resulting state

74 result <- runErrorT $ runRWST build read' state

77 result <- runErrorT $ runRWST build read' state

75 case result of

78 case result of

76− Left e -> thrown logger e

79+ Left e -> Logger.error logger e

77 Right (_, s, _) -> Store.set store factsKey $ runtimeFacts s

80 Right (_, s, _) -> Store.set store factsKey $ runtimeFacts s

79 -- Flush and return

82 -- Flush and return

80− flushLogger logger

83+ Logger.flush logger

81 return ruleSet

84 return ruleSet

82 where

85 where

83 factsKey = ["Hakyll.Core.Runtime.run", "facts"]

86 factsKey = ["Hakyll.Core.Runtime.run", "facts"]

@@ -109,23 +112,25 @@ type Runtime a = RWST RuntimeRead () RuntimeState (ErrorT String IO) a

109--------------------------------------------------------------------------------

112--------------------------------------------------------------------------------

110build :: Runtime ()

113build :: Runtime ()

111build = do

114build = do

115+ logger <- runtimeLogger <$> ask

116+ Logger.header logger "Checking for out-of-date items"

112 scheduleOutOfDate

117 scheduleOutOfDate

118+ Logger.header logger "Compiling"

113 pickAndChase

119 pickAndChase

120+ Logger.header logger "Success"

114

121

115

122

116--------------------------------------------------------------------------------

123--------------------------------------------------------------------------------

117scheduleOutOfDate :: Runtime ()

124scheduleOutOfDate :: Runtime ()

118scheduleOutOfDate = do

125scheduleOutOfDate = do

119− logger <- runtimeLogger <$> ask

120 provider <- runtimeProvider <$> ask

126 provider <- runtimeProvider <$> ask

121 universe <- runtimeUniverse <$> ask

127 universe <- runtimeUniverse <$> ask

122 facts <- runtimeFacts <$> get

128 facts <- runtimeFacts <$> get

123 todo <- runtimeTodo <$> get

129 todo <- runtimeTodo <$> get

124

130

125 let identifiers = map fst universe

131 let identifiers = map fst universe

126− modified <- timed logger "Checking for modified items" $

127− fmap S.fromList $ flip filterM identifiers $

132+ modified <- fmap S.fromList $ flip filterM identifiers $

128− liftIO . resourceModified provider

133+ liftIO . resourceModified provider

129 let (ood, facts', _) = outOfDate identifiers modified facts

134 let (ood, facts', _) = outOfDate identifiers modified facts

130 todo' = M.fromList

135 todo' = M.fromList

131 [(id', c) | (id', c) <- universe, id' `S.member` ood]

136 [(id', c) | (id', c) <- universe, id' `S.member` ood]

@@ -163,7 +168,6 @@ chase trail id'

163 store <- runtimeStore <$> ask

168 store <- runtimeStore <$> ask

164 config <- runtimeConfiguration <$> ask

169 config <- runtimeConfiguration <$> ask

165

170

166− section logger $ "Processing " ++ show id'

167 let compiler = todo M.! id'

171 let compiler = todo M.! id'

168 read' = CompilerRead

172 read' = CompilerRead

169 { compilerIdentifier = id'

173 { compilerIdentifier = id'

@@ -174,18 +178,25 @@ chase trail id'

174 , compilerLogger = logger

178 , compilerLogger = logger

175 }

179 }

176

180

177− result <- timed logger "Compiling" $ liftIO $ runCompiler compiler read'

181+ result <- liftIO $ runCompiler compiler read'

178 case result of

182 case result of

179 -- Rethrow error

183 -- Rethrow error

180 CompilerError e -> throwError e

184 CompilerError e -> throwError e

181

185

182 -- Huge success

186 -- Huge success

183− CompilerDone (CompiledItem compiled) facts -> do

187+ CompilerDone (CompiledItem compiled) cwrite -> do

188+ let facts = compilerDependencies cwrite

189+ cacheHits

190+ | compilerCacheHits cwrite <= 0 = "modified"

191+ | otherwise = "cache hit"

192+ Logger.item logger [show id', cacheHits]

193+

184 -- Write if necessary

194 -- Write if necessary

185 case runRoutes routes id' of

195 case runRoutes routes id' of

186 Nothing -> return ()

196 Nothing -> return ()

187− Just url -> timed logger ("Routing to " ++ url) $ do

197+ Just url -> do

188 let path = destinationDirectory config </> url

198 let path = destinationDirectory config </> url

199+ Logger.subitem logger ["-> " ++ path]

189 liftIO $ makeDirectories path

200 liftIO $ makeDirectories path

190 liftIO $ write path compiled

201 liftIO $ write path compiled

191

202

src/Hakyll/Core/UnixFilter.hs+3−3

@@ -75,9 +75,9 @@ unixFilterWith :: (Handle -> i -> IO ()) -- ^ Writer

75 -> [String] -- ^ Program args

76 -> i -- ^ Program input

77 -> Compiler o -- ^ Program output

78−unixFilterWith writer reader programName args input =

78+unixFilterWith writer reader programName args input = do

79− timedCompiler ("Executing external program " ++ programName) $

79+ debugCompiler ("Executing external program " ++ programName)

80− unsafeCompiler $ unixFilterIO writer reader programName args input

80+ unsafeCompiler $ unixFilterIO writer reader programName args input

83--------------------------------------------------------------------------------