Fast and correct aeson instances for UTCTime

src/Data/Thyme/Calendar/WeekDate.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 #if __GLASGOW_HASKELL__ == 706
-{-# OPTIONS_GHC -fsimpl-tick-factor=120 #-} -- 7.6.3 only, it seems; fixes #29
+{-# OPTIONS_GHC -fsimpl-tick-factor=180 #-} -- 7.6.3 only, it seems; fixes #29
 #endif
 
 #include "thyme.h"
@@ -120,4 +120,3 @@ fromWeekDate y w d = weekDate # WeekDate y w d
 {-# INLINE fromWeekDateValid #-}
 fromWeekDateValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day
 fromWeekDateValid y w d = weekDateValid (WeekDate y w d)
-

src/Data/Thyme/Clock/TAI.hs

@@ -40,7 +40,9 @@ module Data.Thyme.Clock.TAI
 import Prelude
 #if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
+import Data.Monoid (mempty)
 #endif
+
 import Control.DeepSeq
 import Control.Lens
 import Control.Monad
@@ -354,4 +356,3 @@ utcToTAITime = view . absoluteTime
 {-# INLINE taiToUTCTime #-}
 taiToUTCTime :: TAIUTCMap -> AbsoluteTime -> UTCTime
 taiToUTCTime = review . absoluteTime
-

src/Data/Thyme/Format.hs

@@ -30,6 +30,9 @@ import Control.Applicative
 #if SHOW_INTERNAL
 import Control.Arrow
 #endif
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid (mempty)
+#endif
 import Control.Lens
 import Control.Monad.Trans
 import Control.Monad.State.Strict
@@ -985,4 +988,3 @@ timeZoneParser = zone "TAI" 0 False <|> zone "UT1" 0 False
     zone name offset dst = TimeZone offset dst name <$ P.string (S.pack name)
     ($+) h m = h * 60 + m
     ($-) h m = negate (h * 60 + m)
-

src/Data/Thyme/Format/Aeson.hs

@@ -23,8 +23,13 @@ import Data.Data
 import Data.Monoid
 #endif
 import Data.Text (pack, unpack)
+import Data.Text.Encoding (decodeUtf8)
 import qualified Data.Text as T
 import Data.Thyme
+import Data.Thyme.Format.DateFast (parseFastUtc)
+import Data.Thyme.Format.DateEncode (utcTimeBuilder, quote)
+import Data.ByteString.Builder (toLazyByteString)
+import Data.ByteString.Lazy (toStrict)
 
 -- Copyright:   (c) 2011, 2012, 2013 Bryan O'Sullivan
 --              (c) 2011 MailRank, Inc.
@@ -94,15 +99,14 @@ instance FromJSON ZonedTime where
     parseJSON v = typeMismatch "ZonedTime" v
 
 instance ToJSON UTCTime where
-    toJSON t = String $ pack $ formatTime defaultTimeLocale format t
-      where
-        format = "%FT%T." ++ formatMillis t ++ "Z"
+#if MIN_VERSION_aeson(0,11,2)
+    toEncoding t = unsafeToEncoding $ quote (utcTimeBuilder t)
+    {-# INLINE toEncoding #-}
+#endif
+    toJSON t = String $ decodeUtf8 $ toStrict $ toLazyByteString (utcTimeBuilder t)
     {-# INLINE toJSON #-}
 
+-- For some unexaplainable reason the fast Scanner parser doesn't seem to work on 7.6
 instance FromJSON UTCTime where
-    parseJSON = withText "UTCTime" $ \t ->
-        case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
-          Just d -> pure d
-          _      -> fail "could not parse ISO-8601 date"
+    parseJSON = withText "UTCTime" $ parseFastUtc
     {-# INLINE parseJSON #-}
-

src/Data/Thyme/Format/DateEncode.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+-- |
+-- Copied and adapted from aeson
+-- Copyright:   (c) 2011 MailRank, Inc.
+--              (c) 2013 Simon Meier <[email protected]>
+-- License:     BSD3
+-- Maintainer:  Bryan O'Sullivan <[email protected]>
+
+module Data.Thyme.Format.DateEncode
+  (
+      utcTimeBuilder
+    , quote
+  ) where
+
+import Control.Lens (view)
+import Data.ByteString.Builder as B
+import Data.ByteString.Builder.Prim as BP
+import Data.Char (chr)
+import Data.Monoid ((<>))
+import Data.Thyme.Clock
+import Data.Thyme.Calendar
+
+-- | Add quotes surrounding a builder
+quote :: Builder -> Builder
+quote b = B.char8 '"' <> b <> B.char8 '"'
+
+ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a
+ascii4 cs = BP.liftFixedToBounded $ (const cs) >$<
+    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
+{-# INLINE ascii4 #-}
+
+ascii6 :: (Char, (Char, (Char, (Char, (Char, Char))))) -> BP.BoundedPrim a
+ascii6 cs = BP.liftFixedToBounded $ (const cs) >$<
+    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
+{-# INLINE ascii6 #-}
+
+ascii8 :: (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
+       -> BP.BoundedPrim a
+ascii8 cs = BP.liftFixedToBounded $ (const cs) >$<
+    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*<
+    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
+{-# INLINE ascii8 #-}
+
+day :: Day -> Builder
+day dd = encodeYear yr <>
+         BP.primBounded (ascii6 ('-',(mh,(ml,('-',(dh,dl)))))) ()
+  where (yr,m,d)    = toGregorian dd
+        !(T mh ml)  = twoDigits m
+        !(T dh dl)  = twoDigits d
+        encodeYear y
+            | y >= 1000 = B.intDec y
+            | y > 0 =
+                let (ab,c) =  y `quotRem` 10
+                    (a,b)  = ab `quotRem` 10
+                in BP.primBounded (ascii4 ('0',(digit a,(digit b,digit c)))) ()
+            | otherwise =
+                error "Data.Aeson.Encode.Builder.day:  years BCE not supported"
+{-# INLINE day #-}
+
+timeOfDay64 :: DiffTime -> Builder
+timeOfDay64 nom
+  | frac == 0 = hhmmss -- omit subseconds if 0
+  | otherwise = hhmmss <> BP.primBounded showFrac frac
+  where
+    micros = toMicroseconds nom
+    (h, m') = micros `quotRem` (3600 * micro)
+    (m, s) = m' `quotRem` (60 * micro)
+
+    hhmmss  = BP.primBounded (ascii8 (hh,(hl,(':',(mh,(ml,(':',(sh,sl)))))))) ()
+    !(T hh hl)  = twoDigits (fromIntegral h)
+    !(T mh ml)  = twoDigits (fromIntegral m)
+    !(T sh sl)  = twoDigits (fromIntegral real)
+    (real,frac) = s `quotRem` micro
+    showFrac = (\x -> ('.', x)) >$< (BP.liftFixedToBounded BP.char7 >*< trunc6)
+    trunc6  = ((`quotRem` milli) . fromIntegral) >$<
+              BP.condB (\(_,y) -> y == 0) (fst >$< trunc3) (digits3 >*< trunc3)
+    digits3 = (`quotRem` 10) >$< (digits2 >*< digits1)
+    digits2 = (`quotRem` 10) >$< (digits1 >*< digits1)
+    digits1 = BP.liftFixedToBounded (digit >$< BP.char7)
+    trunc3  = BP.condB (== 0) BP.emptyB $
+              (`quotRem` 100) >$< (digits1 >*< trunc2)
+    trunc2  = BP.condB (== 0) BP.emptyB $
+              (`quotRem` 10)  >$< (digits1 >*< trunc1)
+    trunc1  = BP.condB (== 0) BP.emptyB digits1
+
+    micro      =       1000000 -- number of microseconds in 1 second
+    milli      =          1000 -- number of milliseconds in 1 second
+{-# INLINE timeOfDay64 #-}
+
+dayTime :: Day -> DiffTime -> Builder
+dayTime d t = day d <> B.char7 'T' <> timeOfDay64 t
+{-# INLINE dayTime #-}
+
+utcTimeBuilder :: UTCTime -> B.Builder
+utcTimeBuilder utc = dayTime d s <> B.char7 'Z'
+  where
+    UTCView d s = view utcTime utc
+{-# INLINE utcTimeBuilder #-}
+
+data T = T {-# UNPACK #-} !Char {-# UNPACK #-} !Char
+
+twoDigits :: Int -> T
+twoDigits a     = T (digit hi) (digit lo)
+  where (hi,lo) = a `quotRem` 10
+
+digit :: Int -> Char
+digit x = chr (x + 48)

src/Data/Thyme/Format/DateFast.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NamedFieldPuns    #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+module Data.Thyme.Format.DateFast (
+    parseFastUtc
+) where
+
+#if !MIN_VERSION_base(4,8,0)
+import           Control.Applicative
+#endif
+import           Control.Lens        (from, view)
+import           Control.Monad       (unless, when, void)
+import qualified Data.ByteString     as BS
+import           Data.Int            (Int64)
+import           Data.List           (foldl1')
+import qualified Data.Text           as T
+import           Data.Text.Encoding  (encodeUtf8)
+import           Data.Thyme.Calendar (fromGregorian)
+import           Data.Thyme.Clock
+import           Data.Word           (Word8)
+import           Scanner             (Scanner)
+import qualified Scanner             as S
+
+satisfy :: (Word8 -> Bool) -> Scanner Word8
+satisfy f = do
+  c <- S.anyWord8
+  unless (f c) $ fail $ "Unexpected " ++ show c
+  return c
+{-# INLINE satisfy #-}
+
+satisfyChar :: (Char -> Bool) -> Scanner Char
+satisfyChar f = do
+  c <- S.anyChar8
+  unless (f c) $ fail $ "Unexpected " ++ show c
+  return c
+{-# INLINE satisfyChar #-}
+
+digit :: Scanner Int
+digit = do
+  c <- satisfy (\c -> c >= 48 && c <= 57)
+  return $ fromIntegral c - 48
+{-# INLINE digit #-}
+
+many1digit :: Scanner [Int]
+many1digit = do
+  start <- digit
+  rest <- S.takeWhile (\c -> c >=48 && c <= 57)
+  let nums = map (fromIntegral . subtract 48) $ BS.unpack rest
+  return (start : nums)
+{-# INLINE many1digit #-}
+
+-- | Parse integer number read up to maxdigits; stop if different character is found
+parseNumber2 :: Scanner Int
+parseNumber2 = do -- Specialized version for 2 digits
+  c1 <- digit
+  c2 <- digit
+  return (10 * c1 + c2)
+{-# INLINE parseNumber2 #-}
+
+parseNumber4 :: Scanner Int
+parseNumber4 = do -- Specialized version for 2 digits
+  c1 <- digit
+  c2 <- digit
+  c3 <- digit
+  c4 <- digit
+  return (1000 * c1 + 100 * c2 + 10 * c3 + c4)
+{-# INLINE parseNumber4 #-}
+
+toffset :: Scanner Int64
+toffset = do
+  hours <- parseNumber2
+  -- optional ':'
+  colon <- S.lookAheadChar8
+  when (colon == Just ':') (S.char8 ':')
+  minutes <- parseNumber2
+  return $ fromIntegral $ hours * 3600 + minutes * 60
+{-# INLINE toffset #-}
+
+
+parserRfc :: Scanner UTCTime
+parserRfc = do
+    year <- parseNumber4
+    S.char8 '-'
+    month <- parseNumber2
+    S.char8 '-'
+    dayofmonth <- parseNumber2
+    S.char8 'T'
+    hour <- fromIntegral <$> parseNumber2
+    S.char8 ':'
+    minute <- fromIntegral <$> parseNumber2
+    S.char8 ':'
+    seconds <- fromIntegral <$> parseNumber2
+    dot <- S.lookAheadChar8
+    micros <- case dot of
+        Just '.' -> do
+            void S.anyChar8
+            numlst <- take 6 <$> many1digit
+            let num = foldl1' (\a b -> 10 * a + b) numlst
+            return $ fromIntegral $ num * (10 ^ (6 - length numlst))
+        Just _ -> return 0
+        Nothing -> fail "Not enough input"
+    zone <- satisfyChar (\c -> c == '+' || c == '-' || c == 'Z')
+    offset <- case zone of
+          'Z' -> return 0
+          '+' -> toffset
+          '-' -> negate <$> toffset
+          _ -> fail "Expected Z/+/- while parsing date."
+    let totalMicro = micros + 1000000 * seconds + 1000000 * 60 * minute + 1000000 * 3600 * hour
+                     - offset * 1000000 :: Int64
+        tdiff = view (from microseconds) totalMicro
+        tday = fromGregorian year month dayofmonth
+    return $ view (from utcTime) (UTCView tday tdiff)
+
+parseFastUtc :: MonadFail m => T.Text -> m UTCTime
+parseFastUtc t =
+  case S.scanOnly parserRfc (encodeUtf8 t) of
+        Right d -> return d
+        Left err -> fail $ "could not parse ISO-8601 date: " ++ err

tests/bench.hs

@@ -1,2 +1,23 @@
+module Main where
+
+import Criterion.Main
+
+import Data.Thyme.Clock as TH
+import Data.Thyme.Format.Aeson ()
+import Data.Time.Clock as TI
+import qualified Data.Aeson as AE
+import qualified Data.ByteString.Lazy as BL
+
 main :: IO ()
-main = return ()
+main = do
+  tinow <- TI.getCurrentTime
+  thnow <- TH.getCurrentTime
+
+  let encoded = AE.encode thnow
+
+  defaultMain [
+      bgroup "time encode" [ bench "time/encode"   $ nf AE.encode tinow
+                           , bench "thyme/encode"  $ nf AE.encode thnow ]
+    , bgroup "time decode" [ bench "time/decode"   $ nf (AE.decode :: BL.ByteString -> Maybe TI.UTCTime) encoded
+                           , bench "thyme/decode"  $ nf (AE.decode :: BL.ByteString -> Maybe TH.UTCTime) encoded ]
+    ]

tests/sanity.hs

@@ -7,6 +7,9 @@
 
 import Prelude
 
+#if !MIN_VERSION_base(4,8,0)
+import           Control.Applicative
+#endif
 import Control.Arrow
 import Control.Lens
 import qualified Data.Attoparsec.ByteString.Char8 as P
@@ -17,6 +20,8 @@ import Data.Thyme.Time
 import qualified Data.Time as T
 import qualified Data.Time.Calendar.OrdinalDate as T
 import Test.QuickCheck
+import qualified Data.Aeson as AE
+import Data.Thyme.Format.Aeson ()
 
 import Common
 
@@ -49,6 +54,25 @@ prop_toOrdinalDate :: Day -> Bool
 prop_toOrdinalDate day =
     fromIntegral `first` toOrdinalDate day == T.toOrdinalDate (thyme # day)
 
+newtype AcUTCTime = AcUTCTime UTCTime deriving (Show)
+instance Arbitrary AcUTCTime where
+  arbitrary = AcUTCTime <$> (arbitrary `suchThat` (\d -> d >= year1 && d < yearMax))
+    where
+      year1 = view (from utcTime) $ UTCView (fromGregorian 1 1 1) 0
+      yearMax = view (from utcTime) $ UTCView (fromGregorian 10000 1 1) 0
+  shrink (AcUTCTime a) = map AcUTCTime (shrink a)
+
+prop_aeson :: AcUTCTime -> Property
+prop_aeson (AcUTCTime t') =
+#if MIN_VERSION_QuickCheck(2,7,0)
+    counterexample desc (t == Just [t'])
+#else
+    printTestCase desc (t == Just [t'])
+#endif
+  where
+    t = AE.decode (AE.encode [t'])
+    desc = "Orig: " ++ show t' ++ ", Aeson: " ++ show (AE.encode t') ++ ", BackOrig: " ++ show t
+
 prop_formatTime :: Spec -> RecentTime -> Property
 prop_formatTime (Spec spec) (RecentTime t@(review thyme -> t'))
 #if MIN_VERSION_QuickCheck(2,7,0)
@@ -90,9 +114,8 @@ main = exit . all isSuccess =<< sequence
     , qc 10000 prop_toOrdinalDate
     , qc  1000 prop_formatTime
     , qc  1000 prop_parseTime
-
+    , qc  1000 prop_aeson
     ] where
     isSuccess r = case r of Success {} -> True; _ -> False
     qc :: Testable prop => Int -> prop -> IO Result
     qc n = quickCheckWithResult stdArgs {maxSuccess = n, maxSize = n}
-