git.iko.soy/typeable/katip
on master help sign in
Faster time encoding for Handle Scribe
c595451Leonid Onokhov
katip/katip.cabal+2−1
compare with master
unifiedsplit
@@ -37,6 +37,7 @@ library
37 exposed-modules:
37 exposed-modules:
38 Katip
38 Katip
39 Katip.Core
39 Katip.Core
40+ Katip.Format.Time
40 Katip.Monadic
41 Katip.Monadic
41 Katip.Scribes.Handle
42 Katip.Scribes.Handle
42
43
@@ -63,7 +64,6 @@ library
63 , template-haskell >= 2.8 && < 2.12
64 , template-haskell >= 2.8 && < 2.12
64 , text >= 0.11 && <1.3
65 , text >= 0.11 && <1.3
65 , time >= 1 && < 1.7
66 , time >= 1 && < 1.7
66− , time-locale-compat >= 0.1.0.1 && < 0.2
67 , transformers >= 0.3 && < 0.6
67 , transformers >= 0.3 && < 0.6
68 , transformers-compat
68 , transformers-compat
69 , unix >= 2.5 && < 2.8
69 , unix >= 2.5 && < 2.8
@@ -97,6 +97,7 @@ test-suite test
97 , template-haskell
97 , template-haskell
98 , text
98 , text
99 , time
99 , time
100+ , time-locale-compat >= 0.1.0.1 && < 0.2
100 , temporary
101 , temporary
101 , directory
102 , directory
102 , regex-tdfa
103 , regex-tdfa
katip/src/Katip/Format/Time.hsnew file+213
@@ -0,0 +1,213 @@
1+-- | Time and memory efficient time encoding helper functions.
2+--
3+module Katip.Format.Time
4+ ( formatAsLogTime
5+ , formatAsIso8601
6+ ) where
7+
8+import Control.Monad.ST (ST)
9+
10+import Data.Int (Int64)
11+import qualified Data.Text.Array as TA
12+import Data.Text (Text)
13+import Data.Text.Internal (Text(..))
14+import Data.Time (UTCTime(..), toGregorian, Day, DiffTime)
15+import Data.Word (Word16)
16+import Unsafe.Coerce (unsafeCoerce)
17+
18+-- Note: All functions here are optimized to never allocate anything
19+-- on heap. At least on ghc 8.0.1 no extra strictness annotations are
20+-- seem to be needed.
21+--
22+-- Exported functions are INLINEABLE
23+
24+
25+-- | Format 'UTCTime' into a short human readable format.
26+--
27+-- >>> formatAsLogTime $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012
28+-- "2016-01-23 01:23:45"
29+--
30+formatAsLogTime :: UTCTime -> Text
31+formatAsLogTime (UTCTime day time) = toText $ TA.run2 $ do
32+ buf <- TA.new 19 -- length "2016-10-20 12:34:56"
33+ _ <- writeDay buf 0 day
34+ TA.unsafeWrite buf 10 0x20 -- space
35+ _ <- writeTimeOfDay False buf 11 (diffTimeOfDay64 time)
36+ pure (buf, 19)
37+ where
38+ toText (arr, len) = Text arr 0 len
39+
40+{-# INLINEABLE formatAsLogTime #-}
41+
42+-- | Format 'UTCTime' into a Iso8601 format.
43+--
44+-- Note that this function may overcommit up to 12*2 bytes, depending
45+-- on sub-second precision. If this is an issue, make a copy with a
46+-- 'Data.Text.copy'.
47+--
48+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012
49+-- "2016-11-23T01:23:45.123456789012Z"
50+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025.123
51+-- "2016-01-23T01:23:45.123Z"
52+-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025
53+-- "2016-01-23T01:23:45Z"
54+
55+--
56+formatAsIso8601 :: UTCTime -> Text
57+formatAsIso8601 (UTCTime day time) = toText $ TA.run2 $ do
58+ buf <- TA.new 33 -- length "2016-10-20 12:34:56.123456789012Z"
59+ _ <- writeDay buf 0 day
60+ TA.unsafeWrite buf 10 0x54 -- T
61+ next <- writeTimeOfDay True buf 11 (diffTimeOfDay64 time)
62+ TA.unsafeWrite buf next 0x5A -- Z
63+ pure (buf, next+1)
64+ where
65+ toText (arr, len) = Text arr 0 len
66+
67+{-# INLINEABLE formatAsIso8601 #-}
68+
69+-- | Writes the @YYYY-MM-DD@ part of timestamp
70+writeDay :: TA.MArray s -> Int -> Day -> ST s Int
71+writeDay buf off day =
72+ do
73+ TA.unsafeWrite buf (off + 0) (digit y1)
74+ TA.unsafeWrite buf (off + 1) (digit y2)
75+ TA.unsafeWrite buf (off + 2) (digit y3)
76+ TA.unsafeWrite buf (off + 3) (digit y4)
77+ TA.unsafeWrite buf (off + 4) 0x2d -- dash
78+ TA.unsafeWrite buf (off + 5) m1
79+ TA.unsafeWrite buf (off + 6) m2
80+ TA.unsafeWrite buf (off + 7) 0x2d -- dash
81+ TA.unsafeWrite buf (off + 8) d1
82+ TA.unsafeWrite buf (off + 9) d2
83+ pure (off + 10)
84+ where
85+ (yr,m,d) = toGregorian day
86+ (y1, ya) = fromIntegral (abs yr) `quotRem` 1000
87+ (y2, yb) = ya `quotRem` 100
88+ (y3, y4) = yb `quotRem` 10
89+ T m1 m2 = twoDigits m
90+ T d1 d2 = twoDigits d
91+{-# INLINE writeDay #-}
92+
93+-- | Write time of day, optionally with sub seconds
94+writeTimeOfDay :: Bool -> TA.MArray s -> Int -> TimeOfDay64 -> ST s Int
95+writeTimeOfDay doSubSeconds buf off (TOD hh mm ss) =
96+ do
97+
98+ TA.unsafeWrite buf off h1
99+ TA.unsafeWrite buf (off + 1) h2
100+ TA.unsafeWrite buf (off + 2) 0x3A -- colon
101+ TA.unsafeWrite buf (off + 3) m1
102+ TA.unsafeWrite buf (off + 4) m2
103+ TA.unsafeWrite buf (off + 5) 0x3A -- colon
104+ TA.unsafeWrite buf (off + 6) s1
105+ TA.unsafeWrite buf (off + 7) s2
106+ if doSubSeconds && frac /= 0
107+ then writeFracSeconds buf (off + 8) frac
108+ else pure (off + 8)
109+ where
110+ T h1 h2 = twoDigits hh
111+ T m1 m2 = twoDigits mm
112+ T s1 s2 = twoDigits (fromIntegral real)
113+ (real,frac) = ss `quotRem` pico
114+ pico = 1000000000000 -- number of picoseconds in 1 second
115+
116+
117+writeFracSeconds :: TA.MArray s -> Int -> Int64 -> ST s Int
118+writeFracSeconds buf off frac =
119+ do
120+ TA.unsafeWrite buf off 0x2e -- period
121+ if mills == 0
122+ then do
123+ writeTrunc6 buf (off + 1) (fromIntegral mics)
124+ else do
125+ writeDigit6 buf (off + 1) (fromIntegral mics)
126+ writeTrunc6 buf (off + 7) (fromIntegral mills)
127+
128+ where
129+ (mics, mills) = frac `quotRem` micro
130+ micro = 1000000 -- number of microseconds in 1 second
131+
132+
133+writeDigit6 :: TA.MArray s -> Int -> Int -> ST s ()
134+writeDigit6 buf off i =
135+ do
136+ writeDigit3 buf off f1
137+ writeDigit3 buf (off+3) f2
138+ where
139+ (f1, f2) = i `quotRem` 1000
140+
141+{-# INLINE writeDigit6 #-}
142+
143+writeDigit3 :: TA.MArray s -> Int -> Int -> ST s ()
144+writeDigit3 buf off i =
145+ do
146+ TA.unsafeWrite buf off (digit d1)
147+ TA.unsafeWrite buf (off+1) (digit d2)
148+ TA.unsafeWrite buf (off+2) (digit d3)
149+ where
150+ (d1, d) = i `quotRem` 100
151+ (d2, d3) = d `quotRem` 10
152+
153+{-# INLINE writeDigit3 #-}
154+
155+writeTrunc6 :: TA.MArray s -> Int -> Int -> ST s Int
156+writeTrunc6 buf off i =
157+ if f2 == 0
158+ then writeTrunc3 buf off f1
159+ else do
160+ writeDigit3 buf off f1
161+ writeTrunc3 buf (off+3) f2
162+ where
163+ (f1, f2) = i `quotRem` 1000
164+
165+{-# INLINE writeTrunc6 #-}
166+
167+
168+writeTrunc3 :: TA.MArray s -> Int -> Int -> ST s Int
169+writeTrunc3 buf off i
170+ | d == 0 = do
171+ TA.unsafeWrite buf off (digit d1)
172+ pure (off+1)
173+ | d3 == 0 = do
174+ TA.unsafeWrite buf off (digit d1)
175+ TA.unsafeWrite buf (off+1) (digit d2)
176+ pure (off+2)
177+
178+ | otherwise = do
179+ TA.unsafeWrite buf off (digit d1)
180+ TA.unsafeWrite buf (off+1) (digit d2)
181+ TA.unsafeWrite buf (off+2) (digit d3)
182+ pure (off+3)
183+ where
184+ (d1, d) = i `quotRem` 100
185+ (d2, d3) = d `quotRem` 10
186+
187+{-# INLINE writeTrunc3 #-}
188+
189+
190+-- Following code was adapted from aeson package.
191+--
192+-- Copyright: (c) 2015-2016 Bryan O'Sullivan
193+-- License: BSD3
194+
195+data T = T {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16
196+
197+twoDigits :: Int -> T
198+twoDigits a = T (digit hi) (digit lo)
199+ where (hi,lo) = a `quotRem` 10
200+
201+digit :: Int -> Word16
202+digit x = fromIntegral (x + 48)
203+
204+
205+data TimeOfDay64 = TOD {-# UNPACK #-} !Int
206+ {-# UNPACK #-} !Int
207+ {-# UNPACK #-} !Int64
208+
209+diffTimeOfDay64 :: DiffTime -> TimeOfDay64
210+diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s
211+ where (h,mp) = fromIntegral pico `quotRem` 3600000000000000
212+ (m,s) = mp `quotRem` 60000000000000
213+ pico = unsafeCoerce t :: Integer
katip/src/Katip/Scribes/Handle.hs+2−3
@@ -13,12 +13,11 @@ import Data.Monoid
13import Data.Text (Text)
13import Data.Text (Text)
14import Data.Text.Lazy.Builder
14import Data.Text.Lazy.Builder
15import Data.Text.Lazy.IO as T
15import Data.Text.Lazy.IO as T
16−import Data.Time
17−import qualified Data.Time.Locale.Compat as LC
18import System.IO
16import System.IO
19import System.IO.Unsafe (unsafePerformIO)
17import System.IO.Unsafe (unsafePerformIO)
20-------------------------------------------------------------------------------
18-------------------------------------------------------------------------------
21import Katip.Core
19import Katip.Core
20+import Katip.Format.Time (formatAsLogTime)
22-------------------------------------------------------------------------------
21-------------------------------------------------------------------------------
23
22
24
23
@@ -83,7 +82,7 @@ formatItem withColor verb Item{..} =
83 maybe mempty (brackets . fromString . locationToString) _itemLoc <>
82 maybe mempty (brackets . fromString . locationToString) _itemLoc <>
84 fromText " " <> (unLogStr _itemMessage)
83 fromText " " <> (unLogStr _itemMessage)
85 where
84 where
86− nowStr = fromString $ formatTime LC.defaultTimeLocale "%Y-%m-%d %H:%M:%S" _itemTime
85+ nowStr = fromText (formatAsLogTime _itemTime)
87 ks = map brackets $ getKeys verb _itemPayload
86 ks = map brackets $ getKeys verb _itemPayload
88 renderSeverity' s = case s of
87 renderSeverity' s = case s of
89 EmergencyS -> red $ renderSeverity s
88 EmergencyS -> red $ renderSeverity s
katip/test/Katip/Tests/Format/Time.hsnew file+73
@@ -0,0 +1,73 @@
1+
2+module Katip.Tests.Format.Time
3+ ( tests
4+ ) where
5+
6+import Data.Aeson (toJSON)
7+import qualified Data.Text as Text
8+import Data.Time
9+import Data.Time.Clock.POSIX
10+import qualified Data.Time.Locale.Compat as LC
11+
12+import Test.Tasty
13+import Test.Tasty.HUnit
14+import Test.Tasty.QuickCheck
15+
16+import Katip.Format.Time
17+
18+tests :: TestTree
19+tests = testGroup "Katip.Format.Time"
20+ [ testCase "formatAsLogTime" $ do
21+ assertEqual "time 1" (formatDT t1) (formatAsLogTime t1)
22+ assertEqual "time 2" (formatDT t2) (formatAsLogTime t2)
23+ assertEqual "time 3" (formatDT t3) (formatAsLogTime t3)
24+
25+ , testCase "formatAsIso8601" $ do
26+ assertEqual "time 1" (formatDTISO t1) (formatAsIso8601 t1)
27+ assertEqual "time 2" (formatDTISO t2) (formatAsIso8601 t2)
28+ assertEqual "time 3" (formatDTISO t3) (formatAsIso8601 t3)
29+
30+ , testCase "formatAsIso8601 Aeson" $ do
31+ assertEqual "time 1" (toJSON t1) (toJSON $ formatAsIso8601 t1)
32+ assertEqual "time 2" (toJSON t2) (toJSON $ formatAsIso8601 t2)
33+ assertEqual "time 3" (toJSON t3) (toJSON $ formatAsIso8601 t3)
34+
35+
36+ , testProperty "LogTime same as Date.Time" $ \(ArbUTCTime t) ->
37+ prop_format_log t
38+
39+ , testProperty "ISO 8601 same as Date.Time" $ \(ArbUTCTime t) ->
40+ prop_format_iso t
41+
42+ , testProperty "ISO 8601 same as Aeson" $ \(ArbUTCTime t) ->
43+ prop_format_aeson t
44+
45+ ]
46+ where
47+ t1 = UTCTime (fromGregorian 2016 12 34) 5025.123456789012
48+ t2 = UTCTime (fromGregorian 2016 1 23) 5025.123
49+ t3 = UTCTime (fromGregorian 16 12 1) 025
50+
51+formatDT :: UTCTime -> Text.Text
52+formatDT = Text.pack . formatTime LC.defaultTimeLocale "%0Y-%m-%d %H:%M:%S"
53+
54+formatDTISO :: UTCTime -> Text.Text
55+formatDTISO = Text.pack . formatTime LC.defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%QZ"
56+
57+prop_format_log :: UTCTime -> Property
58+prop_format_log a = formatDT a === formatAsLogTime a
59+
60+prop_format_iso :: UTCTime -> Property
61+prop_format_iso a = formatDTISO a === formatAsIso8601 a
62+
63+prop_format_aeson :: UTCTime -> Property
64+prop_format_aeson a = toJSON a === toJSON (formatAsIso8601 a)
65+
66+
67+newtype ArbUTCTime = ArbUTCTime {
68+ unArbUTCTime :: UTCTime
69+ } deriving (Show)
70+
71+instance Arbitrary ArbUTCTime where
72+ arbitrary = ArbUTCTime . posixSecondsToUTCTime . fromInteger
73+ <$> arbitrary
katip/test/Main.hs+2
@@ -4,6 +4,7 @@ module Main (main) where
4import Test.Tasty
4import Test.Tasty
5-------------------------------------------------------------------------------
5-------------------------------------------------------------------------------
6import qualified Katip.Tests
6import qualified Katip.Tests
7+import qualified Katip.Tests.Format.Time
7import qualified Katip.Tests.Scribes.Handle
8import qualified Katip.Tests.Scribes.Handle
8-------------------------------------------------------------------------------
9-------------------------------------------------------------------------------
9
10
@@ -15,5 +16,6 @@ testSuite :: TestTree
15testSuite = testGroup "katip"
16testSuite = testGroup "katip"
16 [
17 [
17 Katip.Tests.tests
18 Katip.Tests.tests
19+ , Katip.Tests.Format.Time.tests
18 , Katip.Tests.Scribes.Handle.tests
20 , Katip.Tests.Scribes.Handle.tests
19 ]
21 ]