git.iko.soy/typeable/katip
on master help sign in
Add colorizer that doesn't need wl-pp
commit3239a69ad2b8213b01022f0927e266053b5a207b authorMichael Xavier <michael@michaelxavier.net> dateSun 1 Mar 2015, 16:58 (12 years ago) parent4b43391
3 files changed+44−13
compare with master
unifiedsplit
bench/Main.hs+14−13 katip.cabal+1 src/Katip/Scribes/Handle.hs+29
bench/Main.hs+14−13
@@ -1,10 +1,12 @@
11{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RankNTypes #-}
23module Main
34 ( main
45 ) where
56
67
78-------------------------------------------------------------------------------
9+import Blaze.ByteString.Builder
810import Control.Concurrent
911import Control.Monad.IO.Class
1012import CriterionPlus
@@ -30,13 +32,19 @@ handleScribeBench :: Benchmark ()
3032handleScribeBench = standoff "Katip.Scribes.Handle" $ do
3133 subject "Bytestring Builder" $ do
3234 pause
33− (Scribe push) <- liftIO setupBB
35+ (Scribe push) <- liftIO $ setup bbFormat
3436 tid <- liftIO myThreadId
3537 continue
3638 whnfIO $ push $ exItem tid
37− subject "Colored" $ do
39+ subject "Bytestring Builder + Colored" $ do
3840 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
4048 tid <- liftIO myThreadId
4149 continue
4250 whnfIO $ push $ exItem tid
@@ -78,14 +86,7 @@ mkUTCTime y mt d h mn s = UTCTime day dt
7886
7987
8088-------------------------------------------------------------------------------
81−setupBB :: IO Scribe
82−setupBB = do
83− h <- openFile "/dev/null" WriteMode
84− mkHandleScribe' bbFormat h Debug V0
85−
86−
87−-------------------------------------------------------------------------------
88−setupColor :: IO Scribe
89−setupColor = do
89+setup :: (forall a. LogContext a => Verbosity -> Item a -> Builder) -> IO Scribe
90+setup format = do
9091 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
6262 build-depends:
6363 base
6464 , aeson
65+ , blaze-builder
6566 , katip
6667 , criterion >= 0.8 && < 1.0
6768 , criterion-plus
src/Katip/Scribes/Handle.hs+29
@@ -5,6 +5,7 @@ module Katip.Scribes.Handle
55 -- * exported for benchmarking
66 , mkHandleScribe'
77 , bbFormat
8+ , bbFormatColor
89 , colorFormat
910 ) where
1011
@@ -67,6 +68,7 @@ mkHandleScribe' fmt h sev verb = do
6768
6869
6970-------------------------------------------------------------------------------
71+bbFormat :: LogContext a => Verbosity -> Item a -> Builder
7072bbFormat verb Item{..} =
7173 brackets nowStr <>
7274 brackets (mconcat $ map fromText $ intercalateNs itemNamespace) <>
@@ -83,6 +85,33 @@ bbFormat verb Item{..} =
8385
8486
8587-------------------------------------------------------------------------------
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
86115colorFormat verb Item{..} = disp $
87116 PP.brackets (PP.string nowStr) <>
88117 PP.brackets (PP.string $ fromChunks $ intercalateNs itemNamespace) <>