256cc76 · hakyll · git.iko.soy

git.iko.soy/hakyll

Add pretty, thread-safe logger

commit256cc760bae2e8bc4238fb8b903ffc92a36d7db9 authorJasper Van der Jeugt <jaspervdj@gmail.com> dateMon 21 Feb 2011, 02:56 (16 years ago) parentf04efba

3 files changed+129−35

compare with master

unifiedsplit

src/Hakyll/Core/Compiler.hs−2 src/Hakyll/Core/Logger.hs+82 src/Hakyll/Core/Run.hs+47−33

src/Hakyll/Core/Compiler.hs−2

@@ -253,8 +253,6 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do

253253 identifier <- compilerIdentifier <$> ask

254254 store <- compilerStore <$> ask

255255 modified <- compilerResourceModified <$> ask

256− liftIO $ putStrLn $

257− show identifier ++ ": " ++ if modified then "MODIFIED" else "OK"

258256 if modified

259257 then do v <- unCompilerM $ j $ Resource identifier

260258 liftIO $ storeSet store name identifier v

src/Hakyll/Core/Logger.hsnew file+82

@@ -0,0 +1,82 @@

1+-- | Produce pretty, thread-safe logs

2+--

3+{-# LANGUAGE BangPatterns #-}

4+module Hakyll.Core.Logger

5+ ( Logger

6+ , makeLogger

7+ , flushLogger

8+ , section

9+ , timed

10+ ) where

11+

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

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

14+import Control.Concurrent (forkIO)

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

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

17+import Text.Printf (printf)

18+

19+import Data.Time (getCurrentTime, diffUTCTime)

20+

21+-- | Logger structure. Very complicated.

22+--

23+data Logger = Logger

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

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

26+ }

27+

28+-- | Create a new logger

29+--

30+makeLogger :: IO Logger

31+makeLogger = do

32+ logger <- Logger <$> newChan <*> newEmptyMVar

33+ _ <- forkIO $ loggerThread logger

34+ return logger

35+ where

36+ loggerThread logger = do

37+ msg <- readChan $ loggerChan logger

38+ case msg of

39+ -- Stop: sync

40+ Nothing -> putMVar (loggerSync logger) ()

41+ -- Print and continue

42+ Just m -> do

43+ putStrLn m

44+ loggerThread logger

45+

46+-- | Flush the logger (blocks until flushed)

47+--

48+flushLogger :: Logger -> IO ()

49+flushLogger logger = do

50+ writeChan (loggerChan logger) Nothing

51+ () <- takeMVar $ loggerSync logger

52+ return ()

53+

54+-- | Send a raw message to the logger

55+--

56+message :: Logger -> String -> IO ()

57+message logger = writeChan (loggerChan logger) . Just

58+

59+-- | Start a section in the log

60+--

61+section :: MonadIO m

62+ => Logger -- ^ Logger

63+ -> String -- ^ Section name

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

65+section logger = liftIO . message logger

66+

67+-- | Execute a monadic action and log the duration

68+--

69+timed :: MonadIO m

70+ => Logger -- ^ Logger

71+ -> String -- ^ Message

72+ -> m a -- ^ Action

73+ -> m a -- ^ Timed and logged action

74+timed logger msg action = do

75+ start <- liftIO getCurrentTime

76+ !result <- action

77+ stop <- liftIO getCurrentTime

78+ let diff = fromEnum $ diffUTCTime stop start

79+ ms = diff `div` 10 ^ (9 :: Int)

80+ formatted = printf " [%4dms] %s" ms msg

81+ liftIO $ message logger formatted

82+ return result

src/Hakyll/Core/Run.hs+47−33

@@ -10,7 +10,7 @@ import Control.Monad (filterM)

1010import Control.Monad.Trans (liftIO)

1111import Control.Applicative (Applicative, (<$>))

1212import Control.Monad.Reader (ReaderT, runReaderT, ask)

13−import Control.Monad.State (StateT, evalStateT, get, modify)

13+import Control.Monad.State.Strict (StateT, evalStateT, get, modify)

1414import Control.Arrow ((&&&))

1515import qualified Data.Map as M

1616import Data.Monoid (mempty, mappend)

@@ -31,25 +31,36 @@ import Hakyll.Core.DirectedGraph.DependencySolver

3131import Hakyll.Core.Writable

3232import Hakyll.Core.Store

3333import Hakyll.Core.Configuration

34+import Hakyll.Core.Logger

3435

3536-- | Run all rules needed, return the rule set used

3637--

3738run :: HakyllConfiguration -> Rules -> IO RuleSet

3839run configuration rules = do

39− store <- makeStore $ storeDirectory configuration

40− provider <- fileResourceProvider configuration

40+ logger <- makeLogger

41+

42+ section logger "Initialising"

43+ store <- timed logger "Creating store" $

44+ makeStore $ storeDirectory configuration

45+ provider <- timed logger "Creating provider" $

46+ fileResourceProvider configuration

47+

4148 let ruleSet = runRules rules provider

4249 compilers = rulesCompilers ruleSet

4350

4451 -- Extract the reader/state

4552 reader = unRuntime $ addNewCompilers [] compilers

46− state' = runReaderT reader $ env ruleSet provider store

53+ state' = runReaderT reader $ env logger ruleSet provider store

4754

4855 evalStateT state' state

56+

57+ -- Flush and return

58+ flushLogger logger

4959 return ruleSet

5060 where

51− env ruleSet provider store = RuntimeEnvironment

52− { hakyllConfiguration = configuration

61+ env logger ruleSet provider store = RuntimeEnvironment

62+ { hakyllLogger = logger

63+ , hakyllConfiguration = configuration

5364 , hakyllRoutes = rulesRoutes ruleSet

5465 , hakyllResourceProvider = provider

5566 , hakyllStore = store

@@ -61,7 +72,8 @@ run configuration rules = do

6172 }

6273

6374data RuntimeEnvironment = RuntimeEnvironment

64− { hakyllConfiguration :: HakyllConfiguration

75+ { hakyllLogger :: Logger

76+ , hakyllConfiguration :: HakyllConfiguration

6577 , hakyllRoutes :: Routes

6678 , hakyllResourceProvider :: ResourceProvider

6779 , hakyllStore :: Store

@@ -96,6 +108,8 @@ addNewCompilers :: [(Identifier, Compiler () CompileRule)]

96108 -> Runtime ()

97109addNewCompilers oldCompilers newCompilers = Runtime $ do

98110 -- Get some information

111+ logger <- hakyllLogger <$> ask

112+ section logger "Adding new compilers"

99113 provider <- hakyllResourceProvider <$> ask

100114 store <- hakyllStore <$> ask

101115

@@ -115,31 +129,31 @@ addNewCompilers oldCompilers newCompilers = Runtime $ do

115129

116130 -- Find the old graph and append the new graph to it. This forms the

117131 -- complete graph

118− completeGraph <- mappend currentGraph . hakyllGraph <$> get

119−

120− -- Check which items are up-to-date. This only needs to happen for the new

121− -- compilers

122− oldModified <- hakyllModified <$> get

123− newModified <- liftIO $ modified provider store $ map fst newCompilers

132+ completeGraph <- timed logger "Creating graph" $

133+ mappend currentGraph . hakyllGraph <$> get

124134

125− let modified' = oldModified `S.union` newModified

126−

127− -- Find obsolete items. Every item that is reachable from a modified

128− -- item is considered obsolete. From these obsolete items, we are only

129− -- interested in ones that are in the current subgraph.

130− obsolete = S.filter (`member` currentGraph)

131− $ reachableNodes modified' $ reverse completeGraph

135+ orderedCompilers <- timed logger "Solving dependencies" $ do

136+ -- Check which items are up-to-date. This only needs to happen for the new

137+ -- compilers

138+ oldModified <- hakyllModified <$> get

139+ newModified <- liftIO $ modified provider store $ map fst newCompilers

132140

133− -- Solve the graph and retain only the obsolete items

134− ordered = filter (`S.member` obsolete) $ solveDependencies currentGraph

141+ let modified' = oldModified `S.union` newModified

142+

143+ -- Find obsolete items. Every item that is reachable from a modified

144+ -- item is considered obsolete. From these obsolete items, we are only

145+ -- interested in ones that are in the current subgraph.

146+ obsolete = S.filter (`member` currentGraph)

147+ $ reachableNodes modified' $ reverse completeGraph

135148

136− -- Join the order with the compilers again

137− orderedCompilers = map (id &&& (compilerMap M.!)) ordered

149+ -- Solve the graph and retain only the obsolete items

150+ ordered = filter (`S.member` obsolete) $ solveDependencies currentGraph

138151

139− liftIO $ putStrLn "Adding compilers..."

140− liftIO $ putStrLn $ "Added: " ++ show (map fst orderedCompilers)

152+ -- Update the state

153+ modify $ updateState modified' completeGraph

141154

142− modify $ updateState modified' completeGraph

155+ -- Join the order with the compilers again

156+ return $ map (id &&& (compilerMap M.!)) ordered

143157

144158 -- Now run the ordered list of compilers

145159 unRuntime $ runCompilers orderedCompilers

@@ -157,33 +171,33 @@ runCompilers :: [(Identifier, Compiler () CompileRule)]

157171runCompilers [] = return ()

158172runCompilers ((id', compiler) : compilers) = Runtime $ do

159173 -- Obtain information

174+ logger <- hakyllLogger <$> ask

160175 routes <- hakyllRoutes <$> ask

161176 provider <- hakyllResourceProvider <$> ask

162177 store <- hakyllStore <$> ask

163178 modified' <- hakyllModified <$> get

164179

180+ section logger $ "Compiling " ++ show id'

181+

165182 let -- Check if the resource was modified

166183 isModified = id' `S.member` modified'

167184

168185 -- Run the compiler

169− result <- liftIO $ runCompiler compiler id' provider routes store isModified

170− liftIO $ putStrLn $ "Generated target: " ++ show id'

186+ result <- timed logger "Compiling item" $

187+ liftIO $ runCompiler compiler id' provider routes store isModified

171188

172189 case result of

173190 -- Compile rule for one item, easy stuff

174191 CompileRule compiled -> do

175192 case runRoutes routes id' of

176193 Nothing -> return ()

177− Just url -> do

178− liftIO $ putStrLn $ "Routing " ++ show id' ++ " to " ++ url

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

179195 destination <-

180196 destinationDirectory . hakyllConfiguration <$> ask

181197 let path = destination </> url

182198 liftIO $ makeDirectories path

183199 liftIO $ write path compiled

184200

185− liftIO $ putStrLn ""

186−

187201 -- Continue for the remaining compilers

188202 unRuntime $ runCompilers compilers

189203