@@ -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