diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -7,81 +7,53 @@ module Main where -import qualified Data.Vector.Unboxed as UVector +import Control.Applicative import Criterion.Main import Data.Int -import Data.Maybe (fromMaybe) +import Data.Word + import Control.DeepSeq (($!!), NFData(..), deepseq) -import qualified Data.ByteString.Char8 as BS8 -import Test.QuickCheck (arbitrary, generate) +import Control.Monad (when) import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly, char) -import qualified Data.Attoparsec.Zepto as Z import Data.Foldable (traverse_) -import Data.Word -import Control.Monad (when) -import Control.Applicative +import Data.Maybe (fromMaybe) import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Short (ShortText) +import Test.QuickCheck (arbitrary, generate) -import qualified Data.Time as Time +import qualified Chronos +import qualified Data.Attoparsec.Zepto as Z +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Short as TS import qualified Data.Thyme as Thyme +import qualified Data.Time as Time +import qualified Data.Vector.Unboxed as UVector import qualified System.Locale as Thyme -import qualified Chronos main :: IO () main = do utcthyme <- generate arbitrary :: IO Thyme.UTCTime let - isoFormatString = "%Y-%m-%dT%H:%M:%S" renderIsoTime = Thyme.formatTime Thyme.defaultTimeLocale isoFormatString - timeParser :: String -> Time.UTCTime - timeParser = - fromMaybe (error "Failed to parse in timeParser") - . Time.parseTimeM True Time.defaultTimeLocale isoFormatString - thymeParser :: String -> Thyme.UTCTime - thymeParser = - fromMaybe (error "Failed to parse in thymeParser") - . Thyme.parseTime Thyme.defaultTimeLocale isoFormatString - thymeAttoparsec :: BS8.ByteString -> Thyme.UTCTime - thymeAttoparsec = - Thyme.buildTime @Thyme.UTCTime - . either error id - . parseOnly (Thyme.timeParser Thyme.defaultTimeLocale isoFormatString) -- With chronos, we explicitly convert the ymdhms time to the -- nanoseconds since the epoch. This is done to make the benchmark -- compare apples to apples. Both thyme and time are computing epoch -- times, so we want chronos to do the same. - chronosAttoparsec :: BS8.ByteString -> Chronos.Time - chronosAttoparsec = - either error Chronos.datetimeToTime - . parseOnly (Chronos.parserUtf8_YmdHMS Chronos.w3c) - chronosZepto :: BS8.ByteString -> Chronos.Time - chronosZepto = - either error Chronos.datetimeToTime - . Z.parse (Chronos.zeptoUtf8_YmdHMS Chronos.w3c) dmy = "%d:%m:%y." - hms = "%%H:%M:%S." + hms = "%H:%M:%S." dmyhms = isoFormatString timePretty = Time.formatTime Time.defaultTimeLocale thymePretty = Thyme.formatTime Thyme.defaultTimeLocale - chronosPrettyDmy = toLazyText - . Chronos.builder_Dmy (Just ':') - . Chronos.datetimeDate - . Chronos.timeToDatetime - chronosPrettyHMS = toLazyText - . Chronos.builder_HMS Chronos.SubsecondPrecisionAuto (Just ':') - . Chronos.datetimeTime - . Chronos.timeToDatetime - chronosPrettyYmdHMS = toLazyText - . Chronos.builder_YmdHMS Chronos.SubsecondPrecisionAuto Chronos.w3c - . Chronos.timeToDatetime timeTime <- Time.getCurrentTime thymeTime <- Thyme.getCurrentTime chronosTime <- Chronos.now string <- return $!! renderIsoTime utcthyme - bytestring <- return $!! BS8.pack (renderIsoTime utcthyme) + bytestring <- return $!! BS8.pack string + shortText <- return $!! TS.pack string defaultMain [ bgroup "parsing" @@ -90,6 +62,7 @@ , bench "Thyme.timeParser" $ nf thymeAttoparsec bytestring , bench "Chronos.parserUtf8_YmdHMS" $ nf chronosAttoparsec bytestring , bench "Chronos.zeptoUtf8_YmdHMS" $ nf chronosZepto bytestring + , bench "Chronos.decodeShortTextIso8601" $ nf chronosIso8601 shortText ] , bgroup "prettyPrint" @@ -108,5 +81,73 @@ , bench "Thyme.formatTime" $ nf (thymePretty dmyhms) thymeTime , bench "Chronos.builder_YmdHMS" $ nf chronosPrettyYmdHMS chronosTime ] + , bgroup "ISO-8601-Zulu" + [ bench "Chronos.encodeShortTextIso8601Zulu" $ nf encodeChronosIso8601Zulu chronosTime + ] ] ] + +encodeChronosIso8601Zulu :: Chronos.Time -> ShortText +encodeChronosIso8601Zulu !t = + Chronos.encodeShortTextIso8601Zulu (Chronos.timeToDatetime t) + +chronosIso8601 :: ShortText -> Chronos.Time +{-# noinline chronosIso8601 #-} +chronosIso8601 !t = case Chronos.decodeShortTextIso8601Zoneless t of + Just x -> Chronos.datetimeToTime x + Nothing -> errorWithoutStackTrace "chronosIso8601: decode failure" + +chronosZepto :: BS8.ByteString -> Chronos.Time +{-# noinline chronosZepto #-} +chronosZepto !bs = either error Chronos.datetimeToTime + (Z.parse (Chronos.zeptoUtf8_YmdHMS Chronos.w3c) bs) + + +chronosPrettyYmdHMS :: Chronos.Time -> LT.Text +{-# noinline chronosPrettyYmdHMS #-} +chronosPrettyYmdHMS = toLazyText + . Chronos.builder_YmdHMS Chronos.SubsecondPrecisionAuto Chronos.w3c + . Chronos.timeToDatetime + +chronosPrettyHMS :: Chronos.Time -> LT.Text +{-# noinline chronosPrettyHMS #-} +chronosPrettyHMS = toLazyText + . Chronos.builder_HMS Chronos.SubsecondPrecisionAuto (Just ':') + . Chronos.datetimeTime + . Chronos.timeToDatetime + +chronosPrettyDmy :: Chronos.Time -> LT.Text +{-# noinline chronosPrettyDmy #-} +chronosPrettyDmy = toLazyText + . Chronos.builder_Dmy (Just ':') + . Chronos.datetimeDate + . Chronos.timeToDatetime + +chronosAttoparsec :: BS8.ByteString -> Chronos.Time +{-# noinline chronosAttoparsec #-} +chronosAttoparsec = + either error Chronos.datetimeToTime + . parseOnly (Chronos.parserUtf8_YmdHMS Chronos.w3c) + +timeParser :: String -> Time.UTCTime +{-# noinline timeParser #-} +timeParser = + fromMaybe (error "Failed to parse in timeParser") + . Time.parseTimeM True Time.defaultTimeLocale isoFormatString + +thymeParser :: String -> Thyme.UTCTime +{-# noinline thymeParser #-} +thymeParser = + fromMaybe (error "Failed to parse in thymeParser") + . Thyme.parseTime Thyme.defaultTimeLocale isoFormatString + +thymeAttoparsec :: BS8.ByteString -> Thyme.UTCTime +{-# noinline thymeAttoparsec #-} +thymeAttoparsec = + Thyme.buildTime @Thyme.UTCTime + . either error id + . parseOnly (Thyme.timeParser Thyme.defaultTimeLocale isoFormatString) + +isoFormatString :: String +{-# noinline isoFormatString #-} +isoFormatString = "%Y-%m-%dT%H:%M:%S" diff --git a/chronos.cabal b/chronos.cabal --- a/chronos.cabal +++ b/chronos.cabal @@ -1,10 +1,7 @@ cabal-version: 3.0 -name: - chronos -version: - 1.1.2 -synopsis: - A high-performance time library +name: chronos +version: 1.1.3 +synopsis: A high-performance time library description: Chronos is a performance-oriented time library for Haskell, with a straightforward API. The main differences between this @@ -28,27 +25,19 @@ format strings. The approach taken by Chronos is faster and catches more mistakes at compile time, at the cost of being less expressive. -homepage: - https://github.com/andrewthad/chronos -license: - BSD-3-Clause -license-file: - LICENSE -author: - Andrew Martin +homepage: https://github.com/andrewthad/chronos +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin maintainer: Andrew Martin chessai -copyright: - 2016 Andrew Martin -category: - Data, Time, Parsing, Development -build-type: - Simple +copyright: 2016 Andrew Martin +category: Data, Time, Parsing, Development +build-type: Simple library - hs-source-dirs: - src + hs-source-dirs: src exposed-modules: Chronos Chronos.Types @@ -57,9 +46,9 @@ -- it is OPTIONS_HADDOCK-hidden Chronos.Internal.CTimespec build-depends: - , aeson >= 1.1 && < 1.5 - , attoparsec >= 0.13 && < 0.14 - , base >= 4.9 && < 5 + , aeson >= 1.1 && < 1.6 + , attoparsec >= 0.13 && < 0.15 + , base >= 4.12 && < 5 , bytestring >= 0.10 && < 0.11 , deepseq >= 1.4.4.0 , hashable >= 1.2 && < 1.4 @@ -68,29 +57,27 @@ , text >= 1.2 && < 1.3 , torsor >= 0.1 && < 0.2 , vector >= 0.11 && < 0.13 + , bytebuild >= 0.3.8 && < 0.4 + , bytesmith >= 0.3.7 && < 0.4 + , byteslice >= 0.2.5.2 && <0.3 + , text-short >= 0.1.3 && <0.2 + , natural-arithmetic >= 0.1.2 && <0.2 if os(windows) build-depends: Win32 >= 2.2 && < 2.9 - if impl(ghc < 8.4) - build-depends: clock >= 0.7 && < 0.9 - default-language: - Haskell2010 - c-sources: - src/cbits/hs-time.c + default-language: Haskell2010 + c-sources: src/cbits/hs-time.c ghc-options: -Wall -O2 test-suite chronos-test - type: - exitcode-stdio-1.0 - hs-source-dirs: - test - main-is: - Spec.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs build-depends: , HUnit , QuickCheck - , aeson >= 1.1 && < 1.5 + , aeson >= 1.1 && < 1.6 , attoparsec , base , bytestring @@ -104,16 +91,12 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: - Haskell2010 + default-language: Haskell2010 test-suite doctest - type: - exitcode-stdio-1.0 - hs-source-dirs: - test - main-is: - Doctests.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Doctests.hs build-depends: , QuickCheck , base @@ -121,16 +104,12 @@ , deepseq >= 1.4.4.0 , doctest >= 0.10 , torsor >= 0.1 && < 0.2 - default-language: - Haskell2010 + default-language: Haskell2010 benchmark bench - type: - exitcode-stdio-1.0 - hs-source-dirs: - bench - main-is: - Bench.hs + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs build-depends: , QuickCheck , attoparsec @@ -142,14 +121,12 @@ , deepseq >= 1.4.4.0 , old-locale , text + , text-short , thyme , time , vector - default-language: - Haskell2010 + default-language: Haskell2010 source-repository head - type: - git - location: - https://github.com/andrewthad/chronos + type: git + location: https://github.com/andrewthad/chronos diff --git a/src/Chronos.hs b/src/Chronos.hs --- a/src/Chronos.hs +++ b/src/Chronos.hs @@ -3,7 +3,9 @@ , CPP , DeriveGeneric , GeneralizedNewtypeDeriving + , LambdaCase , MultiParamTypeClasses + , NumericUnderscores , OverloadedStrings , RecordWildCards , ScopedTypeVariables @@ -52,10 +54,6 @@ -- ** Duration , stopwatch , stopwatch_ -#if !MIN_VERSION_base(4,11,0) - , stopwatchWith - , stopwatchWith_ -#endif -- ** Construction , datetimeFromYmdhms , timeFromYmdhms @@ -199,6 +197,13 @@ , parserUtf8_YmdHMS , parserUtf8_YmdHMS_opt_S , zeptoUtf8_YmdHMS + -- *** UTF-8 Bytes + , boundedBuilderUtf8BytesIso8601Zoneless + , decodeUtf8BytesIso8601Zoneless + -- *** Short Text + , decodeShortTextIso8601Zoneless + , encodeShortTextIso8601Zulu + , encodeShortTextIso8601Zoneless -- ** Offset Datetime -- *** Text , encode_YmdHMSz @@ -215,6 +220,13 @@ , parserUtf8_YmdHMSz , builderUtf8_YmdIMS_p_z , builderUtf8W3Cz + -- *** UTF-8 Bytes + , parserUtf8BytesIso8601 + , boundedBuilderUtf8BytesIso8601 + , decodeUtf8BytesIso8601 + -- *** ShortText + , decodeShortTextIso8601 + , encodeShortTextIso8601 -- ** Offset -- *** Text , encodeOffset @@ -277,6 +289,8 @@ import Control.Monad import Data.Aeson (FromJSON,ToJSON,FromJSONKey,ToJSONKey) import Data.Attoparsec.Text (Parser) +import Data.Bool (bool) +import Data.Bytes (Bytes) import Data.ByteString (ByteString) import Data.Char (isDigit) import Data.Foldable @@ -284,36 +298,42 @@ import Data.Int (Int64) import Data.Primitive import Data.Text (Text) +import Data.Text.Short (ShortText) import Data.Vector (Vector) import Data.Word (Word64, Word8) import Foreign.Storable +import GHC.Clock (getMonotonicTimeNSec) import GHC.Generics (Generic) import Torsor +import qualified Arithmetic.Lte as Lte +import qualified Arithmetic.Nat as Nat import qualified Data.Aeson as AE import qualified Data.Aeson.Encoding as AEE import qualified Data.Aeson.Types as AET import qualified Data.Attoparsec.ByteString.Char8 as AB import qualified Data.Attoparsec.Text as AT import qualified Data.Attoparsec.Zepto as Z +import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Builder.Bounded as Bounded +import qualified Data.Bytes.Parser as BVP +import qualified Data.Bytes.Parser.Latin as Latin import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Short.Internal as SBS import qualified Data.Semigroup as SG import qualified Data.Text as Text import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Builder.Int as TB import qualified Data.Text.Read as Text +import qualified Data.Text.Short as TS +import qualified Data.Text.Short.Unsafe as TS import qualified Data.Vector as Vector import qualified Data.Vector.Generic as GVector import qualified Data.Vector.Generic.Mutable as MGVector import qualified Data.Vector.Primitive as PVector import qualified Data.Vector.Unboxed as UVector -#if MIN_VERSION_base(4,11,0) -import GHC.Clock (getMonotonicTimeNSec) -#else -import qualified System.Clock as CLK -#endif #ifdef mingw32_HOST_OS import System.Win32.Time (SYSTEMTIME(..)) @@ -322,10 +342,6 @@ import Chronos.Internal.CTimespec (getPosixNanoseconds) #endif -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup (Semigroup, (<>)) -#endif - -- $setup -- >>> import Test.QuickCheck hiding (within) -- >>> import Test.QuickCheck.Gen @@ -552,7 +568,6 @@ epoch :: Time epoch = Time 0 -#if MIN_VERSION_base(4,11,0) -- | Measures the time it takes to run an action and evaluate -- its result to WHNF. This measurement uses a monotonic clock -- instead of the standard system clock. @@ -572,44 +587,7 @@ _ <- action end <- getMonotonicTimeNSec pure (Timespan (fromIntegral (end - start))) -#else --- | Measures the time it takes to run an action and evaluate --- its result to WHNF. This measurement uses a monotonic clock --- instead of the standard system clock. -stopwatch :: IO a -> IO (Timespan, a) -stopwatch = stopwatchWith CLK.Monotonic - --- | Measures the time it takes to run an action. The result --- is discarded. This measurement uses a monotonic clock --- instead of the standard system clock. -stopwatch_ :: IO a -> IO Timespan -stopwatch_ = stopwatchWith_ CLK.Monotonic - --- | Variant of 'stopwatch' that accepts a clock type. Users --- need to import @System.Clock@ from the @clock@ package --- in order to provide the clock type. -stopwatchWith :: CLK.Clock -> IO a -> IO (Timespan, a) -stopwatchWith c action = do - start <- CLK.getTime c - a <- action >>= evaluate - end <- CLK.getTime c - pure (timeSpecToTimespan (CLK.diffTimeSpec end start),a) -{-# DEPRECATED stopwatchWith "stopwatchWith will be removed in a future majour version" #-} - --- | Variant of 'stopwatch_' that accepts a clock type. -stopwatchWith_ :: CLK.Clock -> IO a -> IO Timespan -stopwatchWith_ c action = do - start <- CLK.getTime c - _ <- action - end <- CLK.getTime c - pure (timeSpecToTimespan (CLK.diffTimeSpec end start)) -{-# DEPRECATED stopwatchWith_ "stopwatchWith_ will be removed in a future majour version" #-} - -timeSpecToTimespan :: CLK.TimeSpec -> Timespan -timeSpecToTimespan (CLK.TimeSpec s ns) = Timespan (s * 1000000000 + ns) -#endif - -- UtcTime. Used internally only. data UtcTime = UtcTime {-# UNPACK #-} !Day -- day @@ -1238,14 +1216,17 @@ nanoseconds <- ( do _ <- AT.char '.' numberOfZeroes <- countZeroes - x <- AT.decimal - let totalDigits = countDigits x + numberOfZeroes - result = if totalDigits == 9 - then x - else if totalDigits < 9 - then x * raiseTenTo (9 - totalDigits) - else quot x (raiseTenTo (totalDigits - 9)) - pure (fromIntegral result) + AT.peekChar >>= \case + Just c | c >= '0' && c <= '9' -> do + x <- AT.decimal + let totalDigits = countDigits x + numberOfZeroes + result = if totalDigits == 9 + then x + else if totalDigits < 9 + then x * raiseTenTo (9 - totalDigits) + else quot x (raiseTenTo (totalDigits - 9)) + pure (fromIntegral result) + _ -> pure 0 ) <|> pure 0 pure (s * 1000000000 + nanoseconds) @@ -1844,18 +1825,22 @@ parseSecondsAndNanosecondsUtf8 = do s' <- parseFixedDigitsIntBS 2 let !s = fromIntegral s' :: Int64 + -- TODO: whoops, this should probably be gt 59, not 60 when (s > 60) (fail "seconds must be between 0 and 60") nanoseconds <- ( do _ <- AB.char '.' numberOfZeroes <- countZeroesUtf8 - x <- AB.decimal - let totalDigits = countDigits x + numberOfZeroes - result = if totalDigits == 9 - then x - else if totalDigits < 9 - then x * raiseTenTo (9 - totalDigits) - else quot x (raiseTenTo (totalDigits - 9)) - pure (fromIntegral result) + AB.peekChar >>= \case + Just c | c >= '0' && c <= '9' -> do + x <- AB.decimal + let totalDigits = countDigits x + numberOfZeroes + result = if totalDigits == 9 + then x + else if totalDigits < 9 + then x * raiseTenTo (9 - totalDigits) + else quot x (raiseTenTo (totalDigits - 9)) + pure (fromIntegral result) + _ -> pure 0 ) <|> pure 0 pure (s * 1000000000 + nanoseconds) @@ -3185,3 +3170,181 @@ , timePartsSubsecond = fromIntegral subsecond , timePartsOffset = getOffset o } + +-- | Decode an ISO-8601-encode datetime. The encoded time must not by suffixed +-- by an offset. Any offset (e.g. @-05:00@, @+00:00@, @Z@) will cause a decode +-- failure. +decodeShortTextIso8601Zoneless :: ShortText -> Maybe Chronos.Datetime +decodeShortTextIso8601Zoneless !t = decodeUtf8BytesIso8601Zoneless + (Bytes.fromShortByteString (TS.toShortByteString t)) + +-- | Decode an ISO-8601-encode datetime. The encoded time must include an offset +-- (e.g. @-05:00@, @+00:00@, @Z@). +decodeShortTextIso8601 :: ShortText -> Maybe Chronos.OffsetDatetime +decodeShortTextIso8601 !t = decodeUtf8BytesIso8601 + (Bytes.fromShortByteString (TS.toShortByteString t)) + +decodeUtf8BytesIso8601Zoneless :: Bytes -> Maybe Chronos.Datetime +decodeUtf8BytesIso8601Zoneless !b = + BVP.parseBytesMaybe (parserUtf8BytesIso8601Zoneless <* BVP.endOfInput ()) b + +decodeUtf8BytesIso8601 :: Bytes -> Maybe Chronos.OffsetDatetime +decodeUtf8BytesIso8601 !b = + BVP.parseBytesMaybe (parserUtf8BytesIso8601 <* BVP.endOfInput ()) b + +parserUtf8BytesIso8601Zoneless :: BVP.Parser () s Chronos.Datetime +{-# noinline parserUtf8BytesIso8601Zoneless #-} +parserUtf8BytesIso8601Zoneless = do + year <- Latin.decWord () + Latin.char () '-' + month' <- Latin.decWord () + let !month = month' - 1 + when (month >= 12) (BVP.fail ()) + Latin.char () '-' + dayWord <- Latin.decWord () + when (dayWord > 31) (BVP.fail ()) + let !date = Chronos.Date + (Chronos.Year (fromIntegral year)) + (Chronos.Month (fromIntegral month)) + (Chronos.DayOfMonth (fromIntegral dayWord)) + Latin.char () 'T' + hourWord <- Latin.decWord8 () + when (hourWord > 23) (BVP.fail ()) + Latin.char () ':' + minuteWord <- Latin.decWord8 () + when (minuteWord > 59) (BVP.fail ()) + Latin.char () ':' + sec <- Latin.decWord8 () + when (sec > 59) (BVP.fail ()) + !nanos <- Latin.trySatisfy (=='.') >>= \case + True -> do + (n,w) <- BVP.measure (Latin.decWord64 ()) + when (n > 9) (BVP.fail ()) + let go !acc !b = case b of + 0 -> acc + _ -> go (acc * 10) (b - 1) + !ns = go w (9 - n) + pure ns + False -> pure 0 + let !td = Chronos.TimeOfDay + (fromIntegral hourWord) + (fromIntegral minuteWord) + (fromIntegral @Word64 @Int64 (fromIntegral sec * 1000000000 + nanos)) + pure $! Chronos.Datetime date td + +-- | Consume an ISO-8601-encoded datetime with offset. This will consume any of +-- the following: +-- +-- > 2021-12-05T23:01:09Z +-- > 2021-12-05T23:01:09.000Z +-- > 2021-12-05T23:01:09.123456789Z +-- > 2021-12-05T23:01:09+05:00 +-- > 2021-12-05T23:01:09.357-11:00 +parserUtf8BytesIso8601 :: BVP.Parser () s Chronos.OffsetDatetime +{-# noinline parserUtf8BytesIso8601 #-} +parserUtf8BytesIso8601 = do + dt <- parserUtf8BytesIso8601Zoneless + off <- Latin.any () >>= \case + 'Z' -> pure 0 + '+' -> parserBytesOffset + '-' -> do + !off <- parserBytesOffset + pure (negate off) + _ -> BVP.fail () + pure $! Chronos.OffsetDatetime dt (Chronos.Offset off) + +-- Should consume exactly five characters: HH:MM. However, the implementation +-- is more generous. +parserBytesOffset :: BVP.Parser () s Int +parserBytesOffset = do + h <- Latin.decWord8 () + Latin.char () ':' + m <- Latin.decWord8 () + let !r = ((fromIntegral @Word8 @Int h) * 60) + fromIntegral @Word8 @Int m + pure r + +encodeShortTextIso8601Zulu :: Datetime -> ShortText +{-# noinline encodeShortTextIso8601Zulu #-} +encodeShortTextIso8601Zulu !dt = + let !(ByteArray x) = Bounded.run Nat.constant + ( boundedBuilderUtf8BytesIso8601Zoneless dt + `Bounded.append` + Bounded.ascii 'Z' + ) + in TS.fromShortByteStringUnsafe (SBS.SBS x) + +encodeShortTextIso8601Zoneless :: Datetime -> ShortText +{-# noinline encodeShortTextIso8601Zoneless #-} +encodeShortTextIso8601Zoneless !dt = + let !(ByteArray x) = Bounded.run Nat.constant + (boundedBuilderUtf8BytesIso8601Zoneless dt) + in TS.fromShortByteStringUnsafe (SBS.SBS x) + +encodeShortTextIso8601 :: OffsetDatetime -> ShortText +{-# noinline encodeShortTextIso8601 #-} +encodeShortTextIso8601 offdt = + let !(ByteArray x) = Bounded.run Nat.constant + (boundedBuilderUtf8BytesIso8601 offdt) + in TS.fromShortByteStringUnsafe (SBS.SBS x) + +boundedBuilderUtf8BytesIso8601 :: OffsetDatetime -> Bounded.Builder 50 +boundedBuilderUtf8BytesIso8601 (OffsetDatetime dt off) = + ( boundedBuilderUtf8BytesIso8601Zoneless dt + `Bounded.append` + boundedBuilderOffset off + ) + +-- | Encode a datetime with ISO-8601. The result does not include any +-- indication of a time zone. If the subsecond part is zero, it is suppressed. +-- Examples of output: +-- +-- > 2021-01-05T23:00:51 +-- > 2021-01-05T23:00:52.123000000 +-- > 2021-01-05T23:00:53.674094347 +boundedBuilderUtf8BytesIso8601Zoneless :: Datetime -> Bounded.Builder 44 +boundedBuilderUtf8BytesIso8601Zoneless (Datetime (Date (Year y) (Month mth) (DayOfMonth d)) (TimeOfDay h mt sns)) = + let (s,ns) = quotRem sns 1_000_000_000 in + Bounded.wordDec (fromIntegral y) + `Bounded.append` + Bounded.ascii '-' + `Bounded.append` + Bounded.wordPaddedDec2 (fromIntegral (mth + 1)) + `Bounded.append` + Bounded.ascii '-' + `Bounded.append` + Bounded.wordPaddedDec2 (fromIntegral d) + `Bounded.append` + Bounded.ascii 'T' + `Bounded.append` + Bounded.wordPaddedDec2 (fromIntegral h) + `Bounded.append` + Bounded.ascii ':' + `Bounded.append` + Bounded.wordPaddedDec2 (fromIntegral mt) + `Bounded.append` + Bounded.ascii ':' + `Bounded.append` + Bounded.wordPaddedDec2 (fromIntegral s) + `Bounded.append` + (case ns of + 0 -> Bounded.weaken @0 @10 Lte.constant Bounded.empty + _ -> + Bounded.ascii '.' + `Bounded.append` + Bounded.wordPaddedDec9 (fromIntegral ns) + ) + +boundedBuilderOffset :: Offset -> Bounded.Builder 6 +boundedBuilderOffset (Offset mins) = case mins of + 0 -> Bounded.weaken @1 @6 Lte.constant (Bounded.ascii 'Z') + _ -> + let !absMins = fromIntegral @Int @Word (abs mins) + !absHrs = quot absMins 60 + !absMinutes = rem absMins 60 + in Bounded.ascii (bool '-' '+' (mins > 0)) + `Bounded.append` + Bounded.wordPaddedDec2 absHrs + `Bounded.append` + Bounded.ascii ':' + `Bounded.append` + Bounded.wordPaddedDec2 absMinutes diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Main (main) where @@ -15,7 +17,8 @@ import Test.Framework (defaultMain,defaultMainWithOpts,testGroup,Test) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion,(@?=),assertBool) -import Test.QuickCheck (Gen, Arbitrary(..),discard,choose,arbitraryBoundedEnum,genericShrink,elements, suchThat) +import Test.QuickCheck (Gen,Arbitrary(..),discard,genericShrink,elements,suchThat) +import Test.QuickCheck (choose,chooseInt,arbitraryBoundedEnum) import Test.QuickCheck.Property (failed,succeeded,Result(..)) import qualified Chronos as C import qualified Data.Attoparsec.ByteString as AttoBS @@ -405,6 +408,12 @@ either (const Nothing) Just $ flip Atto.parseOnly input $ C.parser_YmdHMSz offsetFormat datetimeFormat ) + , testProperty "ISO-8601 Roundtrip" $ propEncodeDecodeIso + C.encodeShortTextIso8601Zulu + (\input -> case C.decodeShortTextIso8601 input of + Just (OffsetDatetime dt (Offset 0)) -> Just dt + _ -> Nothing + ) ] , testGroup "Posix Time" [ PH.testCase "Get now" $ do @@ -637,7 +646,21 @@ <$> choose (0,23) <*> choose (0,59) -- never use leap seconds for property-based tests - <*> choose (0,60000000000 - 1) + <*> ( do subsecPrecision <- chooseInt (0,9) + secs <- chooseInt (0,59) + case subsecPrecision of + 0 -> pure (fromIntegral @Int @Int64 secs * 1_000_000_000) + _ -> do + subsecs <- chooseInt (0,((10 :: Int) ^ subsecPrecision) - 1) + let subsecs' = subsecs * ((10 :: Int) ^ (9 - subsecPrecision)) + if subsecs' < 0 || subsecs' >= 1_000_000_000 + then error "Mistake in Arbitrary instance for TimeOfDay" + else pure + ( (fromIntegral @Int @Int64 secs * 1_000_000_000) + + + (fromIntegral @Int @Int64 subsecs) + ) + ) instance Arbitrary Date where arbitrary = Date @@ -660,9 +683,12 @@ instance Arbitrary DatetimeFormat where arbitrary = DatetimeFormat - <$> arbitrary - <*> elements [Nothing, Just '/', Just ':', Just '-'] - <*> arbitrary + <$> elements [Nothing, Just '/', Just ':', Just '-', Just '.'] + <*> elements [Nothing, Just '/', Just ':', Just '-', Just 'T'] + <*> elements [Nothing, Just ':', Just '-'] + shrink (DatetimeFormat a b c) + | a == Just '-', b == Just 'T', c == Just ':' = [] + | otherwise = [DatetimeFormat (Just '-') (Just 'T') (Just ':')] instance Arbitrary OffsetFormat where arbitrary = arbitraryBoundedEnum