Skip to content

Commit be5ca29

Browse files
ondraptmcgilchrist
ondrap
authored and
tmcgilchrist
committed
Added fast parsing instance for Aeson + aeson tests using scanner.
Fast encoding of UTCTime to JSON.
1 parent 103a943 commit be5ca29

File tree

6 files changed

+276
-16
lines changed

6 files changed

+276
-16
lines changed

‎src/Data/Thyme/Format/Aeson.hs‎

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -23,8 +23,13 @@ import Data.Data
2323
import Data.Monoid
2424
#endif
2525
import Data.Text (pack, unpack)
26+
import Data.Text.Encoding (decodeUtf8)
2627
import qualified Data.Text as T
2728
import Data.Thyme
29+
import Data.Thyme.Format.DateFast (parseFastUtc)
30+
import Data.Thyme.Format.DateEncode (utcTimeBuilder, quote)
31+
import Data.ByteString.Builder (toLazyByteString)
32+
import Data.ByteString.Lazy (toStrict)
2833

2934
-- Copyright: (c) 2011, 2012, 2013 Bryan O'Sullivan
3035
-- (c) 2011 MailRank, Inc.
@@ -94,15 +99,11 @@ instance FromJSON ZonedTime where
9499
parseJSON v = typeMismatch "ZonedTime" v
95100

96101
instance ToJSON UTCTime where
97-
toJSON t = String $ pack $ formatTime defaultTimeLocale format t
98-
where
99-
format = "%FT%T." ++ formatMillis t ++ "Z"
102+
toEncoding t = unsafeToEncoding $ quote (utcTimeBuilder t)
103+
{-# INLINE toEncoding #-}
104+
toJSON t = String $ decodeUtf8 $ toStrict $ toLazyByteString (utcTimeBuilder t)
100105
{-# INLINE toJSON #-}
101106

102107
instance FromJSON UTCTime where
103-
parseJSON = withText "UTCTime" $ \t ->
104-
case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
105-
Just d -> pure d
106-
_ -> fail "could not parse ISO-8601 date"
108+
parseJSON = withText "UTCTime" $ parseFastUtc
107109
{-# INLINE parseJSON #-}
108-

‎src/Data/Thyme/Format/DateEncode.hs‎

Lines changed: 109 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,109 @@
1+
{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2+
{-# OPTIONS_HADDOCK hide #-}
3+
4+
-- |
5+
-- Copied and adapted from aeson
6+
-- Copyright: (c) 2011 MailRank, Inc.
7+
-- (c) 2013 Simon Meier <[email protected]>
8+
-- License: BSD3
9+
-- Maintainer: Bryan O'Sullivan <[email protected]>
10+
11+
module Data.Thyme.Format.DateEncode
12+
(
13+
utcTimeBuilder
14+
, quote
15+
) where
16+
17+
import Control.Lens (view)
18+
import Data.ByteString.Builder as B
19+
import Data.ByteString.Builder.Prim as BP
20+
import Data.Char (chr)
21+
import Data.Monoid ((<>))
22+
import Data.Thyme.Clock
23+
import Data.Thyme.Calendar
24+
25+
-- | Add quotes surrounding a builder
26+
quote :: Builder -> Builder
27+
quote b = B.char8 '"' <> b <> B.char8 '"'
28+
29+
ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a
30+
ascii4 cs = BP.liftFixedToBounded $ (const cs) >$<
31+
BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
32+
{-# INLINE ascii4 #-}
33+
34+
ascii6 :: (Char, (Char, (Char, (Char, (Char, Char))))) -> BP.BoundedPrim a
35+
ascii6 cs = BP.liftFixedToBounded $ (const cs) >$<
36+
BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
37+
{-# INLINE ascii6 #-}
38+
39+
ascii8 :: (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
40+
-> BP.BoundedPrim a
41+
ascii8 cs = BP.liftFixedToBounded $ (const cs) >$<
42+
BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*<
43+
BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
44+
{-# INLINE ascii8 #-}
45+
46+
day :: Day -> Builder
47+
day dd = encodeYear yr <>
48+
BP.primBounded (ascii6 ('-',(mh,(ml,('-',(dh,dl)))))) ()
49+
where (yr,m,d) = toGregorian dd
50+
!(T mh ml) = twoDigits m
51+
!(T dh dl) = twoDigits d
52+
encodeYear y
53+
| y >= 1000 = B.intDec y
54+
| y > 0 =
55+
let (ab,c) = y `quotRem` 10
56+
(a,b) = ab `quotRem` 10
57+
in BP.primBounded (ascii4 ('0',(digit a,(digit b,digit c)))) ()
58+
| otherwise =
59+
error "Data.Aeson.Encode.Builder.day: years BCE not supported"
60+
{-# INLINE day #-}
61+
62+
timeOfDay64 :: DiffTime -> Builder
63+
timeOfDay64 nom
64+
| frac == 0 = hhmmss -- omit subseconds if 0
65+
| otherwise = hhmmss <> BP.primBounded showFrac frac
66+
where
67+
micros = toMicroseconds nom
68+
(h, m') = micros `quotRem` (3600 * micro)
69+
(m, s) = m' `quotRem` (60 * micro)
70+
71+
hhmmss = BP.primBounded (ascii8 (hh,(hl,(':',(mh,(ml,(':',(sh,sl)))))))) ()
72+
!(T hh hl) = twoDigits (fromIntegral h)
73+
!(T mh ml) = twoDigits (fromIntegral m)
74+
!(T sh sl) = twoDigits (fromIntegral real)
75+
(real,frac) = s `quotRem` micro
76+
showFrac = (\x -> ('.', x)) >$< (BP.liftFixedToBounded BP.char7 >*< trunc6)
77+
trunc6 = ((`quotRem` milli) . fromIntegral) >$<
78+
BP.condB (\(_,y) -> y == 0) (fst >$< trunc3) (digits3 >*< trunc3)
79+
digits3 = (`quotRem` 10) >$< (digits2 >*< digits1)
80+
digits2 = (`quotRem` 10) >$< (digits1 >*< digits1)
81+
digits1 = BP.liftFixedToBounded (digit >$< BP.char7)
82+
trunc3 = BP.condB (== 0) BP.emptyB $
83+
(`quotRem` 100) >$< (digits1 >*< trunc2)
84+
trunc2 = BP.condB (== 0) BP.emptyB $
85+
(`quotRem` 10) >$< (digits1 >*< trunc1)
86+
trunc1 = BP.condB (== 0) BP.emptyB digits1
87+
88+
micro = 1000000 -- number of microseconds in 1 second
89+
milli = 1000 -- number of milliseconds in 1 second
90+
{-# INLINE timeOfDay64 #-}
91+
92+
dayTime :: Day -> DiffTime -> Builder
93+
dayTime d t = day d <> B.char7 'T' <> timeOfDay64 t
94+
{-# INLINE dayTime #-}
95+
96+
utcTimeBuilder :: UTCTime -> B.Builder
97+
utcTimeBuilder utc = dayTime d s <> B.char7 'Z'
98+
where
99+
UTCView d s = view utcTime utc
100+
{-# INLINE utcTimeBuilder #-}
101+
102+
data T = T {-# UNPACK #-} !Char {-# UNPACK #-} !Char
103+
104+
twoDigits :: Int -> T
105+
twoDigits a = T (digit hi) (digit lo)
106+
where (hi,lo) = a `quotRem` 10
107+
108+
digit :: Int -> Char
109+
digit x = chr (x + 48)

‎src/Data/Thyme/Format/DateFast.hs‎

Lines changed: 114 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,114 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# OPTIONS_HADDOCK hide #-}
4+
5+
module Data.Thyme.Format.DateFast (
6+
parseFastUtc
7+
) where
8+
9+
import Control.Lens (from, view)
10+
import Control.Monad (unless, void)
11+
import qualified Data.ByteString as BS
12+
import Data.Int (Int64)
13+
import Data.List (foldl1')
14+
import qualified Data.Text as T
15+
import Data.Text.Encoding (encodeUtf8)
16+
import Data.Thyme.Calendar (fromGregorian)
17+
import Data.Thyme.Clock
18+
import Data.Word (Word8)
19+
import Scanner (Scanner)
20+
import qualified Scanner as S
21+
22+
satisfy :: (Word8 -> Bool) -> Scanner Word8
23+
satisfy f = do
24+
c <- S.anyWord8
25+
unless (f c) $ fail $ "Unexpected " ++ show c
26+
return c
27+
{-# INLINE satisfy #-}
28+
29+
satisfyChar :: (Char -> Bool) -> Scanner Char
30+
satisfyChar f = do
31+
c <- S.anyChar8
32+
unless (f c) $ fail $ "Unexpected " ++ show c
33+
return c
34+
{-# INLINE satisfyChar #-}
35+
36+
digit :: Scanner Int
37+
digit = do
38+
c <- satisfy (\c -> c >= 48 && c <= 57)
39+
return $ fromIntegral c - 48
40+
{-# INLINE digit #-}
41+
42+
many1digit :: Scanner [Int]
43+
many1digit = do
44+
start <- digit
45+
rest <- S.takeWhile (\c -> c >=48 && c <= 57)
46+
let nums = map (fromIntegral . subtract 48) $ BS.unpack rest
47+
return (start : nums)
48+
{-# INLINE many1digit #-}
49+
50+
-- | Parse integer number read up to maxdigits; stop if different character is found
51+
parseNumber2 :: Scanner Int
52+
parseNumber2 = do -- Specialized version for 2 digits
53+
c1 <- digit
54+
c2 <- digit
55+
return (10 * c1 + c2)
56+
{-# INLINE parseNumber2 #-}
57+
58+
parseNumber4 :: Scanner Int
59+
parseNumber4 = do -- Specialized version for 2 digits
60+
c1 <- digit
61+
c2 <- digit
62+
c3 <- digit
63+
c4 <- digit
64+
return (1000 * c1 + 100 * c2 + 10 * c3 + c4)
65+
{-# INLINE parseNumber4 #-}
66+
67+
toffset :: Scanner Int64
68+
toffset = do
69+
hours <- parseNumber2
70+
S.char8 ':'
71+
minutes <- parseNumber2
72+
return $ fromIntegral $ hours * 3600 + minutes * 60
73+
{-# INLINE toffset #-}
74+
75+
76+
parserRfc :: Scanner UTCTime
77+
parserRfc = do
78+
year <- parseNumber4
79+
S.char8 '-'
80+
month <- parseNumber2
81+
S.char8 '-'
82+
dayofmonth <- parseNumber2
83+
S.char8 'T'
84+
hour <- fromIntegral <$> parseNumber2
85+
S.char8 ':'
86+
minute <- fromIntegral <$> parseNumber2
87+
S.char8 ':'
88+
seconds <- fromIntegral <$> parseNumber2
89+
dot <- S.lookAheadChar8
90+
micros <- case dot of
91+
Just '.' -> do
92+
void S.anyChar8
93+
numlst <- take 6 <$> many1digit
94+
let num = foldl1' (\a b -> 10 * a + b) numlst
95+
return $ fromIntegral $ num * (10 ^ (6 - length numlst))
96+
Just _ -> return 0
97+
Nothing -> fail "Not enough input"
98+
zone <- satisfyChar (\c -> c == '+' || c == '-' || c == 'Z')
99+
offset <- case zone of
100+
'Z' -> return 0
101+
'+' -> toffset
102+
'-' -> negate <$> toffset
103+
_ -> fail "Expected Z/+/- while parsing date."
104+
let totalMicro = micros + 1000000 * seconds + 1000000 * 60 * minute + 1000000 * 3600 * hour
105+
- offset * 1000000 :: Int64
106+
tdiff = view (from microseconds) totalMicro
107+
tday = fromGregorian year month dayofmonth
108+
return $ UTCTime tday tdiff
109+
110+
parseFastUtc :: Monad m => T.Text -> m UTCTime
111+
parseFastUtc t =
112+
case S.scanOnly parserRfc (encodeUtf8 t) of
113+
Right d -> pure d
114+
Left err -> fail $ "could not parse ISO-8601 date: " ++ err

‎tests/bench.hs‎

Lines changed: 22 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,2 +1,23 @@
1+
module Main where
2+
3+
import Criterion.Main
4+
5+
import Data.Thyme.Clock as TH
6+
import Data.Thyme.Format.Aeson ()
7+
import Data.Time.Clock as TI
8+
import qualified Data.Aeson as AE
9+
import qualified Data.ByteString.Lazy as BL
10+
111
main :: IO ()
2-
main = return ()
12+
main = do
13+
tinow <- TI.getCurrentTime
14+
thnow <- TH.getCurrentTime
15+
16+
let encoded = AE.encode thnow
17+
18+
defaultMain [
19+
bgroup "time encode" [ bench "time/encode" $ nf AE.encode tinow
20+
, bench "thyme/encode" $ nf AE.encode thnow ]
21+
, bgroup "time decode" [ bench "time/decode" $ nf (AE.decode :: BL.ByteString -> Maybe TI.UTCTime) encoded
22+
, bench "thyme/decode" $ nf (AE.decode :: BL.ByteString -> Maybe TH.UTCTime) encoded ]
23+
]

‎tests/sanity.hs‎

Lines changed: 14 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,8 @@ import Data.Thyme.Time
1717
import qualified Data.Time as T
1818
import qualified Data.Time.Calendar.OrdinalDate as T
1919
import Test.QuickCheck
20+
import qualified Data.Aeson as AE
21+
import Data.Thyme.Format.Aeson ()
2022

2123
import Common
2224

@@ -49,6 +51,17 @@ prop_toOrdinalDate :: Day -> Bool
4951
prop_toOrdinalDate day =
5052
fromIntegral `first` toOrdinalDate day == T.toOrdinalDate (thyme # day)
5153

54+
newtype AcUTCTime = AcUTCTime { getAc :: UTCTime } deriving (Show)
55+
instance Arbitrary AcUTCTime where
56+
arbitrary = AcUTCTime <$> (arbitrary `suchThat` (\d -> d >= year1 && d < yearMax))
57+
where
58+
year1 = UTCTime (fromGregorian 1 1 1) 0
59+
yearMax = UTCTime (fromGregorian 10000 1 1) 0
60+
shrink (AcUTCTime a) = map AcUTCTime (shrink a)
61+
62+
prop_aeson :: AcUTCTime -> Bool
63+
prop_aeson a = AE.decode (AE.encode (getAc a)) == Just (getAc a)
64+
5265
prop_formatTime :: Spec -> RecentTime -> Property
5366
prop_formatTime (Spec spec) (RecentTime t@(review thyme -> t'))
5467
#if MIN_VERSION_QuickCheck(2,7,0)
@@ -90,9 +103,8 @@ main = exit . all isSuccess =<< sequence
90103
, qc 10000 prop_toOrdinalDate
91104
, qc 1000 prop_formatTime
92105
, qc 1000 prop_parseTime
93-
106+
, qc 1000 prop_aeson
94107
] where
95108
isSuccess r = case r of Success {} -> True; _ -> False
96109
qc :: Testable prop => Int -> prop -> IO Result
97110
qc n = quickCheckWithResult stdArgs {maxSuccess = n, maxSize = n}
98-

‎thyme.cabal‎

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -81,7 +81,8 @@ library
8181
Data.Thyme.Calendar.Internal
8282
Data.Thyme.Clock.Internal
8383
Data.Thyme.Format.Internal
84-
Data.Thyme.TrueName
84+
Data.Thyme.Format.DateFast
85+
Data.Thyme.Format.DateEncode
8586
if !(flag(lens) || flag(docs))
8687
other-modules: Control.Lens
8788
build-depends:
@@ -101,8 +102,8 @@ library
101102
time >= 1.4,
102103
vector >= 0.9,
103104
vector-th-unbox >= 0.2.1.0,
104-
vector-space >= 0.8
105-
105+
vector-space >= 0.8,
106+
scanner
106107
if os(windows)
107108
build-depends: Win32
108109
if os(darwin) || os(freebsd)
@@ -139,6 +140,7 @@ test-suite sanity
139140
text,
140141
thyme,
141142
time,
143+
aeson,
142144
vector-space
143145
if flag(lens)
144146
build-depends: lens
@@ -189,12 +191,13 @@ benchmark bench
189191
thyme,
190192
time,
191193
vector,
192-
vector-space
194+
vector-space,
195+
aeson,
196+
bytestring
193197
if flag(lens)
194198
build-depends: lens
195199
else
196200
build-depends: profunctors
197201
ghc-options: -Wall
198202

199203
-- vim: et sw=4 ts=4 sts=4:
200-

0 commit comments

Comments
 (0)