git.iko.soy/typeable/katip
on master help sign in
Experiment using aeson's time formatter

Benchmarks show no difference. formatting 23.23ns for current formatter, 23.18ns for ported version. The ported formatter targets a bytestring builder and then we have to conver to a lazy bytestring, then lazy text, then a builder so we may be losing some efficiency there. I guess I could try understanding what aeson's code is doing to port it to text but it sure is making the current implementation feel fast enough. Maybe strings aren't so bad when there's such a short string for timestamps.

commit77aaf468269e7a97e327f5b47bcb5f60f00fe9ba authorMichael Xavier <michael@michaelxavier.net> dateTue 19 Jul 2016, 09:34 (10 years ago) parent8df79e3
2 files changed+145−9
compare with master
unifiedsplit
katip/bench/Main.hs+14−2 katip/src/Katip/Scribes/Handle.hs+131−7
katip/bench/Main.hs+14−2
@@ -34,6 +34,18 @@ handleScribeBench = bgroup "Katip.Scribes.Handle" [
3434 env setupEnv $ \ ~(Scribe push, tid) ->
3535 bench "Bytestring Builder" $
3636 whnfIO $ push $ exItem tid
37+ , bgroup "formatItem"
38+ [ bench "with color" $
39+ whnf (formatItem True V3) (exItem (ThreadIdText "1"))
40+ , bench "without color" $
41+ whnf (formatItem False V3) (exItem (ThreadIdText "1"))
42+ ]
43+ , bgroup "formatItem'"
44+ [ bench "with color" $
45+ whnf (formatItem' True V3) (exItem (ThreadIdText "1"))
46+ , bench "without color" $
47+ whnf (formatItem' False V3) (exItem (ThreadIdText "1"))
48+ ]
3749 ]
3850 where
3951 setupEnv = do
@@ -73,9 +85,9 @@ instance LogItem ExPayload where
7385
7486-------------------------------------------------------------------------------
7587mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime
76−mkUTCTime y mt d h mn s = UTCTime day dt
88+mkUTCTime y mt d h mn s = UTCTime dy dt
7789 where
78− day = fromGregorian y mt d
90+ dy = fromGregorian y mt d
7991 dt = h * 60 * 60 + mn * 60 + s
8092
8193
katip/src/Katip/Scribes/Handle.hs+131−7
@@ -1,20 +1,26 @@
1+{-# LANGUAGE BangPatterns #-}
12{-# LANGUAGE RecordWildCards #-}
2−
33module Katip.Scribes.Handle where
44
55-------------------------------------------------------------------------------
6−import Control.Applicative as A
6+import Control.Applicative as A
77import Control.Monad
88import Data.Aeson
9−import qualified Data.HashMap.Strict as HM
9+import Data.Aeson.Internal.Time
10+import qualified Data.ByteString.Builder as B
11+import Data.ByteString.Builder.Prim ((>$<), (>*<))
12+import qualified Data.ByteString.Builder.Prim as BP
13+import Data.Char (chr)
14+import qualified Data.HashMap.Strict as HM
1015import Data.Monoid
11−import Data.Text (Text)
16+import Data.Text (Text)
1217import Data.Text.Lazy.Builder
13−import Data.Text.Lazy.IO as T
18+import Data.Text.Lazy.Encoding (decodeUtf8)
19+import Data.Text.Lazy.IO as T
1420import Data.Time
15−import qualified Data.Time.Locale.Compat as LC
21+import qualified Data.Time.Locale.Compat as LC
1622import System.IO
17−import System.IO.Unsafe (unsafePerformIO)
23+import System.IO.Unsafe (unsafePerformIO)
1824-------------------------------------------------------------------------------
1925import Katip.Core
2026-------------------------------------------------------------------------------
@@ -96,6 +102,124 @@ formatItem withColor verb Item{..} =
96102 | otherwise = s
97103
98104
105+-------------------------------------------------------------------------------
106+formatItem' :: LogItem a => Bool -> Verbosity -> Item a -> Builder
107+formatItem' withColor verb Item{..} =
108+ brackets nowStr <>
109+ brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
110+ brackets (fromText (renderSeverity' _itemSeverity)) <>
111+ brackets (fromString _itemHost) <>
112+ brackets (fromString (show _itemProcess)) <>
113+ brackets (fromText (getThreadIdText _itemThread)) <>
114+ mconcat ks <>
115+ maybe mempty (brackets . fromString . locationToString) _itemLoc <>
116+ fromText " " <> (unLogStr _itemMessage)
117+ where
118+ nowStr = fromLazyText $ decodeUtf8 $ B.toLazyByteString $ utcTime _itemTime
119+ ks = map brackets $ getKeys verb _itemPayload
120+ renderSeverity' s = case s of
121+ EmergencyS -> red $ renderSeverity s
122+ AlertS -> red $ renderSeverity s
123+ CriticalS -> red $ renderSeverity s
124+ ErrorS -> red $ renderSeverity s
125+ WarningS -> yellow $ renderSeverity s
126+ _ -> renderSeverity s
127+ red = colorize "31"
128+ yellow = colorize "33"
129+ colorize c s
130+ | withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"
131+ | otherwise = s
132+
133+
134+-------------------------------------------------------------------------------
135+utcTime :: UTCTime -> B.Builder
136+utcTime (UTCTime d s) = dayTime d (diffTimeOfDay64 s) <> B.char7 'Z'
137+{-# INLINE utcTime #-}
138+
139+
140+dayTime :: Day -> TimeOfDay64 -> B.Builder
141+dayTime d t = day d <> B.char7 'T' <> timeOfDay64 t
142+{-# INLINE dayTime #-}
143+
144+
145+timeOfDay64 :: TimeOfDay64 -> B.Builder
146+timeOfDay64 (TOD h m s)
147+ | frac == 0 = hhmmss -- omit subseconds if 0
148+ | otherwise = hhmmss <> BP.primBounded showFrac frac
149+ where
150+ hhmmss = BP.primBounded (ascii8 (hh,(hl,(':',(mh,(ml,(':',(sh,sl')))))))) ()
151+ !(T hh hl) = twoDigits h
152+ !(T mh ml) = twoDigits m
153+ !(T sh sl') = twoDigits (fromIntegral real)
154+ (real,frac) = s `quotRem` pico
155+ showFrac = (\x -> ('.', x)) >$< (BP.liftFixedToBounded BP.char7 >*< trunc12)
156+ trunc12 = (`quotRem` micro) >$<
157+ BP.condB (\(_,y) -> y == 0) (fst >$< trunc6) (digits6 >*< trunc6)
158+ digits6 = ((`quotRem` milli) . fromIntegral) >$< (digits3 >*< digits3)
159+ trunc6 = ((`quotRem` milli) . fromIntegral) >$<
160+ BP.condB (\(_,y) -> y == 0) (fst >$< trunc3) (digits3 >*< trunc3)
161+ digits3 = (`quotRem` 10) >$< (digits2 >*< digits1)
162+ digits2 = (`quotRem` 10) >$< (digits1 >*< digits1)
163+ digits1 = BP.liftFixedToBounded (digit >$< BP.char7)
164+ trunc3 = BP.condB (== 0) BP.emptyB $
165+ (`quotRem` 100) >$< (digits1 >*< trunc2)
166+ trunc2 = BP.condB (== 0) BP.emptyB $
167+ (`quotRem` 10) >$< (digits1 >*< trunc1)
168+ trunc1 = BP.condB (== 0) BP.emptyB digits1
169+
170+ pico = 1000000000000 -- number of picoseconds in 1 second
171+ micro = 1000000 -- number of microseconds in 1 second
172+ milli = 1000 -- number of milliseconds in 1 second
173+{-# INLINE timeOfDay64 #-}
174+
175+
176+day :: Day -> B.Builder
177+day dd = encodeYear yr <>
178+ BP.primBounded (ascii6 ('-',(mh,(ml,('-',(dh,dl)))))) ()
179+ where (yr,m,d) = toGregorian dd
180+ !(T mh ml) = twoDigits m
181+ !(T dh dl) = twoDigits d
182+ encodeYear y
183+ | y >= 1000 = B.integerDec y
184+ | y > 0 =
185+ let (ab,c) = fromIntegral y `quotRem` 10
186+ (a,b) = ab `quotRem` 10
187+ in BP.primBounded (ascii4 ('0',(digit a,(digit b,digit c)))) ()
188+ | otherwise =
189+ error "Data.Aeson.Encode.Builder.day: years BCE not supported"
190+{-# INLINE day #-}
191+
192+
193+ascii8 :: (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
194+ -> BP.BoundedPrim a
195+ascii8 cs = BP.liftFixedToBounded $ const cs >$<
196+ BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*<
197+ BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
198+{-# INLINE ascii8 #-}
199+
200+
201+data T = T {-# UNPACK #-} !Char {-# UNPACK #-} !Char
202+
203+
204+twoDigits :: Int -> T
205+twoDigits a = T (digit hi) (digit lo)
206+ where (hi,lo) = a `quotRem` 10
207+
208+digit :: Int -> Char
209+digit x = chr (x + 48)
210+
211+
212+ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a
213+ascii4 cs = BP.liftFixedToBounded $ const cs >$<
214+ BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
215+{-# INLINE ascii4 #-}
216+
217+
218+ascii6 :: (Char, (Char, (Char, (Char, (Char, Char))))) -> BP.BoundedPrim a
219+ascii6 cs = BP.liftFixedToBounded $ const cs >$<
220+ BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
221+{-# INLINE ascii6 #-}
222+
99223-------------------------------------------------------------------------------
100224-- | An implicit environment to enable logging directly ouf of the IO monad.
101225_ioLogEnv :: LogEnv