git.iko.soy/typeable/katip
on master help sign in
Add colorizer that doesn't need wl-pp
3239a69Michael Xavier
bench/Main.hs+14−13
compare with master
unifiedsplit
@@ -1,10 +1,12 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RankNTypes #-}
2module Main
3module Main
3 ( main
4 ( main
4 ) where
5 ) where
5
6
6
7
7-------------------------------------------------------------------------------
8-------------------------------------------------------------------------------
9+import Blaze.ByteString.Builder
8import Control.Concurrent
10import Control.Concurrent
9import Control.Monad.IO.Class
11import Control.Monad.IO.Class
10import CriterionPlus
12import CriterionPlus
@@ -30,13 +32,19 @@ handleScribeBench :: Benchmark ()
30handleScribeBench = standoff "Katip.Scribes.Handle" $ do
32handleScribeBench = standoff "Katip.Scribes.Handle" $ do
31 subject "Bytestring Builder" $ do
33 subject "Bytestring Builder" $ do
32 pause
34 pause
33− (Scribe push) <- liftIO setupBB
35+ (Scribe push) <- liftIO $ setup bbFormat
34 tid <- liftIO myThreadId
36 tid <- liftIO myThreadId
35 continue
37 continue
36 whnfIO $ push $ exItem tid
38 whnfIO $ push $ exItem tid
37− subject "Colored" $ do
39+ subject "Bytestring Builder + Colored" $ do
38 pause
40 pause
39− (Scribe push) <- liftIO setupColor
41+ (Scribe push) <- liftIO $ setup bbFormatColor
42+ tid <- liftIO myThreadId
43+ continue
44+ whnfIO $ push $ exItem tid
45+ subject "WL + Colored" $ do
46+ pause
47+ (Scribe push) <- liftIO $ setup colorFormat
40 tid <- liftIO myThreadId
48 tid <- liftIO myThreadId
41 continue
49 continue
42 whnfIO $ push $ exItem tid
50 whnfIO $ push $ exItem tid
@@ -78,14 +86,7 @@ mkUTCTime y mt d h mn s = UTCTime day dt
78
86
79
87
80-------------------------------------------------------------------------------
88-------------------------------------------------------------------------------
81−setupBB :: IO Scribe
89+setup :: (forall a. LogContext a => Verbosity -> Item a -> Builder) -> IO Scribe
82−setupBB = do
90+setup format = do
83− h <- openFile "/dev/null" WriteMode
84− mkHandleScribe' bbFormat h Debug V0
85−
86−
87−-------------------------------------------------------------------------------
88−setupColor :: IO Scribe
89−setupColor = do
90 h <- openFile "/dev/null" WriteMode
91 h <- openFile "/dev/null" WriteMode
91− mkHandleScribe' colorFormat h Debug V0
92+ mkHandleScribe' format h Debug V0
katip.cabal+1
@@ -62,6 +62,7 @@ benchmark bench
62 build-depends:
62 build-depends:
63 base
63 base
64 , aeson
64 , aeson
65+ , blaze-builder
65 , katip
66 , katip
66 , criterion >= 0.8 && < 1.0
67 , criterion >= 0.8 && < 1.0
67 , criterion-plus
68 , criterion-plus
src/Katip/Scribes/Handle.hs+29
@@ -5,6 +5,7 @@ module Katip.Scribes.Handle
5 -- * exported for benchmarking
5 -- * exported for benchmarking
6 , mkHandleScribe'
6 , mkHandleScribe'
7 , bbFormat
7 , bbFormat
8+ , bbFormatColor
8 , colorFormat
9 , colorFormat
9 ) where
10 ) where
10
11
@@ -67,6 +68,7 @@ mkHandleScribe' fmt h sev verb = do
67
68
68
69
69-------------------------------------------------------------------------------
70-------------------------------------------------------------------------------
71+bbFormat :: LogContext a => Verbosity -> Item a -> Builder
70bbFormat verb Item{..} =
72bbFormat verb Item{..} =
71 brackets nowStr <>
73 brackets nowStr <>
72 brackets (mconcat $ map fromText $ intercalateNs itemNamespace) <>
74 brackets (mconcat $ map fromText $ intercalateNs itemNamespace) <>
@@ -83,6 +85,33 @@ bbFormat verb Item{..} =
83
85
84
86
85-------------------------------------------------------------------------------
87-------------------------------------------------------------------------------
88+bbFormatColor :: LogContext a => Verbosity -> Item a -> Builder
89+bbFormatColor verb Item{..} =
90+ brackets nowStr <>
91+ brackets (mconcat $ map fromText $ intercalateNs itemNamespace) <>
92+ brackets (fromText (renderSeverity' itemSeverity)) <>
93+ brackets (fromString itemHost) <>
94+ brackets (fromString (show itemProcess)) <>
95+ brackets (fromString (show itemThread)) <>
96+ mconcat ks <>
97+ maybe mempty (brackets . fromString . locationToString) itemLoc <>
98+ fromText " " <> fromText itemMessage
99+ where
100+ nowStr = fromString $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" itemTime
101+ ks = map brackets $ getKeys verb itemPayload
102+ renderSeverity' s = case s of
103+ Emergency -> red $ renderSeverity s
104+ Alert -> red $ renderSeverity s
105+ Critical -> red $ renderSeverity s
106+ Error -> red $ renderSeverity s
107+ Warning -> yellow $ renderSeverity s
108+ _ -> renderSeverity s
109+ red = colorize "31"
110+ yellow = colorize "33"
111+ colorize c s = "\ESC["<> c <> "m" <> s <> "\ESC[0m"
112+
113+-------------------------------------------------------------------------------
114+colorFormat :: LogContext a => Verbosity -> Item a -> Builder
86colorFormat verb Item{..} = disp $
115colorFormat verb Item{..} = disp $
87 PP.brackets (PP.string nowStr) <>
116 PP.brackets (PP.string nowStr) <>
88 PP.brackets (PP.string $ fromChunks $ intercalateNs itemNamespace) <>
117 PP.brackets (PP.string $ fromChunks $ intercalateNs itemNamespace) <>