katip-0.8.8.1: src/Katip/Format/Time.hs
{-# LANGUAGE CPP #-}
-- | Time and memory efficient time encoding helper functions.
module Katip.Format.Time
( formatAsLogTime,
formatAsIso8601,
)
where
import Control.Monad.ST (ST)
import Data.Int (Int64)
import Data.Text (Text)
import qualified Data.Text.Array as TA
import Data.Text.Internal (Text (..))
import Data.Time (Day, DiffTime, UTCTime (..), toGregorian)
import Data.Word
#if MIN_VERSION_text(2,0,0)
(Word8)
#else
(Word16)
#endif
import Unsafe.Coerce (unsafeCoerce)
-- Note: All functions here are optimized to never allocate anything
-- on heap. At least on ghc 8.0.1 no extra strictness annotations are
-- seem to be needed.
--
-- Exported functions are INLINEABLE
-- | Format 'UTCTime' into a short human readable format.
--
-- >>> formatAsLogTime $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012
-- "2016-01-23 01:23:45"
formatAsLogTime :: UTCTime -> Text
formatAsLogTime (UTCTime day time) = toText $
TA.run2 $ do
buf <- TA.new 19 -- length "2016-10-20 12:34:56"
_ <- writeDay buf 0 day
TA.unsafeWrite buf 10 0x20 -- space
_ <- writeTimeOfDay False buf 11 (diffTimeOfDay64 time)
return (buf, 19)
where
toText (arr, len) = Text arr 0 len
{-# INLINE formatAsLogTime #-}
-- | Format 'UTCTime' into a Iso8601 format.
--
-- Note that this function may overcommit up to 12*2 bytes, depending
-- on sub-second precision. If this is an issue, make a copy with a
-- 'Data.Text.copy'.
--
-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012
-- "2016-11-23T01:23:45.123456789012Z"
-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025.123
-- "2016-01-23T01:23:45.123Z"
-- >>> formatAsIso8601 $ UTCTime (fromGregorian 2016 1 23) 5025
-- "2016-01-23T01:23:45Z"
--
formatAsIso8601 :: UTCTime -> Text
formatAsIso8601 (UTCTime day time) = toText $
TA.run2 $ do
buf <- TA.new 33 -- length "2016-10-20 12:34:56.123456789012Z"
_ <- writeDay buf 0 day
TA.unsafeWrite buf 10 0x54 -- T
next <- writeTimeOfDay True buf 11 (diffTimeOfDay64 time)
TA.unsafeWrite buf next 0x5A -- Z
return (buf, next + 1)
where
toText (arr, len) = Text arr 0 len
{-# INLINE formatAsIso8601 #-}
-- | Writes the @YYYY-MM-DD@ part of timestamp
writeDay :: TA.MArray s -> Int -> Day -> ST s Int
writeDay buf off day =
do
TA.unsafeWrite buf (off + 0) (digit y1)
TA.unsafeWrite buf (off + 1) (digit y2)
TA.unsafeWrite buf (off + 2) (digit y3)
TA.unsafeWrite buf (off + 3) (digit y4)
TA.unsafeWrite buf (off + 4) 0x2d -- dash
TA.unsafeWrite buf (off + 5) m1
TA.unsafeWrite buf (off + 6) m2
TA.unsafeWrite buf (off + 7) 0x2d -- dash
TA.unsafeWrite buf (off + 8) d1
TA.unsafeWrite buf (off + 9) d2
return (off + 10)
where
(yr, m, d) = toGregorian day
(y1, ya) = fromIntegral (abs yr) `quotRem` 1000
(y2, yb) = ya `quotRem` 100
(y3, y4) = yb `quotRem` 10
T m1 m2 = twoDigits m
T d1 d2 = twoDigits d
{-# INLINE writeDay #-}
-- | Write time of day, optionally with sub seconds
writeTimeOfDay :: Bool -> TA.MArray s -> Int -> TimeOfDay64 -> ST s Int
writeTimeOfDay doSubSeconds buf off (TOD hh mm ss) =
do
TA.unsafeWrite buf off h1
TA.unsafeWrite buf (off + 1) h2
TA.unsafeWrite buf (off + 2) 0x3A -- colon
TA.unsafeWrite buf (off + 3) m1
TA.unsafeWrite buf (off + 4) m2
TA.unsafeWrite buf (off + 5) 0x3A -- colon
TA.unsafeWrite buf (off + 6) s1
TA.unsafeWrite buf (off + 7) s2
if doSubSeconds && frac /= 0
then writeFracSeconds buf (off + 8) frac
else return (off + 8)
where
T h1 h2 = twoDigits hh
T m1 m2 = twoDigits mm
T s1 s2 = twoDigits (fromIntegral real)
(real, frac) = ss `quotRem` pico
pico = 1000000000000 -- number of picoseconds in 1 second
{-# INLINE writeTimeOfDay #-}
writeFracSeconds :: TA.MArray s -> Int -> Int64 -> ST s Int
writeFracSeconds buf off frac =
do
TA.unsafeWrite buf off 0x2e -- period
if mills == 0
then do
writeTrunc6 buf (off + 1) (fromIntegral mics)
else do
writeDigit6 buf (off + 1) (fromIntegral mics)
writeTrunc6 buf (off + 7) (fromIntegral mills)
where
(mics, mills) = frac `quotRem` micro
micro = 1000000 -- number of microseconds in 1 second
{-# INLINE writeFracSeconds #-}
writeDigit6 :: TA.MArray s -> Int -> Int -> ST s ()
writeDigit6 buf off i =
do
writeDigit3 buf off f1
writeDigit3 buf (off + 3) f2
where
(f1, f2) = i `quotRem` 1000
{-# INLINE writeDigit6 #-}
writeDigit3 :: TA.MArray s -> Int -> Int -> ST s ()
writeDigit3 buf off i =
do
TA.unsafeWrite buf off (digit d1)
TA.unsafeWrite buf (off + 1) (digit d2)
TA.unsafeWrite buf (off + 2) (digit d3)
where
(d1, d) = i `quotRem` 100
(d2, d3) = d `quotRem` 10
{-# INLINE writeDigit3 #-}
writeTrunc6 :: TA.MArray s -> Int -> Int -> ST s Int
writeTrunc6 buf off i =
if f2 == 0
then writeTrunc3 buf off f1
else do
writeDigit3 buf off f1
writeTrunc3 buf (off + 3) f2
where
(f1, f2) = i `quotRem` 1000
{-# INLINE writeTrunc6 #-}
writeTrunc3 :: TA.MArray s -> Int -> Int -> ST s Int
writeTrunc3 buf off i
| d == 0 = do
TA.unsafeWrite buf off (digit d1)
return (off + 1)
| d3 == 0 = do
TA.unsafeWrite buf off (digit d1)
TA.unsafeWrite buf (off + 1) (digit d2)
return (off + 2)
| otherwise = do
TA.unsafeWrite buf off (digit d1)
TA.unsafeWrite buf (off + 1) (digit d2)
TA.unsafeWrite buf (off + 2) (digit d3)
return (off + 3)
where
(d1, d) = i `quotRem` 100
(d2, d3) = d `quotRem` 10
{-# INLINE writeTrunc3 #-}
-- Following code was adapted from aeson package.
--
-- Copyright: (c) 2015-2016 Bryan O'Sullivan
-- License: BSD3
data T = T
#if MIN_VERSION_text(2,0,0)
{-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
#else
{-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16
#endif
twoDigits :: Int -> T
twoDigits a = T (digit hi) (digit lo)
where
(hi, lo) = a `quotRem` 10
digit :: Int ->
#if MIN_VERSION_text(2,0,0)
Word8
#else
Word16
#endif
digit x = fromIntegral (x + 48)
data TimeOfDay64
= TOD
{-# UNPACK #-} !Int
{-# UNPACK #-} !Int
{-# UNPACK #-} !Int64
diffTimeOfDay64 :: DiffTime -> TimeOfDay64
diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s
where
(h, mp) = fromIntegral pico `quotRem` 3600000000000000
(m, s) = mp `quotRem` 60000000000000
pico = unsafeCoerce t :: Integer