diff --git a/src/Data/Thyme/Calendar/WeekDate.hs b/src/Data/Thyme/Calendar/WeekDate.hs index fcc8ea1..cbad7e5 100644 --- a/src/Data/Thyme/Calendar/WeekDate.hs +++ b/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) - diff --git a/src/Data/Thyme/Clock/TAI.hs b/src/Data/Thyme/Clock/TAI.hs index 23c034c..337cd53 100644 --- a/src/Data/Thyme/Clock/TAI.hs +++ b/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 @@ -353,5 +355,4 @@ utcToTAITime m = view (absoluteTime m) -- @ {-# INLINE taiToUTCTime #-} taiToUTCTime :: TAIUTCMap -> AbsoluteTime -> UTCTime -taiToUTCTime m = review (absoluteTime m) - +taiToUTCTime m = review (absoluteTime m) \ No newline at end of file diff --git a/src/Data/Thyme/Format.hs b/src/Data/Thyme/Format.hs index 70115b9..2ed57bc 100644 --- a/src/Data/Thyme/Format.hs +++ b/src/Data/Thyme/Format.hs @@ -34,6 +34,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 @@ -989,4 +992,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) - diff --git a/src/Data/Thyme/Format/Aeson.hs b/src/Data/Thyme/Format/Aeson.hs index 0d8345f..dd1e200 100644 --- a/src/Data/Thyme/Format/Aeson.hs +++ b/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 #-} - diff --git a/src/Data/Thyme/Format/DateEncode.hs b/src/Data/Thyme/Format/DateEncode.hs new file mode 100644 index 0000000..06e1458 --- /dev/null +++ b/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 +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan + +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) diff --git a/src/Data/Thyme/Format/DateFast.hs b/src/Data/Thyme/Format/DateFast.hs new file mode 100644 index 0000000..ddeeb2d --- /dev/null +++ b/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 diff --git a/tests/bench.hs b/tests/bench.hs index 377b6b5..bd27e3d 100644 --- a/tests/bench.hs +++ b/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 ] + ] diff --git a/tests/sanity.hs b/tests/sanity.hs index 466860e..cd6079c 100644 --- a/tests/sanity.hs +++ b/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} - diff --git a/thyme.cabal b/thyme.cabal index 4736368..4d6ab2e 100644 --- a/thyme.cabal +++ b/thyme.cabal @@ -81,6 +81,8 @@ library Data.Thyme.Calendar.Internal Data.Thyme.Clock.Internal Data.Thyme.Format.Internal + Data.Thyme.Format.DateFast + Data.Thyme.Format.DateEncode Data.Thyme.TrueName if !(flag(lens) || flag(docs)) other-modules: Control.Lens @@ -90,6 +92,7 @@ library aeson >= 0.6, base >= 4.5 && < 5, bytestring >= 0.9, + bytestring-builder, containers >= 0.5, deepseq >= 1.2, hashable >= 1.2, @@ -98,11 +101,12 @@ library random, text >= 0.11, template-haskell >= 2.7 && < 2.20, - time >= 1.4, + time >= 1.4 && < 1.10, vector >= 0.9, vector-th-unbox >= 0.2.1.0, - vector-space >= 0.8 - + vector-space >= 0.8, + scanner + build-tools: hsc2hs if os(windows) build-depends: Win32 if os(darwin) || os(freebsd) @@ -139,6 +143,7 @@ test-suite sanity text, thyme, time, + aeson, vector-space if flag(lens) build-depends: lens @@ -189,7 +194,9 @@ benchmark bench thyme, time, vector, - vector-space + vector-space, + aeson, + bytestring if flag(lens) build-depends: lens else @@ -197,4 +204,3 @@ benchmark bench ghc-options: -Wall -- vim: et sw=4 ts=4 sts=4: -