diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,104 @@ +# Revision history for chronos + +## 1.1.7.0 -- 2025.07.15 + +* Add `decodeIso8601Zulu` for going straight from `Text` to a `Datetime`. +* Require a newer version of the `text` library so that UTF-8 encoding is used. + +## 1.1.6.2 -- 2024-12-11 + +* Support GHC 9.10 + +## 1.1.6.1 -- 2024-02-15 + +* Update package metadata. + +## 1.1.6.0 -- 2024-01-29 + +* Add `sinceEpoch` and `asSeconds` functions. +* Make `boundedBuilderUtf8BytesIso8601Zoneless` suppress trailing zeros + when a timestamp has no submillisecond part. For example, this function + prints 2021-01-05T23:00:52.123 where it previously + printed 2021-01-05T23:00:52.123000000. + +## 1.1.5.1 -- 2023-08-24 + +* Allow newer `natural-arithmetic`, `primitive`, and `vector`. +* Allow base 4.18. +* Add units to offset docs. + +## 1.1.5 -- 2022-11-03 + +* Add `decodeShortTextIso8601Zulu`. +* Add `decodeUtf8BytesIso8601ZonelessSpaced`. + +## 1.1.4 -- 2022-02-21 + +* Fix February length in `normalYearMonthLength`. Fixes GitHub issue #67. +* Support aeson-2.x, with backward compatibility for aeson-1.x. +* Add helper `dateToDayOfWeek` +* Add helpers `encode_Ymd` and `encode_Dmy` to more easily pretty-print dates +* Add various lenses for core data type fields and isos +* Drop support for GHC 8.8 and earlier. + +## 1.1.3 -- 2021-09-07 + +* Dropped support for GHC < 8.6. +* Integrated with `byteverse` libraries and `text-short`, adding efficient + builders and parsers targeting UT8-encoded unpinned byte arrays. The new + functions are: `boundedBuilderUtf8BytesIso8601Zoneless`, + `encodeShortTextIso8601Zulu`, `encodeShortTextIso8601Zoneless`, + `parserUtf8BytesIso8601`, `boundedBuilderUtf8BytesIso8601`, + `decodeUtf8BytesIso8601`, `decodeShortTextIso8601`, + `decodeShortTextIso8601Zoneless`, `decodeUtf8BytesIso8601Zoneless`, + `encodeShortTextIso8601`. +* Corrected an implementation mistake that had caused many parsers to + incorrectly identifier a subseconds part of 0 (i.e. `23:59:17.000`). +* Improved layout of cabal file. + +## 1.1.2 -- 2021-02-08 + +* Adds `NFData` typeclass instances for all data types. +* Add `encodeIso8601` and `builderIso8601`. +* Soft deprecate `builderW3C` in favor of `builderIso8601`. +* Fix formatting in cabal file. + +## 1.1.1 -- 2020-04-17 + +* Add `timeToDayOfWeek`, `datetimeToDayOfWeek`, `todayDayOfWeek`, + `yesterdayDayOfWeek`, and `tomorrowDayOfWeek`. +* Remove `stopwatchWith(_)` on GHC 8.6+. +* Fix build on 32-bit POSIX systems. + +## 1.1 -- 2019-11-28 + +* Drop dependency of `clock` on GHC 8.6+. +* Remove `stopwatchWith(_)` on GHC 8.6+. +* Deprecate `stopwatchWith(_)` on GHC <8.6. +* Fix build on Windows. Thanks @SpaceKitteh for reporting this. + +## 1.0.9 -- 2019-11-09 + +* Add `TimeParts` for custom formatting. + +## 1.0.8 -- 2019-11-07 + +* Allow newer semigroups. + +## 1.0.7 -- 2019-08-16 + +* Fix build on windows. Chronos now builds on windows, macos, and linux. Thanks + to @nprindle for the fix/testing and @ShrykerWindgrace for reporting it! + +## 1.0.6 -- 2019-07-19 + +* Add 'TimeInterval' type and related functions. + +## 1.0.5 -- 2019-05-01 + +* Allow newer version of `clock` (==0.7.* ===> >=0.7 && < 0.9) +* Build with -Wall +* Build with -O2 + +## 1.0.4 -- 2018-08-14 +* Initial version, w.r.t. CHANGELOG (i.e. there was no changelog before). diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,68 @@ +# Chronos + +Chronos is a performance-oriented time library for Haskell, with a +straightforward API. The main differences between this +and the [time](http://hackage.haskell.org/package/time) library +are: + * Chronos uses machine integers where possible. This means + that time-related arithmetic should be faster, with the + drawback that the types are incapable of representing times + that are very far in the future or the past (because Chronos + provides nanosecond, rather than picosecond, resolution). + For most users, this is not a hindrance and the tradeoff is + worthwhile. + * Chronos provides 'ToJSON'/'FromJSON' instances for serialisation. + * Chronos provides 'Unbox' instances for working with unboxed vectors. + * Chronos provides 'Prim' instances for working with byte arrays/primitive arrays. + * Chronos uses normal non-overloaded haskell functions for + encoding and decoding time. It provides [attoparsec](http://hackage.haskell.org/package/attoparsec) parsers for both 'Text' and + 'ByteString'. Additionally, Chronos provides functions for + encoding time to 'Text' or 'ByteString'. The [time](http://hackage.haskell.org/package/time) library accomplishes these with the + [Data.Time.Format](http://hackage.haskell.org/package/time-1.9.3/docs/Data-Time-Format.html) module, which uses UNIX-style datetime + format strings. The approach taken by Chronos is faster and + catches more mistakes at compile time, at the cost of being + less expressive. + +Jacob Stanley has written +[a blog post comparing the features and performance](https://jacobstanley.io/3-packages-you-need-to-know-about-before-processing-timestamps-in-haskell/) +of `time`, `thyme`, and `chronos`. It has a good bulleted breakdown of why +you may want to use each library along with some benchmarks. + +## Benchmarks + +Benchmarks of `chronos` against `time` and `thyme`. + +### Parsing + +| Benchmark name | Time | +|---------------------------|----------| +| Time.parseTimeM | 9.679 μs | +| Thyme.parseTime | 1.743 μs | +| Thyme.timeParser | 1.113 μs | +| Chronos.parserUtf8_YmdHMS | 301.4 ns | +| Chronos.zeptoUtf8_YmdHMS | 173.6 ns | + +### Pretty-printing + +| Benchmark name | Time | +|-------------------------|----------| +| dmy/Time.formatTime | 4.404 μs | +| dmy/Thyme.formatTime | 663.0 ns | +| dmy/Chronos.builder_Dmy | 340.9 ns | +| HMS/Time.formatTime | 1.987 μs | +| HMS/Thyme.formatTime | 879.1 ns | +| HMS/Chronos.builder_HMS | 481.3 ns | + +## Doctest + +Doctest used to be provided as a test suite, but `doctest-0.20` and higher +do not require this to be run. To run the doctests, make sure you have +`doctest` on your path (i.e. run `cabal install doctest`), and then run: + + cabal build + cabal repl --build-depends=QuickCheck --with-ghc=doctest --repl-options='-fno-warn-orphans' + +This runs incredibly slowly, but it works for now. Doctest is not run by CI, +so if you make a change that adds more doctests, it needs to be run by hand +by someone. (The maintainer is happy to do this if you're on a platform +where doctest is finicky.) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,113 +1,157 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE BangPatterns #-} module Main where -import qualified Data.Vector.Unboxed as UVector import Criterion.Main -import Data.Int + +import Control.DeepSeq (($!!)) +import Data.Attoparsec.ByteString.Char8 (parseOnly) import Data.Maybe (fromMaybe) -import Control.DeepSeq (($!!), NFData(..), deepseq) -import qualified Data.ByteString.Char8 as BS8 -import Test.QuickCheck (arbitrary, generate) -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.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 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) - chronosAttoparsec :: BS8.ByteString -> Chronos.Datetime - chronosAttoparsec = - either error id - . parseOnly (Chronos.parserUtf8_YmdHMS Chronos.w3c) - chronosZepto :: BS8.ByteString -> Chronos.Datetime - chronosZepto = - either error id - . Z.parse (Chronos.zeptoUtf8_YmdHMS Chronos.w3c) + -- 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. - dmy = "%d:%m:%y." - hms = "%%H:%M:%S." - 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 + dmy = "%d:%m:%y." + hms = "%H:%M:%S." + dmyhms = isoFormatString + timePretty = Time.formatTime Time.defaultTimeLocale + thymePretty = Thyme.formatTime Thyme.defaultTimeLocale - timeTime <- Time.getCurrentTime + 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" - [ bench "Time.parseTimeM" $ nf timeParser string - , bench "Thyme.parseTime" $ nf thymeParser string - , bench "Thyme.timeParser" $ nf thymeAttoparsec bytestring - , bench "Chronos.parserUtf8_YmdHMS" $ nf chronosAttoparsec bytestring - , bench "Chronos.zeptoUtf8_YmdHMS" $ nf chronosZepto bytestring - ] - - , bgroup "prettyPrint" - [ bgroup "dmy" - [ bench "Time.formatTime" $ nf (timePretty dmy) timeTime - , bench "Thyme.formatTime" $ nf (thymePretty dmy) thymeTime - , bench "Chronos.builder_Dmy" $ nf chronosPrettyDmy chronosTime + [ bgroup + "parsing" + [ bench "Time.parseTimeM" $ nf timeParser string + , bench "Thyme.parseTime" $ nf thymeParser string + , 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 "HMS" - [ bench "Time.formatTime" $ nf (timePretty hms) timeTime - , bench "Thyme.formatTime" $ nf (thymePretty hms) thymeTime - , bench "Chronos.builder_HMS" $ nf chronosPrettyHMS chronosTime + , bgroup + "prettyPrint" + [ bgroup + "dmy" + [ bench "Time.formatTime" $ nf (timePretty dmy) timeTime + , bench "Thyme.formatTime" $ nf (thymePretty dmy) thymeTime + , bench "Chronos.builder_Dmy" $ nf chronosPrettyDmy chronosTime + ] + , bgroup + "HMS" + [ bench "Time.formatTime" $ nf (timePretty hms) timeTime + , bench "Thyme.formatTime" $ nf (thymePretty hms) thymeTime + , bench "Chronos.builder_HMS" $ nf chronosPrettyHMS chronosTime + ] + , bgroup + "YmdHMS" + [ bench "Time.formatTime" $ nf (timePretty dmyhms) timeTime + , bench "Thyme.formatTime" $ nf (thymePretty dmyhms) thymeTime + , bench "Chronos.builder_YmdHMS" $ nf chronosPrettyYmdHMS chronosTime + ] + , bgroup + "ISO-8601-Zulu" + [ bench "Chronos.encodeShortTextIso8601Zulu" $ nf encodeChronosIso8601Zulu chronosTime + ] ] - ] ] -instance NFData Chronos.Datetime where - rnf (Chronos.Datetime a b) = a `deepseq` b `deepseq` () +encodeChronosIso8601Zulu :: Chronos.Time -> ShortText +encodeChronosIso8601Zulu !t = + Chronos.encodeShortTextIso8601Zulu (Chronos.timeToDatetime t) -instance NFData Chronos.Date where - rnf (Chronos.Date y m d) = y `deepseq` m `deepseq` d `deepseq` () +chronosIso8601 :: ShortText -> Chronos.Time +{-# NOINLINE chronosIso8601 #-} +chronosIso8601 !t = case Chronos.decodeShortTextIso8601Zoneless t of + Just x -> Chronos.datetimeToTime x + Nothing -> errorWithoutStackTrace "chronosIso8601: decode failure" -instance NFData Chronos.TimeOfDay where - rnf (Chronos.TimeOfDay h m s) = h `deepseq` m `deepseq` s `deepseq` () +chronosZepto :: BS8.ByteString -> Chronos.Time +{-# NOINLINE chronosZepto #-} +chronosZepto !bs = + either + error + Chronos.datetimeToTime + (Z.parse (Chronos.zeptoUtf8_YmdHMS Chronos.w3c) bs) -deriving instance NFData Chronos.DayOfMonth -deriving instance NFData Chronos.Month -deriving instance NFData Chronos.Year -deriving instance NFData Chronos.Day +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,91 +1,85 @@ -cabal-version: 2.2 -name: - chronos -version: - 1.0.9 -synopsis: - A performant time library +cabal-version: 3.0 +name: chronos +version: 1.1.7.0 +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 and the library are: + * Chronos uses machine integers where possible. This means + that time-related arithmetic should be faster, with the + drawback that the types are incapable of representing times + that are very far in the future or the past (because Chronos + provides nanosecond, rather than picosecond, resolution). + For most users, this is not a hindrance. + * Chronos provides 'ToJSON'/'FromJSON' instances for serialisation. + * Chronos provides 'Unbox' instances for working with unboxed vectors. + * Chronos provides 'Prim' instances for working with byte arrays/primitive arrays. + * Chronos uses normal non-overloaded haskell functions for + encoding and decoding time. It provides parsers for both 'Text' and + 'ByteString'. Additionally, Chronos provides functions for + encoding time to 'Text' or 'ByteString'. The http://hackage.haskell.org/package/time time> library accomplishes these with the + module, which uses UNIX-style datetime + 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/byteverse/chronos +bug-reports: https://github.com/byteverse/chronos/issues +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: amartin@layer3com.com, chessai1996@gmail.com +copyright: 2016 Andrew Martin +category: Data, Time, Parsing, Development +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md - * Chronos uses machine integers where possible. This means - that time-related arithmetic should be faster, with the - drawback that the types are incapable of representing times - that are very far in the future or the past (because Chronos - provides nanosecond, rather than picosecond, resolution). - For most users, this is not a hindrance. - * Chronos provides 'ToJSON'/'FromJSON' instances for serialisation. - * Chronos provides 'Unbox' instances for working with unboxed vectors. - * Chronos provides 'Prim' instances for working with byte arrays/primitive arrays. - * Chronos uses normal non-overloaded haskell functions for - encoding and decoding time. It provides parsers for both 'Text' and - 'ByteString'. Additionally, Chronos provides functions for - encoding time to 'Text' or 'ByteString'. The http://hackage.haskell.org/package/time time> library accomplishes these with the - module, which uses UNIX-style datetime - 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 -maintainer: - Andrew Martin - chessai -copyright: - 2016 Andrew Martin -category: - Data, Time, Parsing, Development -build-type: - Simple +tested-with: GHC ==9.6.3 || ==9.8.1 +common build-settings + default-language: Haskell2010 + ghc-options: -Wall -Wunused-packages + library - hs-source-dirs: - src + import: build-settings + hs-source-dirs: src exposed-modules: - Chronos - Chronos.Types - Chronos.Locale.English - -- only exposed for doctests - -- it is OPTIONS_HADDOCK-hidden - Chronos.Internal.CTimespec + Chronos + Chronos.Internal.CTimespec + Chronos.Locale.English + Chronos.Types build-depends: - , aeson >= 1.1 && < 1.5 - , attoparsec >= 0.13 && < 0.14 - , base >= 4.9 && < 5 - , bytestring >= 0.10 && < 0.11 - , clock >= 0.7 && < 0.9 - , hashable >= 1.2 && < 1.4 - , primitive >= 0.6.4 && < 0.8 - , semigroups >= 0.16 && < 0.20 - , text >= 1.2 && < 1.3 - , torsor >= 0.1 && < 0.2 - , vector >= 0.11 && < 0.13 + , aeson >=2.2 && <2.3 + , attoparsec >=0.13 && <0.15 + , base >=4.14 && <5 + , bytebuild >=0.3.14 && <0.4 + , byteslice >=0.2.5.2 && <0.3 + , bytesmith >=0.3.7 && <0.4 + , bytestring >=0.10 && <0.13 + , deepseq >=1.4.4.0 + , hashable >=1.2 && <1.5 + , natural-arithmetic >=0.1.2 && <0.3 + , primitive >=0.6.4 && <0.10 + , text >=2.1.2 && <2.2 + , text-short >=0.1.5 && <0.2 + , torsor >=0.1 && <0.2 + , vector >=0.11 && <0.14 if os(windows) - build-depends: Win32 >= 2.2 && < 2.9 - default-language: - Haskell2010 - c-sources: - src/cbits/hs-time.c - ghc-options: - -Wall - -O2 + build-depends: Win32 >=2.2 && <2.14 + c-sources: src/cbits/hs-time.c + ghc-options: -O2 + test-suite chronos-test - type: - exitcode-stdio-1.0 - hs-source-dirs: - test - main-is: - Spec.hs + import: build-settings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs build-depends: + , aeson >=1.1 && <2.3 , HUnit , QuickCheck , attoparsec @@ -97,52 +91,30 @@ , test-framework-quickcheck2 , text , torsor - ghc-options: - -threaded - -rtsopts -with-rtsopts=-N - default-language: - Haskell2010 -test-suite doctest - type: - exitcode-stdio-1.0 - hs-source-dirs: - test - main-is: - Doctests.hs - build-depends: - , QuickCheck - , base - , chronos - , doctest >= 0.10 - default-language: - Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N benchmark bench - type: - exitcode-stdio-1.0 - hs-source-dirs: - bench - main-is: - Bench.hs + import: build-settings + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Bench.hs build-depends: - , QuickCheck , attoparsec , base , bytestring , chronos , criterion - , deepseq + , deepseq >=1.4.4.0 , old-locale + , QuickCheck , text + , text-short , thyme , time - , vector - default-language: - Haskell2010 + ghc-options: -O2 + source-repository head - type: - git - location: - https://github.com/andrewthad/chronos + type: git + location: git://github.com/byteverse/chronos.git diff --git a/src/Chronos.hs b/src/Chronos.hs --- a/src/Chronos.hs +++ b/src/Chronos.hs @@ -1,2695 +1,4012 @@ -{-# language - BangPatterns - , CPP - , DeriveGeneric - , GeneralizedNewtypeDeriving - , MultiParamTypeClasses - , OverloadedStrings - , ScopedTypeVariables - , TypeFamilies - , TypeInType - , UnboxedTuples - #-} - -{-| Chronos is a performance-oriented time library for Haskell, with a - straightforward API. The main differences between this - and the library - are: - - * Chronos uses machine integers where possible. This means - that time-related arithmetic should be faster, with the - drawback that the types are incapable of representing times - that are very far in the future or the past (because Chronos - provides nanosecond, rather than picosecond, resolution). - For most users, this is not a hindrance. - * Chronos provides 'ToJSON'/'FromJSON' instances for serialisation. - * Chronos provides 'UVector.Unbox' instances for working with unboxed vectors. - * Chronos provides 'Prim' instances for working with byte arrays/primitive arrays. - * Chronos uses normal non-overloaded haskell functions for - encoding and decoding time. It provides parsers for both 'Text' and - 'ByteString'. Additionally, Chronos provides functions for - encoding time to 'Text' or 'ByteString'. The http://hackage.haskell.org/package/time time> library accomplishes these with the - module, which uses UNIX-style datetime - format strings. The approach taken by Chronos is faster and - catches more mistakes at compile time, at the cost of being - less expressive. - -} - -module Chronos - ( -- * Functions - -- ** Current - now - , today - , tomorrow - , yesterday - , epoch - -- ** Duration - , stopwatch - , stopwatch_ - , stopwatchWith - , stopwatchWith_ - -- ** Construction - , datetimeFromYmdhms - , timeFromYmdhms - -- ** Conversion - , timeToDatetime - , datetimeToTime - , timeToOffsetDatetime - , offsetDatetimeToTime - , timeToDayTruncate - , dayToTimeMidnight - , dayToDate - , dateToDay - , dayToOrdinalDate - , ordinalDateToDay - , monthDateToDayOfYear - , dayOfYearToMonthDay - -- ** Build Timespan - , second - , minute - , hour - , day - , week - -- ** Matching - , buildDayOfWeekMatch - , buildMonthMatch - , buildUnboxedMonthMatch - , caseDayOfWeek - , caseMonth - , caseUnboxedMonth - -- ** Format - -- $format - , w3c - , slash - , hyphen - , compact - , timeParts - -- ** Months - , january - , february - , march - , april - , may - , june - , july - , august - , september - , october - , november - , december - -- ** Days of Week - , sunday - , monday - , tuesday - , wednesday - , thursday - , friday - , saturday - -- ** Utility - , daysInMonth - , isLeapYear - , observedOffsets - -- * Textual Conversion - -- ** Date - -- *** Text - , builder_Ymd - , builder_Dmy - , builder_HMS - , parser_Ymd - , parser_Mdy - , parser_Dmy - -- *** UTF-8 ByteString - , builderUtf8_Ymd - , parserUtf8_Ymd - -- ** Time of Day - -- *** Text - , builder_IMS_p - , builder_IMSp - , parser_HMS - , parser_HMS_opt_S - -- *** UTF-8 ByteString - , builderUtf8_HMS - , builderUtf8_IMS_p - , builderUtf8_IMSp - , parserUtf8_HMS - , parserUtf8_HMS_opt_S - , zeptoUtf8_HMS - -- ** Datetime - -- *** Text - , builder_DmyHMS - , builder_DmyIMSp - , builder_DmyIMS_p - , builder_YmdHMS - , builder_YmdIMSp - , builder_YmdIMS_p - , builderW3C - , encode_DmyHMS - , encode_DmyIMS_p - , encode_YmdHMS - , encode_YmdIMS_p - , parser_DmyHMS - , parser_YmdHMS - , parser_YmdHMS_opt_S - , parser_DmyHMS_opt_S - , decode_DmyHMS - , decode_YmdHMS - , decode_YmdHMS_opt_S - , decode_DmyHMS_opt_S - -- *** UTF-8 ByteString - , encodeUtf8_YmdHMS - , encodeUtf8_YmdIMS_p - , builderUtf8_YmdHMS - , builderUtf8_YmdIMSp - , builderUtf8_YmdIMS_p - , builderUtf8W3C - , decodeUtf8_YmdHMS - , decodeUtf8_YmdHMS_opt_S - , parserUtf8_YmdHMS - , parserUtf8_YmdHMS_opt_S - , zeptoUtf8_YmdHMS - -- ** Offset Datetime - -- *** Text - , encode_YmdHMSz - , encode_DmyHMSz - , builder_YmdHMSz - , builder_DmyHMSz - , parser_YmdHMSz - , parser_DmyHMSz - , builder_YmdIMS_p_z - , builder_DmyIMS_p_z - , builderW3Cz - -- *** UTF-8 ByteString - , builderUtf8_YmdHMSz - , parserUtf8_YmdHMSz - , builderUtf8_YmdIMS_p_z - , builderUtf8W3Cz - -- ** Offset - -- *** Text - , encodeOffset - , builderOffset - , decodeOffset - , parserOffset - -- *** UTF-8 ByteString - , encodeOffsetUtf8 - , builderOffsetUtf8 - , decodeOffsetUtf8 - , parserOffsetUtf8 - -- ** Timespan - -- *** Text - , encodeTimespan - , builderTimespan - -- *** UTF-8 ByteString - , encodeTimespanUtf8 - , builderTimespanUtf8 - -- ** TimeInterval - , within - , timeIntervalToTimespan - , whole - , singleton - , lowerBound - , upperBound - , width - , timeIntervalBuilder - , (...) - -- * Types - , Day(..) - , DayOfWeek(..) - , DayOfMonth(..) - , DayOfYear(..) - , Month(..) - , Year(..) - , Offset(..) - , Time(..) - , DayOfWeekMatch(..) - , MonthMatch(..) - , UnboxedMonthMatch(..) - , Timespan(..) - , SubsecondPrecision(..) - , Date(..) - , OrdinalDate(..) - , MonthDate(..) - , Datetime(..) - , OffsetDatetime(..) - , TimeOfDay(..) - , DatetimeFormat(..) - , OffsetFormat(..) - , DatetimeLocale(..) - , MeridiemLocale(..) - , TimeInterval(..) - , TimeParts(..) - ) where - -import Control.Applicative -import Control.Exception (evaluate) -import Control.Monad -import Data.Aeson (FromJSON,ToJSON,FromJSONKey,ToJSONKey) -import Data.Attoparsec.Text (Parser) -import Data.ByteString (ByteString) -import Data.Char (isDigit) -import Data.Foldable -import Data.Hashable (Hashable) -import Data.Int (Int64) -import Data.Primitive -import Data.Text (Text) -import Data.Vector (Vector) -import Data.Word (Word64, Word8) -import Foreign.Storable -import GHC.Generics (Generic) -import Torsor -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.ByteString.Builder as BB -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as LB -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.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 -import qualified System.Clock as CLK - -#ifdef mingw32_HOST_OS -import System.Win32.Time (SYSTEMTIME(..)) -import qualified System.Win32.Time as W32 -#else -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 --- >>> import Data.Maybe (isJust) --- >>> :set -XStandaloneDeriving --- >>> :set -XGeneralizedNewtypeDeriving --- >>> :set -XScopedTypeVariables --- --- >>> deriving instance Arbitrary Time --- >>> :{ --- instance Arbitrary TimeInterval where --- arbitrary = do --- t0 <- arbitrary --- t1 <- suchThat arbitrary (>= t0) --- pure (TimeInterval t0 t1) --- instance Arbitrary TimeOfDay where --- arbitrary = TimeOfDay --- <$> choose (0,23) --- <*> choose (0,59) --- <*> choose (0, 60000000000 - 1) --- instance Arbitrary Date where --- arbitrary = Date --- <$> fmap Year (choose (1800,2100)) --- <*> fmap Month (choose (0,11)) --- <*> fmap DayOfMonth (choose (1,28)) --- instance Arbitrary Datetime where --- arbitrary = Datetime <$> arbitrary <*> arbitrary --- instance Arbitrary OffsetDatetime where --- arbitrary = OffsetDatetime <$> arbitrary <*> arbitrary --- instance Arbitrary DatetimeFormat where --- arbitrary = DatetimeFormat --- <$> arbitrary --- <*> elements [ Nothing, Just '/', Just ':', Just '-'] --- <*> arbitrary --- instance Arbitrary OffsetFormat where --- arbitrary = arbitraryBoundedEnum --- shrink = genericShrink --- instance Arbitrary Offset where --- arbitrary = fmap Offset (choose ((-24) * 60, 24 * 60)) --- instance Arbitrary SubsecondPrecision where --- arbitrary = frequency --- [ (1, pure SubsecondPrecisionAuto) --- , (1, SubsecondPrecisionFixed <$> choose (0,9)) --- ] --- instance Arbitrary Day where --- arbitrary = fmap Day (choose (0,50000)) --- :} --- - --- | A 'Timespan' representing a single second. -second :: Timespan -second = Timespan 1000000000 - --- | A 'Timespan' representing a single minute. -minute :: Timespan -minute = Timespan 60000000000 - --- | A 'Timespan' representing a single hour. -hour :: Timespan -hour = Timespan 3600000000000 - --- | A 'Timespan' representing a single day. -day :: Timespan -day = Timespan 86400000000000 - --- | A 'Timespan' representing a single week. -week :: Timespan -week = Timespan 604800000000000 - --- | Convert 'Time' to 'Datetime'. --- --- prop> \(t :: Time) -> (datetimeToTime (timeToDatetime t)) == t -timeToDatetime :: Time -> Datetime -timeToDatetime = utcTimeToDatetime . toUtc - --- | Convert 'Datetime' to 'Time'. --- --- prop> \(d :: Datetime) -> timeToDatetime (datetimeToTime d) == d -datetimeToTime :: Datetime -> Time -datetimeToTime = fromUtc . datetimeToUtcTime - --- | Convert 'Time' to 'OffsetDatetime' by providing an 'Offset'. -timeToOffsetDatetime :: Offset -> Time -> OffsetDatetime -timeToOffsetDatetime offset = utcTimeToOffsetDatetime offset . toUtc - --- | Convert 'OffsetDatetime' to 'Time'. -offsetDatetimeToTime :: OffsetDatetime -> Time -offsetDatetimeToTime = fromUtc . offsetDatetimeToUtcTime - --- | Convert 'Time' to 'Day'. This function is lossy; consequently, it --- does not roundtrip with 'dayToTimeMidnight'. -timeToDayTruncate :: Time -> Day -timeToDayTruncate (Time i) = Day (fromIntegral (div i 86400000000000) + 40587) - --- | Convert midnight of the given 'Day' to 'Time'. -dayToTimeMidnight :: Day -> Time -dayToTimeMidnight (Day d) = Time (fromIntegral (d - 40587) * 86400000000000) - --- | Convert 'Day' to a 'Date'. --- --- prop> \(d :: Day) -> dateToDay (dayToDate d) == d -dayToDate :: Day -> Date -dayToDate theDay = Date year month dayOfMonth - where - OrdinalDate year yd = dayToOrdinalDate theDay - MonthDate month dayOfMonth = dayOfYearToMonthDay (isLeapYear year) yd - --- | Convert a 'Date' to a 'Day'. --- --- prop> \(d :: Date) -> dayToDate (dateToDay d) == d -dateToDay :: Date -> Day -dateToDay (Date y m d) = ordinalDateToDay $ OrdinalDate y - (monthDateToDayOfYear (isLeapYear y) (MonthDate m d)) - --- | Construct a 'Datetime' from year, month, day, hour, minute, second: --- --- >>> datetimeFromYmdhms 2014 2 26 17 58 52 --- Datetime {datetimeDate = Date {dateYear = Year {getYear = 2014}, dateMonth = Month {getMonth = 1}, dateDay = DayOfMonth {getDayOfMonth = 26}}, datetimeTime = TimeOfDay {timeOfDayHour = 17, timeOfDayMinute = 58, timeOfDayNanoseconds = 52000000000}} -datetimeFromYmdhms :: - Int -- ^ Year - -> Int -- ^ Month - -> Int -- ^ Day - -> Int -- ^ Hour - -> Int -- ^ Minute - -> Int -- ^ Second - -> Datetime -datetimeFromYmdhms y m d h m' s = Datetime - (Date - (Year $ fromIntegral y) - (Month mx) - (DayOfMonth $ fromIntegral d) - ) - (TimeOfDay - (fromIntegral h) - (fromIntegral m') - (fromIntegral s * 1000000000) - ) - where - mx = if m >= 1 && m <= 12 - then fromIntegral (m - 1) - else 1 - --- | Construct a 'Time' from year, month, day, hour, minute, second: --- --- >>> timeFromYmdhms 2014 2 26 17 58 52 --- Time {getTime = 1393437532000000000} -timeFromYmdhms :: - Int -- ^ Year - -> Int -- ^ Month - -> Int -- ^ Day - -> Int -- ^ Hour - -> Int -- ^ Minute - -> Int -- ^ Second - -> Time -timeFromYmdhms y m d h m' s = datetimeToTime (datetimeFromYmdhms y m d h m' s) - --- | Gets the current 'Day'. This does not take the user\'s --- time zone into account. -today :: IO Day -today = fmap timeToDayTruncate now - --- | Gets the 'Day' of tomorrow. -tomorrow :: IO Day -tomorrow = fmap (add 1 . timeToDayTruncate) now - --- | Gets the 'Day' of yesterday. -yesterday :: IO Day -yesterday = fmap (add (-1) . timeToDayTruncate) now - --- | Get the current time from the system clock. -now :: IO Time -#ifdef mingw32_HOST_OS -now = do - SYSTEMTIME{..} <- W32.getSystemTime - let date = Date - { dateYear = Year (fromIntegral wYear) - , dateMonth = Month (fromIntegral wMonth) - , dateDay = DayOfMonth (fromIntegral wDay) - } - let secNano = (fromIntegral wSecond :: Int64) * 1000000000 - msNano = (fromIntegral wMilliseconds :: Int64) * 1000000 - nano = secNano + msNano - let time = TimeOfDay - { timeOfDayHour = fromIntegral wHour - , timeOfDayMinute = fromIntegral wMinute - , timeOfDayNanoseconds = fromIntegral nano - } - let dt = Datetime date time - pure $ datetimeToTime dt -#else -now = fmap Time getPosixNanoseconds -#endif - --- | The Unix epoch, that is 1970-01-01 00:00:00. -epoch :: Time -epoch = Time 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. -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) - --- | 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)) - -timeSpecToTimespan :: CLK.TimeSpec -> Timespan -timeSpecToTimespan (CLK.TimeSpec s ns) = Timespan (s * 1000000000 + ns) - --- UtcTime. Used internally only. -data UtcTime = UtcTime - {-# UNPACK #-} !Day -- day - {-# UNPACK #-} !Int64 -- nanoseconds - -toUtc :: Time -> UtcTime -toUtc (Time i) = let (d,t) = divMod i (getTimespan day) - in UtcTime (add (fromIntegral d) epochDay) (fromIntegral t) - -fromUtc :: UtcTime -> Time -fromUtc (UtcTime d ns') = Time $ getTimespan $ plus - (scale (intToInt64 (difference d epochDay)) day) - (if ns > day then day else ns) - where ns = Timespan ns' - -intToInt64 :: Int -> Int64 -intToInt64 = fromIntegral - -epochDay :: Day -epochDay = Day 40587 - -dayLengthInt64 :: Int64 -dayLengthInt64 = getTimespan day - -nanosecondsInMinute :: Int64 -nanosecondsInMinute = 60000000000 - --- | All UTC time offsets. See . -observedOffsets :: Vector Offset -observedOffsets = Vector.fromList $ map Offset - [ -1200 - , -1100 - , -1000 - , -930 - , -900 - , -800 - , -700 - , -600 - , -500 - , -400 - , -330 - , -300 - , -230 - , -200 - , -100 - , 0 - , 100 - , 200 - , 300 - , 330 - , 400 - , 430 - , 500 - , 530 - , 545 - , 600 - , 630 - , 700 - , 800 - , 845 - , 900 - , 930 - , 1000 - , 1030 - , 1100 - , 1200 - , 1245 - , 1300 - , 1345 - , 1400 - ] - --- | The first argument in the resulting tuple in a day --- adjustment. It should be either -1, 0, or 1, as no --- offset should ever exceed 24 hours. -offsetTimeOfDay :: Offset -> TimeOfDay -> (Int, TimeOfDay) -offsetTimeOfDay (Offset offset) (TimeOfDay h m s) = - (dayAdjustment,TimeOfDay h'' m'' s) - where - (!dayAdjustment, !h'') = divMod h' 24 - (!hourAdjustment, !m'') = divMod m' 60 - m' = m + offset - h' = h + hourAdjustment - -nanosecondsSinceMidnightToTimeOfDay :: Int64 -> TimeOfDay -nanosecondsSinceMidnightToTimeOfDay ns = - if ns >= dayLengthInt64 - then TimeOfDay 23 59 (nanosecondsInMinute + (ns - dayLengthInt64)) - else TimeOfDay h' m' ns' - where - (!mInt64,!ns') = quotRem ns nanosecondsInMinute - !m = fromIntegral mInt64 - (!h',!m') = quotRem m 60 - -timeOfDayToNanosecondsSinceMidnight :: TimeOfDay -> Int64 -timeOfDayToNanosecondsSinceMidnight (TimeOfDay h m ns) = - fromIntegral h * 3600000000000 + fromIntegral m * 60000000000 + ns - --- datetimeToOffsetDatetime :: Offset -> Datetime -> OffsetDatetime --- datetimeToOffsetDatetime offset - -utcTimeToOffsetDatetime :: Offset -> UtcTime -> OffsetDatetime -utcTimeToOffsetDatetime offset (UtcTime (Day d) nanoseconds) = - let (!dayAdjustment,!tod) = offsetTimeOfDay offset (nanosecondsSinceMidnightToTimeOfDay nanoseconds) - !date = dayToDate (Day (d + dayAdjustment)) - in OffsetDatetime (Datetime date tod) offset - -utcTimeToDatetime :: UtcTime -> Datetime -utcTimeToDatetime (UtcTime d nanoseconds) = - let !tod = nanosecondsSinceMidnightToTimeOfDay nanoseconds - !date = dayToDate d - in Datetime date tod - -datetimeToUtcTime :: Datetime -> UtcTime -datetimeToUtcTime (Datetime date timeOfDay) = - UtcTime (dateToDay date) (timeOfDayToNanosecondsSinceMidnight timeOfDay) - -offsetDatetimeToUtcTime :: OffsetDatetime -> UtcTime -offsetDatetimeToUtcTime (OffsetDatetime (Datetime date timeOfDay) (Offset off)) = - let (!dayAdjustment,!tod) = offsetTimeOfDay (Offset $ negate off) timeOfDay - !(Day !theDay) = dateToDay date - in UtcTime - (Day (theDay + dayAdjustment)) - (timeOfDayToNanosecondsSinceMidnight tod) - --- | Convert a 'MonthDate' to a 'DayOfYear'. -monthDateToDayOfYear :: - Bool -- ^ Is it a leap year? - -> MonthDate - -> DayOfYear -monthDateToDayOfYear isLeap (MonthDate month@(Month m) (DayOfMonth dayOfMonth)) = - DayOfYear ((div (367 * (fromIntegral m + 1) - 362) 12) + k + day') - where - day' = fromIntegral $ clip 1 (daysInMonth isLeap month) dayOfMonth - k = if month < Month 2 then 0 else if isLeap then -1 else -2 - --- | Convert an 'OrdinalDate' to a 'Day'. -ordinalDateToDay :: OrdinalDate -> Day -ordinalDateToDay (OrdinalDate year@(Year y') theDay) = Day mjd where - y = y' - 1 - mjd = (fromIntegral . getDayOfYear $ - (clip (DayOfYear 1) (if isLeapYear year then DayOfYear 366 else DayOfYear 365) theDay) - ) - + (365 * y) - + (div y 4) - (div y 100) - + (div y 400) - 678576 - --- | Is the 'Year' a leap year? --- --- >>> isLeapYear (Year 1996) --- True --- --- >>> isLeapYear (Year 2019) --- False -isLeapYear :: Year -> Bool -isLeapYear (Year year) = (mod year 4 == 0) && ((mod year 400 == 0) || not (mod year 100 == 0)) - --- | Convert a 'DayOfYear' to a 'MonthDate'. -dayOfYearToMonthDay :: - Bool -- ^ Is it a leap year? - -> DayOfYear - -> MonthDate -dayOfYearToMonthDay isLeap dayOfYear = - let (!doyUpperBound,!monthTable,!dayTable) = - if isLeap - then (DayOfYear 366, leapYearDayOfYearMonthTable, leapYearDayOfYearDayOfMonthTable) - else (DayOfYear 365, normalYearDayOfYearMonthTable, normalYearDayOfYearDayOfMonthTable) - DayOfYear clippedDay = clip (DayOfYear 1) doyUpperBound dayOfYear - clippedDayInt = fromIntegral clippedDay :: Int - month = UVector.unsafeIndex monthTable clippedDayInt - theDay = UVector.unsafeIndex dayTable clippedDayInt - in MonthDate month theDay - --- | Convert a 'Day' to an 'OrdinalDate'. -dayToOrdinalDate :: Day -> OrdinalDate -dayToOrdinalDate (Day mjd) = OrdinalDate (Year $ fromIntegral year) (DayOfYear $ fromIntegral yd) where - a = (fromIntegral mjd :: Int64) + 678575 - quadcent = div a 146097 - b = mod a 146097 - cent = min (div b 36524) 3 - c = b - (cent * 36524) - quad = div c 1461 - d = mod c 1461 - y = min (div d 365) 3 - yd = (d - (y * 365) + 1) - year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 - -{- $format - -The formats provided is this module are language-agnostic. -To find meridiem formats and month formats, look in a -language-specific module. - --} - --- | The W3C 'DatetimeFormat'. --- --- >>> encode_YmdHMS SubsecondPrecisionAuto w3c (timeToDatetime (timeFromYmdhms 2014 2 26 17 58 52)) --- "2014-02-26T17:58:52" --- --- prop> \(s :: SubsecondPrecision) (dt :: Datetime) -> isJust (decode_YmdHMS w3c (encode_YmdHMS s w3c dt)) -w3c :: DatetimeFormat -w3c = DatetimeFormat (Just '-') (Just 'T') (Just ':') - --- | A 'DatetimeFormat' that separates the members of --- the 'Date' by slashes. --- --- >>> encode_YmdHMS SubsecondPrecisionAuto slash (timeToDatetime (timeFromYmdhms 2014 2 26 17 58 52)) --- "2014/02/26 17:58:52" --- --- prop> \(s :: SubsecondPrecision) (dt :: Datetime) -> isJust (decode_YmdHMS slash (encode_YmdHMS s slash dt)) -slash :: DatetimeFormat -slash = DatetimeFormat (Just '/') (Just ' ') (Just ':') - --- | A 'DatetimeFormat' that separates the members of --- the 'Date' by hyphens. --- --- >>> encode_YmdHMS SubsecondPrecisionAuto hyphen (timeToDatetime (timeFromYmdhms 2014 2 26 17 58 52)) --- "2014-02-26 17:58:52" --- --- prop> \(s :: SubsecondPrecision) (dt :: Datetime) -> isJust (decode_YmdHMS hyphen (encode_YmdHMS s hyphen dt)) -hyphen :: DatetimeFormat -hyphen = DatetimeFormat (Just '-') (Just ' ') (Just ':') - --- | A 'DatetimeFormat' with no separators, except for a --- `T` between the 'Date' and 'Time'. --- --- >>> encode_YmdHMS SubsecondPrecisionAuto compact (timeToDatetime (timeFromYmdhms 2014 2 26 17 58 52)) --- "20140226T175852" --- --- prop> \(s :: SubsecondPrecision) (dt :: Datetime) -> isJust (decode_YmdHMS compact (encode_YmdHMS s compact dt)) -compact :: DatetimeFormat -compact = DatetimeFormat Nothing (Just 'T') Nothing - --- | Return the number of days in a given month. -daysInMonth :: - Bool -- ^ Is this a leap year? - -> Month -- ^ Month of year - -> Int -daysInMonth isLeap m = if isLeap - then caseMonth leapYearMonthLength m - else caseMonth normalYearMonthLength m - -leapYearMonthLength :: MonthMatch Int -leapYearMonthLength = buildMonthMatch 31 29 31 30 31 30 31 31 30 31 30 31 - -normalYearMonthLength :: MonthMatch Int -normalYearMonthLength = buildMonthMatch 31 30 31 30 31 30 31 31 30 31 30 31 - -leapYearDayOfYearDayOfMonthTable :: UVector.Vector DayOfMonth -leapYearDayOfYearDayOfMonthTable = UVector.fromList $ (DayOfMonth 1:) $ concat - [ enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 29) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 30) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 30) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 30) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 30) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - ] -{-# NOINLINE leapYearDayOfYearDayOfMonthTable #-} - -normalYearDayOfYearDayOfMonthTable :: UVector.Vector DayOfMonth -normalYearDayOfYearDayOfMonthTable = UVector.fromList $ (DayOfMonth 1:) $concat - [ enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 28) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 30) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 30) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 30) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - , enumFromTo (DayOfMonth 1) (DayOfMonth 30) - , enumFromTo (DayOfMonth 1) (DayOfMonth 31) - ] -{-# NOINLINE normalYearDayOfYearDayOfMonthTable #-} - -leapYearDayOfYearMonthTable :: UVector.Vector Month -leapYearDayOfYearMonthTable = UVector.fromList $ (Month 0:) $ concat - [ replicate 31 (Month 0) - , replicate 29 (Month 1) - , replicate 31 (Month 2) - , replicate 30 (Month 3) - , replicate 31 (Month 4) - , replicate 30 (Month 5) - , replicate 31 (Month 6) - , replicate 31 (Month 7) - , replicate 30 (Month 8) - , replicate 31 (Month 9) - , replicate 30 (Month 10) - , replicate 31 (Month 11) - ] -{-# NOINLINE leapYearDayOfYearMonthTable #-} - -normalYearDayOfYearMonthTable :: UVector.Vector Month -normalYearDayOfYearMonthTable = UVector.fromList $ (Month 0:) $ concat - [ replicate 31 (Month 0) - , replicate 28 (Month 1) - , replicate 31 (Month 2) - , replicate 30 (Month 3) - , replicate 31 (Month 4) - , replicate 30 (Month 5) - , replicate 31 (Month 6) - , replicate 31 (Month 7) - , replicate 30 (Month 8) - , replicate 31 (Month 9) - , replicate 30 (Month 10) - , replicate 31 (Month 11) - ] -{-# NOINLINE normalYearDayOfYearMonthTable #-} - --- | Build a 'MonthMatch' from twelve (12) values. -buildMonthMatch :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> MonthMatch a -buildMonthMatch a b c d e f g h i j k l = - MonthMatch (Vector.fromListN 12 [a,b,c,d,e,f,g,h,i,j,k,l]) - --- | Match a 'Month' against a 'MonthMatch'. -caseMonth :: MonthMatch a -> Month -> a -caseMonth (MonthMatch v) (Month ix) = Vector.unsafeIndex v ix - --- | Build an 'UnboxedMonthMatch' from twelve (12) values. -buildUnboxedMonthMatch :: UVector.Unbox a => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> UnboxedMonthMatch a -buildUnboxedMonthMatch a b c d e f g h i j k l = - UnboxedMonthMatch (UVector.fromListN 12 [a,b,c,d,e,f,g,h,i,j,k,l]) - --- | Match a 'Month' against an 'UnboxedMonthMatch'. -caseUnboxedMonth :: UVector.Unbox a => UnboxedMonthMatch a -> Month -> a -caseUnboxedMonth (UnboxedMonthMatch v) (Month ix) = UVector.unsafeIndex v ix - --- | Build a 'DayOfWeekMatch' from seven (7) values. -buildDayOfWeekMatch :: a -> a -> a -> a -> a -> a -> a -> DayOfWeekMatch a -buildDayOfWeekMatch a b c d e f g = - DayOfWeekMatch (Vector.fromListN 7 [a,b,c,d,e,f,g]) - --- | Match a 'DayOfWeek' against a 'DayOfWeekMatch'. -caseDayOfWeek :: DayOfWeekMatch a -> DayOfWeek -> a -caseDayOfWeek (DayOfWeekMatch v) (DayOfWeek ix) = Vector.unsafeIndex v ix --- | Given a 'Date' and a separator, construct a 'Text' 'TB.Builder' --- corresponding to Year\/Month\/Day encoding. -builder_Ymd :: Maybe Char -> Date -> TB.Builder -builder_Ymd msep (Date (Year y) m d) = case msep of - Nothing -> - TB.decimal y - <> monthToZeroPaddedDigit m - <> zeroPadDayOfMonth d - Just sep -> let sepBuilder = TB.singleton sep in - TB.decimal y - <> sepBuilder - <> monthToZeroPaddedDigit m - <> sepBuilder - <> zeroPadDayOfMonth d - --- | Given a 'Date' and a separator, construct a 'Text' 'TB.Builder' --- corresponding to a Day\/Month\/Year encoding. -builder_Dmy :: Maybe Char -> Date -> TB.Builder -builder_Dmy msep (Date (Year y) m d) = case msep of - Nothing -> - zeroPadDayOfMonth d - <> monthToZeroPaddedDigit m - <> TB.decimal y - Just sep -> let sepBuilder = TB.singleton sep in - zeroPadDayOfMonth d - <> sepBuilder - <> monthToZeroPaddedDigit m - <> sepBuilder - <> TB.decimal y - --- | Parse a Year\/Month\/Day-encoded 'Date' that uses the --- given separator. -parser_Ymd :: Maybe Char -> Parser Date -parser_Ymd msep = do - y <- parseFixedDigits 4 - traverse_ AT.char msep - m <- parseFixedDigits 2 - when (m < 1 || m > 12) (fail "month must be between 1 and 12") - traverse_ AT.char msep - d <- parseFixedDigits 2 - when (d < 1 || d > 31) (fail "day must be between 1 and 31") - pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) - --- | Parse a Month\/Day\/Year-encoded 'Date' that uses the --- given separator. -parser_Mdy :: Maybe Char -> Parser Date -parser_Mdy msep = do - m <- parseFixedDigits 2 - when (m < 1 || m > 12) (fail "month must be between 1 and 12") - traverse_ AT.char msep - d <- parseFixedDigits 2 - when (d < 1 || d > 31) (fail "day must be between 1 and 31") - traverse_ AT.char msep - y <- parseFixedDigits 4 - pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) - --- | Parse a Day\/Month\/Year-encoded 'Date' that uses the --- given separator. -parser_Dmy :: Maybe Char -> Parser Date -parser_Dmy msep = do - d <- parseFixedDigits 2 - when (d < 1 || d > 31) (fail "day must be between 1 and 31") - traverse_ AT.char msep - m <- parseFixedDigits 2 - when (m < 1 || m > 12) (fail "month must be between 1 and 12") - traverse_ AT.char msep - y <- parseFixedDigits 4 - pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) - --- | Given a 'Date' and a separator, construct a 'ByteString' 'BB.Builder' --- corresponding to a Day\/Month\/Year encoding. -builderUtf8_Ymd :: Maybe Char -> Date -> BB.Builder -builderUtf8_Ymd msep (Date (Year y) m d) = case msep of - Nothing -> - BB.intDec y - <> monthToZeroPaddedDigitBS m - <> zeroPadDayOfMonthBS d - Just sep -> let sepBuilder = BB.char7 sep in - BB.intDec y - <> sepBuilder - <> monthToZeroPaddedDigitBS m - <> sepBuilder - <> zeroPadDayOfMonthBS d - --- | Parse a Year\/Month\/Day-encoded 'Date' that uses the --- given separator. -parserUtf8_Ymd :: Maybe Char -> AB.Parser Date -parserUtf8_Ymd msep = do - y <- parseFixedDigitsIntBS 4 - traverse_ AB.char msep - m <- parseFixedDigitsIntBS 2 - when (m < 1 || m > 12) (fail "month must be between 1 and 12") - traverse_ AB.char msep - d <- parseFixedDigitsIntBS 2 - when (d < 1 || d > 31) (fail "day must be between 1 and 31") - pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) - --- | Given a 'SubsecondPrecision' and a separator, construct a --- 'Text' 'TB.Builder' corresponding to an Hour\/Minute\/Second --- encoding. -builder_HMS :: SubsecondPrecision -> Maybe Char -> TimeOfDay -> TB.Builder -builder_HMS sp msep (TimeOfDay h m ns) = - indexTwoDigitTextBuilder h - <> internalBuilder_NS sp msep m ns - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a separator, --- construct a 'Text' 'TB.Builder' according to an IMS encoding. --- --- This differs from 'builder_IMSp' in that their is a space --- between the seconds and locale. -builder_IMS_p :: MeridiemLocale Text -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> TB.Builder -builder_IMS_p meridiemLocale sp msep (TimeOfDay h m ns) = - internalBuilder_I h - <> internalBuilder_NS sp msep m ns - <> " " - <> internalBuilder_p meridiemLocale h - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a separator, --- construct a 'Text' 'TB.Builder' according to an IMS encoding. -builder_IMSp :: MeridiemLocale Text -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> TB.Builder -builder_IMSp meridiemLocale sp msep (TimeOfDay h m ns) = - internalBuilder_I h - <> internalBuilder_NS sp msep m ns - <> internalBuilder_p meridiemLocale h - -internalBuilder_I :: Int -> TB.Builder -internalBuilder_I h = - indexTwoDigitTextBuilder $ if h > 12 - then h - 12 - else if h == 0 - then 12 - else h - -internalBuilder_p :: MeridiemLocale Text -> Int -> TB.Builder -internalBuilder_p (MeridiemLocale am pm) h = if h > 11 - then TB.fromText pm - else TB.fromText am - --- | Parse an Hour\/Minute\/Second-encoded 'TimeOfDay' that uses --- the given separator. -parser_HMS :: Maybe Char -> Parser TimeOfDay -parser_HMS msep = do - h <- parseFixedDigits 2 - when (h > 23) (fail "hour must be between 0 and 23") - traverse_ AT.char msep - m <- parseFixedDigits 2 - when (m > 59) (fail "minute must be between 0 and 59") - traverse_ AT.char msep - ns <- parseSecondsAndNanoseconds - pure (TimeOfDay h m ns) - --- | Parses text that is formatted as either of the following: --- --- * @%H:%M@ --- * @%H:%M:%S@ --- --- That is, the seconds and subseconds part is optional. If it is --- not provided, it is assumed to be zero. This format shows up --- in Google Chrome\'s @datetime-local@ inputs. -parser_HMS_opt_S :: Maybe Char -> Parser TimeOfDay -parser_HMS_opt_S msep = do - h <- parseFixedDigits 2 - when (h > 23) (fail "hour must be between 0 and 23") - traverse_ AT.char msep - m <- parseFixedDigits 2 - when (m > 59) (fail "minute must be between 0 and 59") - mc <- AT.peekChar - case mc of - Nothing -> pure (TimeOfDay h m 0) - Just c -> case msep of - Just sep -> if c == sep - then do - _ <- AT.anyChar -- should be the separator - ns <- parseSecondsAndNanoseconds - pure (TimeOfDay h m ns) - else pure (TimeOfDay h m 0) - -- if there is no separator, we will try to parse the - -- remaining part as seconds. We commit to trying to - -- parse as seconds if we see any number as the next - -- character. - Nothing -> if isDigit c - then do - ns <- parseSecondsAndNanoseconds - pure (TimeOfDay h m ns) - else pure (TimeOfDay h m 0) - -parseSecondsAndNanoseconds :: Parser Int64 -parseSecondsAndNanoseconds = do - s' <- parseFixedDigits 2 - let s = fromIntegral s' :: Int64 - when (s > 60) (fail "seconds must be between 0 and 60") - 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) - ) <|> pure 0 - pure (s * 1000000000 + nanoseconds) - -countZeroes :: AT.Parser Int -countZeroes = go 0 where - go !i = do - m <- AT.peekChar - case m of - Nothing -> pure i - Just c -> if c == '0' - then AT.anyChar *> go (i + 1) - else pure i - -nanosecondsBuilder :: Int64 -> TB.Builder -nanosecondsBuilder w - | w == 0 = mempty - | w > 99999999 = "." <> TB.decimal w - | w > 9999999 = ".0" <> TB.decimal w - | w > 999999 = ".00" <> TB.decimal w - | w > 99999 = ".000" <> TB.decimal w - | w > 9999 = ".0000" <> TB.decimal w - | w > 999 = ".00000" <> TB.decimal w - | w > 99 = ".000000" <> TB.decimal w - | w > 9 = ".0000000" <> TB.decimal w - | otherwise = ".00000000" <> TB.decimal w - -microsecondsBuilder :: Int64 -> TB.Builder -microsecondsBuilder w - | w == 0 = mempty - | w > 99999 = "." <> TB.decimal w - | w > 9999 = ".0" <> TB.decimal w - | w > 999 = ".00" <> TB.decimal w - | w > 99 = ".000" <> TB.decimal w - | w > 9 = ".0000" <> TB.decimal w - | otherwise = ".00000" <> TB.decimal w - -millisecondsBuilder :: Int64 -> TB.Builder -millisecondsBuilder w - | w == 0 = mempty - | w > 99 = "." <> TB.decimal w - | w > 9 = ".0" <> TB.decimal w - | otherwise = ".00" <> TB.decimal w - -prettyNanosecondsBuilder :: SubsecondPrecision -> Int64 -> TB.Builder -prettyNanosecondsBuilder sp nano = case sp of - SubsecondPrecisionAuto - | milliRem == 0 -> millisecondsBuilder milli - | microRem == 0 -> microsecondsBuilder micro - | otherwise -> nanosecondsBuilder nano - SubsecondPrecisionFixed d -> if d == 0 - then mempty - else - let newSubsecondPart = quot nano (raiseTenTo (9 - d)) - in "." - <> TB.fromText (Text.replicate (d - countDigits newSubsecondPart) "0") - <> TB.decimal newSubsecondPart - where - (milli,milliRem) = quotRem nano 1000000 - (micro,microRem) = quotRem nano 1000 - --- | Encode a 'Timespan' as 'Text' using the given 'SubsecondPrecision'. -encodeTimespan :: SubsecondPrecision -> Timespan -> Text -encodeTimespan sp = - LT.toStrict . TB.toLazyText . builderTimespan sp - --- | Construct a 'Text' 'TB.Builder' corresponding to an encoding --- of the given 'Timespan' using the given 'SubsecondPrecision'. -builderTimespan :: SubsecondPrecision -> Timespan -> TB.Builder -builderTimespan sp (Timespan ns) = - TB.decimal sInt64 <> prettyNanosecondsBuilder sp nsRemainder - where - (!sInt64,!nsRemainder) = quotRem ns 1000000000 - -internalBuilder_NS :: SubsecondPrecision -> Maybe Char -> Int -> Int64 -> TB.Builder -internalBuilder_NS sp msep m ns = case msep of - Nothing -> indexTwoDigitTextBuilder m - <> indexTwoDigitTextBuilder s - <> prettyNanosecondsBuilder sp nsRemainder - Just sep -> let sepBuilder = TB.singleton sep in - sepBuilder - <> indexTwoDigitTextBuilder m - <> sepBuilder - <> indexTwoDigitTextBuilder s - <> prettyNanosecondsBuilder sp nsRemainder - where - (!sInt64,!nsRemainder) = quotRem ns 1000000000 - !s = fromIntegral sInt64 - --- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct a --- 'Text' 'TB.Builder' corresponding to a --- Day\/Month\/Year,Hour\/Minute\/Second encoding of the given 'Datetime'. -builder_DmyHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder -builder_DmyHMS sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - case msep of - Nothing -> builder_Dmy mdateSep date - <> builder_HMS sp mtimeSep time - Just sep -> builder_Dmy mdateSep date - <> TB.singleton sep - <> builder_HMS sp mtimeSep time - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', --- and a 'DatetimeFormat', construct a 'Text' 'TB.Builder' --- corresponding to a Day\/Month\/Year,IMS encoding of the given --- 'Datetime'. This differs from 'builder_DmyIMSp' in that --- it adds a space between the locale and seconds. -builder_DmyIMS_p :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder -builder_DmyIMS_p locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - builder_Dmy mdateSep date - <> maybe mempty TB.singleton msep - <> builder_IMS_p locale sp mtimeSep time - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', --- and a 'DatetimeFormat', construct a 'Text' 'TB.Builder' --- corresponding to a Day\/Month\/Year,IMS encoding of the given --- 'Datetime'. -builder_DmyIMSp :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder -builder_DmyIMSp locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - builder_Dmy mdateSep date - <> maybe mempty TB.singleton msep - <> builder_IMS_p locale sp mtimeSep time - --- | Given a 'SubsecondPrecision' and 'DatetimeFormat', construct --- 'Text' that corresponds to a Day\/Month\/Year,Hour\/Minute\/Second --- encoding of the given 'Datetime'. -encode_DmyHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> Text -encode_DmyHMS sp format = - LT.toStrict . TB.toLazyText . builder_DmyHMS sp format - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a --- 'DatetimeFormat', construct 'Text' that corresponds to a --- Day\/Month\/Year,IMS encoding of the given 'Datetime'. This --- inserts a space between the locale and seconds. -encode_DmyIMS_p :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> Text -encode_DmyIMS_p a sp b = LT.toStrict . TB.toLazyText . builder_DmyIMS_p a sp b - --- | Given a 'SubsecondPrecision' and 'DatetimeFormat', construct --- 'Text' that corresponds to a Year\/Month\/Day,Hour\/Minute\/Second --- encoding of the given 'Datetime'. -encode_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> Text -encode_YmdHMS sp format = - LT.toStrict . TB.toLazyText . builder_YmdHMS sp format - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a --- 'DatetimeFormat', construct 'Text' that corresponds to a --- Year\/Month\/Day,IMS encoding of the given 'Datetime'. This --- inserts a space between the locale and seconds. -encode_YmdIMS_p :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> Text -encode_YmdIMS_p a sp b = LT.toStrict . TB.toLazyText . builder_YmdIMS_p a sp b - --- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct --- a 'Text' 'TB.Builder' corresponding to a --- Year\/Month\/Day,Hour\/Minute\/Second encoding of the given 'Datetime'. -builder_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder -builder_YmdHMS sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - case msep of - Nothing -> builder_Ymd mdateSep date - <> builder_HMS sp mtimeSep time - Just sep -> builder_Ymd mdateSep date - <> TB.singleton sep - <> builder_HMS sp mtimeSep time - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a --- 'DatetimeFormat', construct a 'Text' 'TB.Builder' that --- corresponds to a Year\/Month\/Day,IMS encoding of the --- given 'Datetime'. This inserts a space between the locale --- and seconds. -builder_YmdIMS_p :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder -builder_YmdIMS_p locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - builder_Ymd mdateSep date - <> maybe mempty TB.singleton msep - <> builder_IMS_p locale sp mtimeSep time - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a --- 'DatetimeFormat', construct a 'Text' 'TB.Builder' that --- corresponds to a Year\/Month\/Day,IMS encoding of the --- given 'Datetime'. -builder_YmdIMSp :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder -builder_YmdIMSp locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - builder_Ymd mdateSep date - <> maybe mempty TB.singleton msep - <> builder_IMS_p locale sp mtimeSep time - --- | Construct a 'Text' 'TB.Builder' corresponding to the W3C --- encoding of the given 'Datetime'. -builderW3C :: Datetime -> TB.Builder -builderW3C = builder_YmdHMS SubsecondPrecisionAuto w3c - --- | Decode a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'Datetime' --- from 'Text' that was encoded with the given 'DatetimeFormat'. -decode_YmdHMS :: DatetimeFormat -> Text -> Maybe Datetime -decode_YmdHMS format = - either (const Nothing) Just . AT.parseOnly (parser_YmdHMS format) - --- | Parse a Day\/Month\/Year,Hour\/Minute\/Second-encoded 'Datetime' --- that was encoded with the given 'DatetimeFormat'. -parser_DmyHMS :: DatetimeFormat -> Parser Datetime -parser_DmyHMS (DatetimeFormat mdateSep msep mtimeSep) = do - date <- parser_Dmy mdateSep - traverse_ AT.char msep - time <- parser_HMS mtimeSep - pure (Datetime date time) - --- | Parses text that is formatted as either of the following: --- --- * @%H:%M@ --- * @%H:%M:%S@ --- --- That is, the seconds and subseconds part is optional. If it is --- not provided, it is assumed to be zero. This format shows up --- in Google Chrome\'s @datetime-local@ inputs. -parser_DmyHMS_opt_S :: DatetimeFormat -> Parser Datetime -parser_DmyHMS_opt_S (DatetimeFormat mdateSep msep mtimeSep) = do - date <- parser_Dmy mdateSep - traverse_ AT.char msep - time <- parser_HMS_opt_S mtimeSep - pure (Datetime date time) - --- | Decode a Day\/Month\/Year,Hour\/Minute\/Second-encoded 'Datetime' --- from 'Text' that was encoded with the given 'DatetimeFormat'. -decode_DmyHMS :: DatetimeFormat -> Text -> Maybe Datetime -decode_DmyHMS format = - either (const Nothing) Just . AT.parseOnly (parser_DmyHMS format) - --- | Parses text that is formatted as either of the following: --- --- * @%H:%M@ --- * @%H:%M:%S@ --- --- That is, the seconds and subseconds part is optional. If it is --- not provided, it is assumed to be zero. This format shows up --- in Google Chrome\'s @datetime-local@ inputs. -decode_DmyHMS_opt_S :: DatetimeFormat -> Text -> Maybe Datetime -decode_DmyHMS_opt_S format = - either (const Nothing) Just . AT.parseOnly (parser_DmyHMS_opt_S format) --- | Parses a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'Datetime' --- that was encoded using the given 'DatetimeFormat'. -parser_YmdHMS :: DatetimeFormat -> Parser Datetime -parser_YmdHMS (DatetimeFormat mdateSep msep mtimeSep) = do - date <- parser_Ymd mdateSep - traverse_ AT.char msep - time <- parser_HMS mtimeSep - pure (Datetime date time) - --- | Parses text that is formatted as either of the following: --- --- * @%H:%M@ --- * @%H:%M:%S@ --- --- That is, the seconds and subseconds part is optional. If it is --- not provided, it is assumed to be zero. This format shows up --- in Google Chrome\'s @datetime-local@ inputs. -parser_YmdHMS_opt_S :: DatetimeFormat -> Parser Datetime -parser_YmdHMS_opt_S (DatetimeFormat mdateSep msep mtimeSep) = do - date <- parser_Ymd mdateSep - traverse_ AT.char msep - time <- parser_HMS_opt_S mtimeSep - pure (Datetime date time) - --- | Parses text that is formatted as either of the following: --- --- * @%H:%M@ --- * @%H:%M:%S@ --- --- That is, the seconds and subseconds part is optional. If it is --- not provided, it is assumed to be zero. This format shows up --- in Google Chrome\'s @datetime-local@ inputs. -decode_YmdHMS_opt_S :: DatetimeFormat -> Text -> Maybe Datetime -decode_YmdHMS_opt_S format = - either (const Nothing) Just . AT.parseOnly (parser_YmdHMS_opt_S format) ---------------- --- ByteString stuff ---------------- - --- | Given a 'SubsecondPrecision' and a separator, construct a 'ByteString' 'BB.Builder' corresponding to an Hour\/Month\/Second encoding of the given 'TimeOfDay'. -builderUtf8_HMS :: SubsecondPrecision -> Maybe Char -> TimeOfDay -> BB.Builder -builderUtf8_HMS sp msep (TimeOfDay h m ns) = - indexTwoDigitByteStringBuilder h - <> internalBuilderUtf8_NS sp msep m ns - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a separator, construct a 'ByteString' 'BB.Builder' corresponding to an IMS encoding of the given 'TimeOfDay'. This differs from 'builderUtf8_IMSp' in that --- there is a space between the seconds and locale. -builderUtf8_IMS_p :: MeridiemLocale ByteString -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> BB.Builder -builderUtf8_IMS_p meridiemLocale sp msep (TimeOfDay h m ns) = - internalBuilderUtf8_I h - <> internalBuilderUtf8_NS sp msep m ns - <> " " - <> internalBuilderUtf8_p meridiemLocale h - -internalBuilderUtf8_I :: Int -> BB.Builder -internalBuilderUtf8_I h = - indexTwoDigitByteStringBuilder $ if h > 12 - then h - 12 - else if h == 0 - then 12 - else h - -internalBuilderUtf8_p :: MeridiemLocale ByteString -> Int -> BB.Builder -internalBuilderUtf8_p (MeridiemLocale am pm) h = if h > 11 - then BB.byteString pm - else BB.byteString am - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a separator, construct a 'ByteString' 'BB.Builder' corresponding to an IMS encoding of the given 'TimeOfDay'. -builderUtf8_IMSp :: MeridiemLocale ByteString -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> BB.Builder -builderUtf8_IMSp meridiemLocale sp msep (TimeOfDay h m ns) = - internalBuilderUtf8_I h - <> internalBuilderUtf8_NS sp msep m ns - <> internalBuilderUtf8_p meridiemLocale h - --- | Parse an Hour\/Minute\/Second-encoded 'TimeOfDay' that uses --- the given separator. -parserUtf8_HMS :: Maybe Char -> AB.Parser TimeOfDay -parserUtf8_HMS msep = do - h <- parseFixedDigitsIntBS 2 - when (h > 23) (fail "hour must be between 0 and 23") - traverse_ AB.char msep - m <- parseFixedDigitsIntBS 2 - when (m > 59) (fail "minute must be between 0 and 59") - traverse_ AB.char msep - ns <- parseSecondsAndNanosecondsUtf8 - pure (TimeOfDay h m ns) - --- | Parses text that is formatted as either of the following: --- --- * @%H:%M@ --- * @%H:%M:%S@ --- --- That is, the seconds and subseconds part is optional. If it is --- not provided, it is assumed to be zero. This format shows up --- in Google Chrome\'s @datetime-local@ inputs. -parserUtf8_HMS_opt_S :: Maybe Char -> AB.Parser TimeOfDay -parserUtf8_HMS_opt_S msep = do - h <- parseFixedDigitsIntBS 2 - when (h > 23) (fail "hour must be between 0 and 23") - traverse_ AB.char msep - m <- parseFixedDigitsIntBS 2 - when (m > 59) (fail "minute must be between 0 and 59") - mc <- AB.peekChar - case mc of - Nothing -> pure (TimeOfDay h m 0) - Just c -> case msep of - Just sep -> if c == sep - then do - _ <- AB.anyChar -- should be the separator - ns <- parseSecondsAndNanosecondsUtf8 - pure (TimeOfDay h m ns) - else pure (TimeOfDay h m 0) - -- if there is no separator, we will try to parse the - -- remaining part as seconds. We commit to trying to - -- parse as seconds if we see any number as the next - -- character. - Nothing -> if isDigit c - then do - ns <- parseSecondsAndNanosecondsUtf8 - pure (TimeOfDay h m ns) - else pure (TimeOfDay h m 0) - -parseSecondsAndNanosecondsUtf8 :: AB.Parser Int64 -parseSecondsAndNanosecondsUtf8 = do - s' <- parseFixedDigitsIntBS 2 - let !s = fromIntegral s' :: Int64 - 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) - ) <|> pure 0 - pure (s * 1000000000 + nanoseconds) - -countZeroesUtf8 :: AB.Parser Int -countZeroesUtf8 = go 0 where - go !i = do - m <- AB.peekChar - case m of - Nothing -> pure i - Just c -> if c == '0' - then AB.anyChar *> go (i + 1) - else pure i - -nanosecondsBuilderUtf8 :: Int64 -> BB.Builder -nanosecondsBuilderUtf8 w - | w == 0 = mempty - | w > 99999999 = "." <> int64Builder w - | w > 9999999 = ".0" <> int64Builder w - | w > 999999 = ".00" <> int64Builder w - | w > 99999 = ".000" <> int64Builder w - | w > 9999 = ".0000" <> int64Builder w - | w > 999 = ".00000" <> int64Builder w - | w > 99 = ".000000" <> int64Builder w - | w > 9 = ".0000000" <> int64Builder w - | otherwise = ".00000000" <> int64Builder w - -microsecondsBuilderUtf8 :: Int64 -> BB.Builder -microsecondsBuilderUtf8 w - | w == 0 = mempty - | w > 99999 = "." <> int64Builder w - | w > 9999 = ".0" <> int64Builder w - | w > 999 = ".00" <> int64Builder w - | w > 99 = ".000" <> int64Builder w - | w > 9 = ".0000" <> int64Builder w - | otherwise = ".00000" <> int64Builder w - -millisecondsBuilderUtf8 :: Int64 -> BB.Builder -millisecondsBuilderUtf8 w - | w == 0 = mempty - | w > 99 = "." <> int64Builder w - | w > 9 = ".0" <> int64Builder w - | otherwise = ".00" <> int64Builder w - -prettyNanosecondsBuilderUtf8 :: SubsecondPrecision -> Int64 -> BB.Builder -prettyNanosecondsBuilderUtf8 sp nano = case sp of - SubsecondPrecisionAuto - | milliRem == 0 -> millisecondsBuilderUtf8 milli - | microRem == 0 -> microsecondsBuilderUtf8 micro - | otherwise -> nanosecondsBuilderUtf8 nano - SubsecondPrecisionFixed d -> if d == 0 - then mempty - else - let newSubsecondPart = quot nano (raiseTenTo (9 - d)) - in BB.char7 '.' - <> BB.byteString (BC.replicate (d - countDigits newSubsecondPart) '0') - <> int64Builder newSubsecondPart - where - (milli,milliRem) = quotRem nano 1000000 - (micro,microRem) = quotRem nano 1000 - --- | Given a 'SubsecondPrecision', construct a 'ByteString' corresponding --- to an encoding of the given 'Timespan'. -encodeTimespanUtf8 :: SubsecondPrecision -> Timespan -> ByteString -encodeTimespanUtf8 sp = - LB.toStrict . BB.toLazyByteString . builderTimespanUtf8 sp - --- | Given a 'SubsecondPrecision', construct a 'ByteString' 'BB.Builder' --- corresponding to an encoding of the given 'Timespan'. -builderTimespanUtf8 :: SubsecondPrecision -> Timespan -> BB.Builder -builderTimespanUtf8 sp (Timespan ns) = - int64Builder sInt64 <> prettyNanosecondsBuilderUtf8 sp nsRemainder - where - (!sInt64,!nsRemainder) = quotRem ns 1000000000 - -int64Builder :: Int64 -> BB.Builder -int64Builder = BB.integerDec . fromIntegral - -internalBuilderUtf8_NS :: SubsecondPrecision -> Maybe Char -> Int -> Int64 -> BB.Builder -internalBuilderUtf8_NS sp msep m ns = case msep of - Nothing -> indexTwoDigitByteStringBuilder m - <> indexTwoDigitByteStringBuilder s - <> prettyNanosecondsBuilderUtf8 sp nsRemainder - Just sep -> let sepBuilder = BB.char7 sep in - sepBuilder - <> indexTwoDigitByteStringBuilder m - <> sepBuilder - <> indexTwoDigitByteStringBuilder s - <> prettyNanosecondsBuilderUtf8 sp nsRemainder - where - (!sInt64,!nsRemainder) = quotRem ns 1000000000 - !s = fromIntegral sInt64 - --- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct --- a 'ByteString' corresponding to a Year\/Month\/Day,Hour\/Minute\/Second --- encoding of the given 'Datetime'. -encodeUtf8_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> ByteString -encodeUtf8_YmdHMS sp format = - LB.toStrict . BB.toLazyByteString . builderUtf8_YmdHMS sp format - --- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a 'DatetimeFormat', --- construct a 'ByteString' corresponding to a Year\/Month\/Day,IMS encoding --- of the given 'Datetime'. This inserts a space between the locale and --- seconds. -encodeUtf8_YmdIMS_p :: MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> Datetime -> ByteString -encodeUtf8_YmdIMS_p a sp b = LB.toStrict . BB.toLazyByteString . builderUtf8_YmdIMS_p a sp b - --- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct --- a 'ByteString' 'BB.Builder' corresponding to a --- Year\/Month\/Day,Hour\/Minute\/Second encoding of the --- given 'Datetime'. -builderUtf8_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> BB.Builder -builderUtf8_YmdHMS sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - case msep of - Nothing -> builderUtf8_Ymd mdateSep date - <> builderUtf8_HMS sp mtimeSep time - Just sep -> builderUtf8_Ymd mdateSep date - <> BB.char7 sep - <> builderUtf8_HMS sp mtimeSep time - --- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct --- a 'ByteString' 'BB.Builder' corresponding to a --- Year\/Month\/Day,IMS encoding of the given 'Datetime'. This inserts --- a space between the locale and seconds. -builderUtf8_YmdIMS_p :: MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> Datetime -> BB.Builder -builderUtf8_YmdIMS_p locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - builderUtf8_Ymd mdateSep date - <> maybe mempty BB.char7 msep - <> builderUtf8_IMS_p locale sp mtimeSep time - --- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct --- a 'ByteString' 'BB.Builder' corresponding to a --- Year\/Month\/Day,IMS encoding of the given 'Datetime'. -builderUtf8_YmdIMSp :: MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> Datetime -> BB.Builder -builderUtf8_YmdIMSp locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - builderUtf8_Ymd mdateSep date - <> maybe mempty BB.char7 msep - <> builderUtf8_IMS_p locale sp mtimeSep time - --- | Construct a 'ByteString' 'BB.Builder' corresponding to --- a W3C encoding of the given 'Datetime'. -builderUtf8W3C :: Datetime -> BB.Builder -builderUtf8W3C = builderUtf8_YmdHMS SubsecondPrecisionAuto (DatetimeFormat (Just '-') (Just 'T') (Just ':')) - --- | Decode a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'Datetime' from --- a 'ByteString'. -decodeUtf8_YmdHMS :: DatetimeFormat -> ByteString -> Maybe Datetime -decodeUtf8_YmdHMS format = - either (const Nothing) Just . AB.parseOnly (parserUtf8_YmdHMS format) - --- | Parse a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'Datetime' that was --- encoded using the given 'DatetimeFormat'. -parserUtf8_YmdHMS :: DatetimeFormat -> AB.Parser Datetime -parserUtf8_YmdHMS (DatetimeFormat mdateSep msep mtimeSep) = do - date <- parserUtf8_Ymd mdateSep - traverse_ AB.char msep - time <- parserUtf8_HMS mtimeSep - pure (Datetime date time) - --- | Parses text that is formatted as either of the following: --- --- * @%H:%M@ --- * @%H:%M:%S@ --- --- That is, the seconds and subseconds part is optional. If it is --- not provided, it is assumed to be zero. This format shows up --- in Google Chrome\'s @datetime-local@ inputs. -parserUtf8_YmdHMS_opt_S :: DatetimeFormat -> AB.Parser Datetime -parserUtf8_YmdHMS_opt_S (DatetimeFormat mdateSep msep mtimeSep) = do - date <- parserUtf8_Ymd mdateSep - traverse_ AB.char msep - time <- parserUtf8_HMS_opt_S mtimeSep - pure (Datetime date time) - --- | Parses text that is formatted as either of the following: --- --- * @%H:%M@ --- * @%H:%M:%S@ --- --- That is, the seconds and subseconds part is optional. If it is --- not provided, it is assumed to be zero. This format shows up --- in Google Chrome\'s @datetime-local@ inputs. -decodeUtf8_YmdHMS_opt_S :: DatetimeFormat -> ByteString -> Maybe Datetime -decodeUtf8_YmdHMS_opt_S format = - either (const Nothing) Just . AB.parseOnly (parserUtf8_YmdHMS_opt_S format) - --- | Given an 'OffsetFormat', a 'SubsecondPrecision', and --- a 'DatetimeFormat', construct a 'Text' 'TB.Builder' --- corresponding to a Year\/Month\/Day,Hour\/Minute\/Second encoding --- of the given 'OffsetDatetime'. -builder_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> TB.Builder -builder_YmdHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = - builder_YmdHMS sp datetimeFormat datetime - <> builderOffset offsetFormat offset - --- | Parse a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'OffsetDatetime' --- that was encoded using the given 'OffsetFormat' --- and 'DatetimeFormat'. -parser_YmdHMSz :: OffsetFormat -> DatetimeFormat -> Parser OffsetDatetime -parser_YmdHMSz offsetFormat datetimeFormat = OffsetDatetime - <$> parser_YmdHMS datetimeFormat - <*> parserOffset offsetFormat - --- | Given an 'OffsetFormat', a 'MeridiemLocale', a --- 'SubsecondPrecision', and 'DatetimeFormat', construct a --- 'Text' 'TB.Builder' corresponding to a Year\/Month\/Day,IMS-encoding --- of the given 'OffsetDatetime'. -builder_YmdIMS_p_z :: OffsetFormat -> MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> TB.Builder -builder_YmdIMS_p_z offsetFormat meridiemLocale sp datetimeFormat (OffsetDatetime datetime offset) = - builder_YmdIMS_p meridiemLocale sp datetimeFormat datetime - <> " " - <> builderOffset offsetFormat offset - --- | Given an 'OffsetFormat', a 'SubsecondPrecision', --- and a 'DatetimeFormat', construct 'Text' corresponding to --- the Year\/Month\/Day,Hour\/Minute\/Second-encoding of --- the given 'OffsetDatetime'. -encode_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> Text -encode_YmdHMSz offsetFormat sp datetimeFormat = - LT.toStrict . TB.toLazyText . builder_YmdHMSz offsetFormat sp datetimeFormat - --- | Given an 'OffsetFormat', a 'SubsecondPrecision', and a --- 'DatetimeFormat', construct a 'Text' 'TB.Builder' corresponding --- to the Day\/Month\/Year,Hour\/Minute\/Second-encoding of --- the given 'OffsetDatetime'. -builder_DmyHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> TB.Builder -builder_DmyHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = - builder_DmyHMS sp datetimeFormat datetime - <> builderOffset offsetFormat offset - --- | Parse a Day\/Month\/Year,Hour\/Minute\/Second-encoded 'OffsetDatetime' --- that was encoded using the given 'OffsetFormat' --- and 'DatetimeFormat'. -parser_DmyHMSz :: OffsetFormat -> DatetimeFormat -> AT.Parser OffsetDatetime -parser_DmyHMSz offsetFormat datetimeFormat = OffsetDatetime - <$> parser_DmyHMS datetimeFormat - <*> parserOffset offsetFormat - --- | Given an 'OffsetFormat', a 'MeridiemLocale', a --- 'SubsecondPrecision', and a 'DatetimeFormat', construct a 'Text' --- 'TB.Builder' corresponding to the Day\/Month\/Year,IMS encoding --- of the given 'OffsetDatetime'. -builder_DmyIMS_p_z :: OffsetFormat -> MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> TB.Builder -builder_DmyIMS_p_z offsetFormat meridiemLocale sp datetimeFormat (OffsetDatetime datetime offset) = - builder_DmyIMS_p meridiemLocale sp datetimeFormat datetime - <> " " - <> builderOffset offsetFormat offset - --- | Given an 'OffsetFormat', a 'SubsecondPrecision', and a --- 'DatetimeFormat', construct 'Text' corresponding to the --- Day\/Month\/Year,Hour\/Minute\/Second encoding of the given --- 'OffsetDatetime'. -encode_DmyHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> Text -encode_DmyHMSz offsetFormat sp datetimeFormat = - LT.toStrict . TB.toLazyText . builder_DmyHMSz offsetFormat sp datetimeFormat - --- | Construct a 'Text' 'TB.Builder' corresponding to the w3c-formatting --- of the given 'OffsetDatetime'. -builderW3Cz :: OffsetDatetime -> TB.Builder -builderW3Cz = builder_YmdHMSz - OffsetFormatColonOn - SubsecondPrecisionAuto - (DatetimeFormat (Just '-') (Just 'T') (Just ':')) - --- | Encode an 'Offset' to 'Text' using the given 'OffsetFormat'. -encodeOffset :: OffsetFormat -> Offset -> Text -encodeOffset fmt = LT.toStrict . TB.toLazyText . builderOffset fmt - --- | Construct a 'TB.Builder' corresponding to the given 'Offset' --- encoded using the given 'OffsetFormat'. -builderOffset :: OffsetFormat -> Offset -> TB.Builder -builderOffset x = case x of - OffsetFormatColonOff -> builderOffset_z - OffsetFormatColonOn -> builderOffset_z1 - OffsetFormatSecondsPrecision -> builderOffset_z2 - OffsetFormatColonAuto -> builderOffset_z3 - --- | Decode an 'Offset' from 'Text' that was encoded --- using the given 'OffsetFormat'. -decodeOffset :: OffsetFormat -> Text -> Maybe Offset -decodeOffset fmt = - either (const Nothing) Just . AT.parseOnly (parserOffset fmt <* AT.endOfInput) - --- | Parse an 'Offset' that was encoded using the given 'OffsetFormat'. -parserOffset :: OffsetFormat -> Parser Offset -parserOffset x = case x of - OffsetFormatColonOff -> parserOffset_z - OffsetFormatColonOn -> parserOffset_z1 - OffsetFormatSecondsPrecision -> parserOffset_z2 - OffsetFormatColonAuto -> parserOffset_z3 - --- | True means positive, false means negative -parseSignedness :: Parser Bool -parseSignedness = do - c <- AT.anyChar - if c == '-' - then pure False - else if c == '+' - then pure True - else fail "while parsing offset, expected [+] or [-]" - -parserOffset_z :: Parser Offset -parserOffset_z = do - pos <- parseSignedness - h <- parseFixedDigits 2 - m <- parseFixedDigits 2 - let !res = h * 60 + m - pure . Offset $ if pos - then res - else negate res - -parserOffset_z1 :: Parser Offset -parserOffset_z1 = do - pos <- parseSignedness - h <- parseFixedDigits 2 - _ <- AT.char ':' - m <- parseFixedDigits 2 - let !res = h * 60 + m - pure . Offset $ if pos - then res - else negate res - -parserOffset_z2 :: AT.Parser Offset -parserOffset_z2 = do - pos <- parseSignedness - h <- parseFixedDigits 2 - _ <- AT.char ':' - m <- parseFixedDigits 2 - _ <- AT.string ":00" - let !res = h * 60 + m - pure . Offset $ if pos - then res - else negate res - --- | This is generous in what it accepts. If you give --- something like +04:00 as the offset, it will be --- allowed, even though it could be shorter. -parserOffset_z3 :: AT.Parser Offset -parserOffset_z3 = do - pos <- parseSignedness - h <- parseFixedDigits 2 - mc <- AT.peekChar - case mc of - Just ':' -> do - _ <- AT.anyChar -- should be a colon - m <- parseFixedDigits 2 - let !res = h * 60 + m - pure . Offset $ if pos - then res - else negate res - _ -> pure . Offset $ if pos - then h * 60 - else h * (-60) - -builderOffset_z :: Offset -> TB.Builder -builderOffset_z (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> indexTwoDigitTextBuilder a - <> indexTwoDigitTextBuilder b - -builderOffset_z1 :: Offset -> TB.Builder -builderOffset_z1 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> indexTwoDigitTextBuilder a - <> ":" - <> indexTwoDigitTextBuilder b - -builderOffset_z2 :: Offset -> TB.Builder -builderOffset_z2 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> indexTwoDigitTextBuilder a - <> ":" - <> indexTwoDigitTextBuilder b - <> ":00" - -builderOffset_z3 :: Offset -> TB.Builder -builderOffset_z3 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in if b == 0 - then prefix - <> indexTwoDigitTextBuilder a - else prefix - <> indexTwoDigitTextBuilder a - <> ":" - <> indexTwoDigitTextBuilder b - --- | Given an 'OffsetFormat', a 'SubsecondPrecision', and a --- 'DatetimeFormat', construct a 'ByteString' 'BB.Builder' --- corresponding to the Year\/Month\/Day,Hour\/Minute\/Second --- encoding of the given 'OffsetDatetime'. -builderUtf8_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> BB.Builder -builderUtf8_YmdHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = - builderUtf8_YmdHMS sp datetimeFormat datetime - <> builderOffsetUtf8 offsetFormat offset - --- | Parse a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'OffsetDatetime' --- that was encoded using the given 'OffsetFormat' and --- 'DatetimeFormat'. -parserUtf8_YmdHMSz :: OffsetFormat -> DatetimeFormat -> AB.Parser OffsetDatetime -parserUtf8_YmdHMSz offsetFormat datetimeFormat = OffsetDatetime - <$> parserUtf8_YmdHMS datetimeFormat - <*> parserOffsetUtf8 offsetFormat - --- | Given an 'OffsetFormat', a 'MeridiemLocale, a 'SubsecondPrecision', --- and a 'DatetimeFormat', construct a 'ByteString' 'BB.Builder' --- corresponding to a Year\/Month\/Day,IMS-encoded 'OffsetDatetime'. -builderUtf8_YmdIMS_p_z :: OffsetFormat -> MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> BB.Builder -builderUtf8_YmdIMS_p_z offsetFormat meridiemLocale sp datetimeFormat (OffsetDatetime datetime offset) = - builderUtf8_YmdIMS_p meridiemLocale sp datetimeFormat datetime - <> " " - <> builderOffsetUtf8 offsetFormat offset - --- | Construct a 'ByteString' 'BB.Builder' corresponding to the W3C --- encoding of the given 'Datetime'. -builderUtf8W3Cz :: OffsetDatetime -> BB.Builder -builderUtf8W3Cz = builderUtf8_YmdHMSz - OffsetFormatColonOn - SubsecondPrecisionAuto - (DatetimeFormat (Just '-') (Just 'T') (Just ':')) - --- | Encode an 'Offset' as a 'ByteString' using the given 'OffsetFormat'. -encodeOffsetUtf8 :: OffsetFormat -> Offset -> ByteString -encodeOffsetUtf8 fmt = LB.toStrict . BB.toLazyByteString . builderOffsetUtf8 fmt - --- | Decode an 'Offset' from a 'ByteString' that was encoded using the given --- 'OffsetFormat'. -decodeOffsetUtf8 :: OffsetFormat -> ByteString -> Maybe Offset -decodeOffsetUtf8 fmt = - either (const Nothing) Just . AB.parseOnly (parserOffsetUtf8 fmt) - --- | Construct a 'ByteString' 'BB.Builder' corresponding to the --- encoding of an 'Offset' using the given 'OffsetFormat'. -builderOffsetUtf8 :: OffsetFormat -> Offset -> BB.Builder -builderOffsetUtf8 x = case x of - OffsetFormatColonOff -> builderOffsetUtf8_z - OffsetFormatColonOn -> builderOffsetUtf8_z1 - OffsetFormatSecondsPrecision -> builderOffsetUtf8_z2 - OffsetFormatColonAuto -> builderOffsetUtf8_z3 - --- | Parse an 'Offset' that was encoded using the given --- 'OffsetFormat'. -parserOffsetUtf8 :: OffsetFormat -> AB.Parser Offset -parserOffsetUtf8 x = case x of - OffsetFormatColonOff -> parserOffsetUtf8_z - OffsetFormatColonOn -> parserOffsetUtf8_z1 - OffsetFormatSecondsPrecision -> parserOffsetUtf8_z2 - OffsetFormatColonAuto -> parserOffsetUtf8_z3 - --- | True means positive, false means negative -parseSignednessUtf8 :: AB.Parser Bool -parseSignednessUtf8 = do - c <- AB.anyChar - if c == '-' - then pure False - else if c == '+' - then pure True - else fail "while parsing offset, expected [+] or [-]" - -parserOffsetUtf8_z :: AB.Parser Offset -parserOffsetUtf8_z = do - pos <- parseSignednessUtf8 - h <- parseFixedDigitsIntBS 2 - m <- parseFixedDigitsIntBS 2 - let !res = h * 60 + m - pure . Offset $ if pos - then res - else negate res - -parserOffsetUtf8_z1 :: AB.Parser Offset -parserOffsetUtf8_z1 = do - pos <- parseSignednessUtf8 - h <- parseFixedDigitsIntBS 2 - _ <- AB.char ':' - m <- parseFixedDigitsIntBS 2 - let !res = h * 60 + m - pure . Offset $ if pos - then res - else negate res - -parserOffsetUtf8_z2 :: AB.Parser Offset -parserOffsetUtf8_z2 = do - pos <- parseSignednessUtf8 - h <- parseFixedDigitsIntBS 2 - _ <- AB.char ':' - m <- parseFixedDigitsIntBS 2 - _ <- AB.string ":00" - let !res = h * 60 + m - pure . Offset $ if pos - then res - else negate res - --- | This is generous in what it accepts. If you give --- something like +04:00 as the offset, it will be --- allowed, even though it could be shorter. -parserOffsetUtf8_z3 :: AB.Parser Offset -parserOffsetUtf8_z3 = do - pos <- parseSignednessUtf8 - h <- parseFixedDigitsIntBS 2 - mc <- AB.peekChar - case mc of - Just ':' -> do - _ <- AB.anyChar -- should be a colon - m <- parseFixedDigitsIntBS 2 - let !res = h * 60 + m - pure . Offset $ if pos - then res - else negate res - _ -> pure . Offset $ if pos - then h * 60 - else h * (-60) - -builderOffsetUtf8_z :: Offset -> BB.Builder -builderOffsetUtf8_z (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> indexTwoDigitByteStringBuilder a - <> indexTwoDigitByteStringBuilder b - -builderOffsetUtf8_z1 :: Offset -> BB.Builder -builderOffsetUtf8_z1 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> indexTwoDigitByteStringBuilder a - <> ":" - <> indexTwoDigitByteStringBuilder b - -builderOffsetUtf8_z2 :: Offset -> BB.Builder -builderOffsetUtf8_z2 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> indexTwoDigitByteStringBuilder a - <> ":" - <> indexTwoDigitByteStringBuilder b - <> ":00" - -builderOffsetUtf8_z3 :: Offset -> BB.Builder -builderOffsetUtf8_z3 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in if b == 0 - then prefix - <> indexTwoDigitByteStringBuilder a - else prefix - <> indexTwoDigitByteStringBuilder a - <> ":" - <> indexTwoDigitByteStringBuilder b - --- Zepto parsers - --- | Parse a 'Datetime' that was encoded using the --- given 'DatetimeFormat'. -zeptoUtf8_YmdHMS :: DatetimeFormat -> Z.Parser Datetime -zeptoUtf8_YmdHMS (DatetimeFormat mdateSep msep' mtimeSep) = do - date <- zeptoUtf8_Ymd mdateSep - let msep = BC.singleton <$> msep' - traverse_ Z.string msep - time <- zeptoUtf8_HMS mtimeSep - pure (Datetime date time) - -zeptoCountZeroes :: Z.Parser Int -zeptoCountZeroes = do - bs <- Z.takeWhile (0x30 ==) - pure $! BC.length bs - --- | Parse a 'Date' that was encoded using --- the given separator. -zeptoUtf8_Ymd :: Maybe Char -> Z.Parser Date -zeptoUtf8_Ymd msep' = do - y <- zeptoFixedDigitsIntBS 4 - let msep = BC.singleton <$> msep' - traverse_ Z.string msep - m <- zeptoFixedDigitsIntBS 2 - when (m < 1 || m > 12) (fail "month must be between 1 and 12") - traverse_ Z.string msep - d <- zeptoFixedDigitsIntBS 2 - when (d < 1 || d > 31) (fail "day must be between 1 and 31") - pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) - --- | Parse a 'TimeOfDay' that was encoded using --- the given separator. -zeptoUtf8_HMS :: Maybe Char -> Z.Parser TimeOfDay -zeptoUtf8_HMS msep' = do - h <- zeptoFixedDigitsIntBS 2 - when (h > 23) (fail "hour must be between 0 and 23") - let msep = BC.singleton <$> msep' - traverse_ Z.string msep - m <- zeptoFixedDigitsIntBS 2 - when (m > 59) (fail "minute must be between 0 and 59") - traverse_ Z.string msep - ns <- zeptoSecondsAndNanosecondsUtf8 - pure (TimeOfDay h m ns) - -zeptoFixedDigitsIntBS :: Int -> Z.Parser Int -zeptoFixedDigitsIntBS n = do - t <- Z.take n - case BC.readInt t of - Nothing -> fail "datetime decoding could not parse integral bytestring (a)" - Just (i,r) -> if BC.null r - then pure i - else fail "datetime decoding could not parse integral bytestring (b)" - -zeptoSecondsAndNanosecondsUtf8 :: Z.Parser Int64 -zeptoSecondsAndNanosecondsUtf8 = do - s' <- zeptoFixedDigitsIntBS 2 - let s = fromIntegral s' :: Int64 - when (s > 60) (fail "seconds must be between 0 and 60") - nanoseconds <- - ( do _ <- Z.string "." - numberOfZeroes <- zeptoCountZeroes - x <- zdecimal - 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 (s * 1000000000 + nanoseconds) - -zdecimal :: Z.Parser Int64 -zdecimal = do - digits <- Z.takeWhile wordIsDigit - case BC.readInt digits of - Nothing -> fail "somehow this didn't work" - Just (i,_) -> pure $! fromIntegral i - -wordIsDigit :: Word8 -> Bool -wordIsDigit a = 0x30 <= a && a <= 0x39 - --- | The 'Month' of January. -january :: Month -january = Month 0 - --- | The 'Month' of February. -february :: Month -february = Month 1 - --- | The 'Month' of March. -march :: Month -march = Month 2 - --- | The 'Month' of April. -april :: Month -april = Month 3 - --- | The 'Month' of May. -may :: Month -may = Month 4 - --- | The 'Month' of June. -june :: Month -june = Month 5 - --- | The 'Month' of July. -july :: Month -july = Month 6 - --- | The 'Month' of August. -august :: Month -august = Month 7 - --- | The 'Month' of September. -september :: Month -september = Month 8 - --- | The 'Month' of October. -october :: Month -october = Month 9 - --- | The 'Month' of November. -november :: Month -november = Month 10 - --- | The 'Month' of December. -december :: Month -december = Month 11 - --- | The 'DayOfWeek' Sunday. -sunday :: DayOfWeek -sunday = DayOfWeek 0 - --- | The 'DayOfWeek' Monday. -monday :: DayOfWeek -monday = DayOfWeek 1 - --- | The 'DayOfWeek' Tuesday. -tuesday :: DayOfWeek -tuesday = DayOfWeek 2 - --- | The 'DayOfWeek' Wednesday. -wednesday :: DayOfWeek -wednesday = DayOfWeek 3 - --- | The 'DayOfWeek' Thursday. -thursday :: DayOfWeek -thursday = DayOfWeek 4 - --- | The 'DayOfWeek' Friday. -friday :: DayOfWeek -friday = DayOfWeek 5 - --- | The 'DayOfWeek' Saturday. -saturday :: DayOfWeek -saturday = DayOfWeek 6 - -countDigits :: (Integral a) => a -> Int -countDigits v0 - | fromIntegral v64 == v0 = go 1 v64 - | otherwise = goBig 1 (fromIntegral v0) - where v64 = fromIntegral v0 - goBig !k (v :: Integer) - | v > big = goBig (k + 19) (v `quot` big) - | otherwise = go k (fromIntegral v) - big = 10000000000000000000 - go !k (v :: Word64) - | v < 10 = k - | v < 100 = k + 1 - | v < 1000 = k + 2 - | v < 1000000000000 = - k + if v < 100000000 - then if v < 1000000 - then if v < 10000 - then 3 - else 4 + fin v 100000 - else 6 + fin v 10000000 - else if v < 10000000000 - then 8 + fin v 1000000000 - else 10 + fin v 100000000000 - | otherwise = go (k + 12) (v `quot` 1000000000000) - fin v n = if v >= n then 1 else 0 - -clip :: (Ord t) => t -> t -> t -> t -clip a _ x | x < a = a -clip _ b x | x > b = b -clip _ _ x = x - -parseFixedDigits :: Int -> AT.Parser Int -parseFixedDigits n = do - t <- AT.take n - case Text.decimal t of - Left err -> fail err - Right (i,r) -> if Text.null r - then pure i - else fail "datetime decoding could not parse integral text" - -parseFixedDigitsIntBS :: Int -> AB.Parser Int -parseFixedDigitsIntBS n = do - t <- AB.take n - case BC.readInt t of - Nothing -> fail "datetime decoding could not parse integral bytestring (a)" - Just (i,r) -> if BC.null r - then pure i - else fail "datetime decoding could not parse integral bytestring (b)" - --- Only provide positive numbers to this function. -indexTwoDigitTextBuilder :: Int -> TB.Builder -indexTwoDigitTextBuilder i = if i < 100 - then Vector.unsafeIndex twoDigitTextBuilder (fromIntegral i) - else TB.decimal i - --- | Only provide positive numbers to this function. -indexTwoDigitByteStringBuilder :: Int -> BB.Builder -indexTwoDigitByteStringBuilder i = if i < 100 - then Vector.unsafeIndex twoDigitByteStringBuilder (fromIntegral i) - else BB.intDec i - -twoDigitByteStringBuilder :: Vector BB.Builder -twoDigitByteStringBuilder = Vector.fromList - $ map (BB.byteString . BC.pack) twoDigitStrings -{-# NOINLINE twoDigitByteStringBuilder #-} - -twoDigitTextBuilder :: Vector TB.Builder -twoDigitTextBuilder = Vector.fromList - $ map (TB.fromText . Text.pack) twoDigitStrings -{-# NOINLINE twoDigitTextBuilder #-} - -twoDigitStrings :: [String] -twoDigitStrings = - [ "00","01","02","03","04","05","06","07","08","09" - , "10","11","12","13","14","15","16","17","18","19" - , "20","21","22","23","24","25","26","27","28","29" - , "30","31","32","33","34","35","36","37","38","39" - , "40","41","42","43","44","45","46","47","48","49" - , "50","51","52","53","54","55","56","57","58","59" - , "60","61","62","63","64","65","66","67","68","69" - , "70","71","72","73","74","75","76","77","78","79" - , "80","81","82","83","84","85","86","87","88","89" - , "90","91","92","93","94","95","96","97","98","99" - ] - -raiseTenTo :: Int -> Int64 -raiseTenTo i = if i > 15 - then 10 ^ i - else UVector.unsafeIndex tenRaisedToSmallPowers i - -tenRaisedToSmallPowers :: UVector.Vector Int64 -tenRaisedToSmallPowers = UVector.fromList $ map (10 ^) [0 :: Int ..15] - -monthToZeroPaddedDigit :: Month -> TB.Builder -monthToZeroPaddedDigit (Month x) = - indexTwoDigitTextBuilder (x + 1) - -zeroPadDayOfMonth :: DayOfMonth -> TB.Builder -zeroPadDayOfMonth (DayOfMonth d) = indexTwoDigitTextBuilder d - -monthToZeroPaddedDigitBS :: Month -> BB.Builder -monthToZeroPaddedDigitBS (Month x) = - indexTwoDigitByteStringBuilder (x + 1) - -zeroPadDayOfMonthBS :: DayOfMonth -> BB.Builder -zeroPadDayOfMonthBS (DayOfMonth d) = indexTwoDigitByteStringBuilder d - --- | Is the given 'Time' within the 'TimeInterval'? -within :: Time -> TimeInterval -> Bool -t `within` (TimeInterval t0 t1) = t >= t0 && t <= t1 - --- | Convert a 'TimeInterval' to a 'Timespan'. This is equivalent to 'width'. -timeIntervalToTimespan :: TimeInterval -> Timespan -timeIntervalToTimespan = width - --- | The 'TimeInterval' that covers the entire range of 'Time's that Chronos supports. --- --- prop> \(t :: Time) -> within t whole -whole :: TimeInterval -whole = TimeInterval minBound maxBound - --- | The singleton (degenerate) 'TimeInterval'. -singleton :: Time -> TimeInterval -singleton x = TimeInterval x x - --- | Get the lower bound of the 'TimeInterval'. -lowerBound :: TimeInterval -> Time -lowerBound (TimeInterval t0 _) = t0 - --- | Get the upper bound of the 'TimeInterval'. -upperBound :: TimeInterval -> Time -upperBound (TimeInterval _ t1) = t1 - --- | The width of the 'TimeInterval'. This is equivalent to 'timeIntervalToTimespan'. -width :: TimeInterval -> Timespan -width (TimeInterval x y) = difference y x - --- | A smart constructor for 'TimeInterval'. In general, you should prefer using this --- over the 'TimeInterval' constructor, since it maintains the invariant that --- @'lowerBound' interval '<=' 'upperBound' interval@. -timeIntervalBuilder :: Time -> Time -> TimeInterval -timeIntervalBuilder x y = case compare x y of - GT -> TimeInterval y x - _ -> TimeInterval x y - -infix 3 ... - --- | An infix 'timeIntervalBuilder'. -(...) :: Time -> Time -> TimeInterval -(...) = timeIntervalBuilder - --- | A day represented as the modified Julian date, the number of days --- since midnight on November 17, 1858. -newtype Day = Day { getDay :: Int } - deriving (Show,Read,Eq,Ord,Hashable,Enum,ToJSON,FromJSON,Storable,Prim) -instance Torsor Day Int where - add i (Day d) = Day (d + i) - difference (Day a) (Day b) = a - b - --- | The day of the week. -newtype DayOfWeek = DayOfWeek { getDayOfWeek :: Int } - deriving (Show,Read,Eq,Ord,Hashable) - --- | The day of the month. -newtype DayOfMonth = DayOfMonth { getDayOfMonth :: Int } - deriving (Show,Read,Eq,Ord,Prim,Enum) - --- | The day of the year. -newtype DayOfYear = DayOfYear { getDayOfYear :: Int } - deriving (Show,Read,Eq,Ord,Prim) - --- | The month of the year. -newtype Month = Month { getMonth :: Int } - deriving (Show,Read,Eq,Ord,Prim) - -instance Enum Month where - fromEnum = getMonth - toEnum = Month - succ (Month x) = if x < 11 - then Month (x + 1) - else error "Enum.succ{Month}: tried to take succ of December" - pred (Month x) = if x > 0 - then Month (x - 1) - else error "Enum.pred{Month}: tried to take pred of January" - enumFrom x = enumFromTo x (Month 11) - --- | 'Month' starts at 0 and ends at 11 (January to December) -instance Bounded Month where - minBound = Month 0 - maxBound = Month 11 - --- | The number of years elapsed since the beginning --- of the Common Era. -newtype Year = Year { getYear :: Int } - deriving (Show,Read,Eq,Ord) - --- | A . -newtype Offset = Offset { getOffset :: Int } - deriving (Show,Read,Eq,Ord,Enum) - --- | POSIX time with nanosecond resolution. -newtype Time = Time { getTime :: Int64 } - deriving (FromJSON,ToJSON,Hashable,Eq,Ord,Show,Read,Storable,Prim,Bounded) - --- | Match a 'DayOfWeek'. By `match`, we mean that a 'DayOfWeekMatch' --- is a mapping from the integer value of a 'DayOfWeek' to some value --- of type @a@. You should construct a 'DayOfWeekMatch' with --- 'buildDayOfWeekMatch', and match it using 'caseDayOfWeek'. -newtype DayOfWeekMatch a = DayOfWeekMatch { getDayOfWeekMatch :: Vector a } - --- | Match a 'Month'. By `match`, we mean that a 'MonthMatch' is --- a mapping from the integer value of a 'Month' to some value of --- type @a@. You should construct a 'MonthMatch' with --- 'buildMonthMatch', and match it using 'caseMonth'. -newtype MonthMatch a = MonthMatch { getMonthMatch :: Vector a } - --- | Like 'MonthMatch', but the matched value can have an instance of --- 'UVector.Unbox'. -newtype UnboxedMonthMatch a = UnboxedMonthMatch { getUnboxedMonthMatch :: UVector.Vector a } - --- | A timespan. This is represented internally as a number --- of nanoseconds. -newtype Timespan = Timespan { getTimespan :: Int64 } - deriving (Show,Read,Eq,Ord,ToJSON,FromJSON,Additive) - -instance Semigroup Timespan where - (Timespan a) <> (Timespan b) = Timespan (a + b) - -instance Monoid Timespan where - mempty = Timespan 0 - mappend = (SG.<>) - -instance Torsor Time Timespan where - add (Timespan ts) (Time t) = Time (t + ts) - difference (Time t) (Time s) = Timespan (t - s) - -instance Scaling Timespan Int64 where - scale i (Timespan ts) = Timespan (i * ts) - -instance Torsor Offset Int where - add i (Offset x) = Offset (x + i) - difference (Offset x) (Offset y) = x - y - --- | The precision used when encoding seconds to a human-readable format. -data SubsecondPrecision - = SubsecondPrecisionAuto -- ^ Rounds to second, millisecond, microsecond, or nanosecond - | SubsecondPrecisionFixed {-# UNPACK #-} !Int -- ^ Specify number of places after decimal - deriving (Eq, Ord, Show, Read) - --- | A date as represented by the Gregorian calendar. -data Date = Date - { dateYear :: {-# UNPACK #-} !Year - , dateMonth :: {-# UNPACK #-} !Month - , dateDay :: {-# UNPACK #-} !DayOfMonth - } deriving (Show,Read,Eq,Ord) - --- | An 'OrdinalDate' is a 'Year' and the number of days elapsed --- since the 'Year' began. -data OrdinalDate = OrdinalDate - { ordinalDateYear :: {-# UNPACK #-} !Year - , ordinalDateDayOfYear :: {-# UNPACK #-} !DayOfYear - } deriving (Show,Read,Eq,Ord) - --- | A month and the day of the month. This does not actually represent --- a specific date, since this recurs every year. -data MonthDate = MonthDate - { monthDateMonth :: {-# UNPACK #-} !Month - , monthDateDay :: {-# UNPACK #-} !DayOfMonth - } deriving (Show,Read,Eq,Ord) - --- | A 'Date' as represented by the Gregorian calendar --- and a 'TimeOfDay'. -data Datetime = Datetime - { datetimeDate :: {-# UNPACK #-} !Date - , datetimeTime :: {-# UNPACK #-} !TimeOfDay - } deriving (Show,Read,Eq,Ord) - --- | A 'Datetime' with a time zone 'Offset'. -data OffsetDatetime = OffsetDatetime - { offsetDatetimeDatetime :: {-# UNPACK #-} !Datetime - , offsetDatetimeOffset :: {-# UNPACK #-} !Offset - } deriving (Show,Read,Eq,Ord) - --- | A time of day with nanosecond resolution. -data TimeOfDay = TimeOfDay - { timeOfDayHour :: {-# UNPACK #-} !Int - , timeOfDayMinute :: {-# UNPACK #-} !Int - , timeOfDayNanoseconds :: {-# UNPACK #-} !Int64 - } deriving (Show,Read,Eq,Ord) - --- | The format of a 'Datetime'. In particular --- this provides separators for parts of the 'Datetime' --- and nothing else. -data DatetimeFormat = DatetimeFormat - { datetimeFormatDateSeparator :: !(Maybe Char) - -- ^ Separator in the date - , datetimeFormatSeparator :: !(Maybe Char) - -- ^ Separator between date and time - , datetimeFormatTimeSeparator :: !(Maybe Char) - -- ^ Separator in the time - } deriving (Show,Read,Eq,Ord) - --- | Formatting settings for a timezone offset. -data OffsetFormat - = OffsetFormatColonOff -- ^ @%z@ (e.g., -0400) - | OffsetFormatColonOn -- ^ @%:z@ (e.g., -04:00) - | OffsetFormatSecondsPrecision -- ^ @%::z@ (e.g., -04:00:00) - | OffsetFormatColonAuto -- ^ @%:::z@ (e.g., -04, +05:30) - deriving (Show,Read,Eq,Ord,Enum,Bounded,Generic) - --- | Locale-specific formatting for weekdays and months. The --- type variable will likely be instantiated to @Text@ --- or @ByteString@. -data DatetimeLocale a = DatetimeLocale - { datetimeLocaleDaysOfWeekFull :: !(DayOfWeekMatch a) - -- ^ full weekdays starting with Sunday, 7 elements - , datetimeLocaleDaysOfWeekAbbreviated :: !(DayOfWeekMatch a) - -- ^ abbreviated weekdays starting with Sunday, 7 elements - , datetimeLocaleMonthsFull :: !(MonthMatch a) - -- ^ full months starting with January, 12 elements - , datetimeLocaleMonthsAbbreviated :: !(MonthMatch a) - -- ^ abbreviated months starting with January, 12 elements - } - --- | A TimeInterval represents a start and end time. --- It can sometimes be more ergonomic than the 'Torsor' API when --- you only care about whether or not a 'Time' is within a certain range. --- --- To construct a 'TimeInterval', it is best to use 'timeIntervalBuilder', --- which maintains the invariant that @'lowerBound' interval '<=' 'upperBound' interval@ --- (all functions that act on 'TimeInterval's assume this invariant). -data TimeInterval = TimeInterval {-# UNPACK #-} !Time {-# UNPACK #-} !Time - deriving (Read,Show,Eq,Ord,Bounded) - --- | Locale-specific formatting for AM and PM. -data MeridiemLocale a = MeridiemLocale - { meridiemLocaleAm :: !a - , meridiemLocalePm :: !a - } deriving (Read,Show,Eq,Ord) - -newtype instance UVector.MVector s Month = MV_Month (PVector.MVector s Month) -newtype instance UVector.Vector Month = V_Month (PVector.Vector Month) - -instance UVector.Unbox Month - -instance MGVector.MVector UVector.MVector Month where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicInitialize #-} - {-# INLINE basicUnsafeReplicate #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - {-# INLINE basicClear #-} - {-# INLINE basicSet #-} - {-# INLINE basicUnsafeCopy #-} - {-# INLINE basicUnsafeGrow #-} - basicLength (MV_Month v) = MGVector.basicLength v - basicUnsafeSlice i n (MV_Month v) = MV_Month $ MGVector.basicUnsafeSlice i n v - basicOverlaps (MV_Month v1) (MV_Month v2) = MGVector.basicOverlaps v1 v2 - basicUnsafeNew n = MV_Month `liftM` MGVector.basicUnsafeNew n - basicInitialize (MV_Month v) = MGVector.basicInitialize v - basicUnsafeReplicate n x = MV_Month `liftM` MGVector.basicUnsafeReplicate n x - basicUnsafeRead (MV_Month v) i = MGVector.basicUnsafeRead v i - basicUnsafeWrite (MV_Month v) i x = MGVector.basicUnsafeWrite v i x - basicClear (MV_Month v) = MGVector.basicClear v - basicSet (MV_Month v) x = MGVector.basicSet v x - basicUnsafeCopy (MV_Month v1) (MV_Month v2) = MGVector.basicUnsafeCopy v1 v2 - basicUnsafeMove (MV_Month v1) (MV_Month v2) = MGVector.basicUnsafeMove v1 v2 - basicUnsafeGrow (MV_Month v) n = MV_Month `liftM` MGVector.basicUnsafeGrow v n - -instance GVector.Vector UVector.Vector Month where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - {-# INLINE elemseq #-} - basicUnsafeFreeze (MV_Month v) = V_Month `liftM` GVector.basicUnsafeFreeze v - basicUnsafeThaw (V_Month v) = MV_Month `liftM` GVector.basicUnsafeThaw v - basicLength (V_Month v) = GVector.basicLength v - basicUnsafeSlice i n (V_Month v) = V_Month $ GVector.basicUnsafeSlice i n v - basicUnsafeIndexM (V_Month v) i = GVector.basicUnsafeIndexM v i - basicUnsafeCopy (MV_Month mv) (V_Month v) = GVector.basicUnsafeCopy mv v - elemseq _ = seq - -newtype instance UVector.MVector s DayOfMonth = MV_DayOfMonth (PVector.MVector s DayOfMonth) -newtype instance UVector.Vector DayOfMonth = V_DayOfMonth (PVector.Vector DayOfMonth) - -instance UVector.Unbox DayOfMonth - -instance MGVector.MVector UVector.MVector DayOfMonth where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicInitialize #-} - {-# INLINE basicUnsafeReplicate #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - {-# INLINE basicClear #-} - {-# INLINE basicSet #-} - {-# INLINE basicUnsafeCopy #-} - {-# INLINE basicUnsafeGrow #-} - basicLength (MV_DayOfMonth v) = MGVector.basicLength v - basicUnsafeSlice i n (MV_DayOfMonth v) = MV_DayOfMonth $ MGVector.basicUnsafeSlice i n v - basicOverlaps (MV_DayOfMonth v1) (MV_DayOfMonth v2) = MGVector.basicOverlaps v1 v2 - basicUnsafeNew n = MV_DayOfMonth `liftM` MGVector.basicUnsafeNew n - basicInitialize (MV_DayOfMonth v) = MGVector.basicInitialize v - basicUnsafeReplicate n x = MV_DayOfMonth `liftM` MGVector.basicUnsafeReplicate n x - basicUnsafeRead (MV_DayOfMonth v) i = MGVector.basicUnsafeRead v i - basicUnsafeWrite (MV_DayOfMonth v) i x = MGVector.basicUnsafeWrite v i x - basicClear (MV_DayOfMonth v) = MGVector.basicClear v - basicSet (MV_DayOfMonth v) x = MGVector.basicSet v x - basicUnsafeCopy (MV_DayOfMonth v1) (MV_DayOfMonth v2) = MGVector.basicUnsafeCopy v1 v2 - basicUnsafeMove (MV_DayOfMonth v1) (MV_DayOfMonth v2) = MGVector.basicUnsafeMove v1 v2 - basicUnsafeGrow (MV_DayOfMonth v) n = MV_DayOfMonth `liftM` MGVector.basicUnsafeGrow v n - -instance GVector.Vector UVector.Vector DayOfMonth where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - {-# INLINE elemseq #-} - basicUnsafeFreeze (MV_DayOfMonth v) = V_DayOfMonth `liftM` GVector.basicUnsafeFreeze v - basicUnsafeThaw (V_DayOfMonth v) = MV_DayOfMonth `liftM` GVector.basicUnsafeThaw v - basicLength (V_DayOfMonth v) = GVector.basicLength v - basicUnsafeSlice i n (V_DayOfMonth v) = V_DayOfMonth $ GVector.basicUnsafeSlice i n v - basicUnsafeIndexM (V_DayOfMonth v) i = GVector.basicUnsafeIndexM v i - basicUnsafeCopy (MV_DayOfMonth mv) (V_DayOfMonth v) = GVector.basicUnsafeCopy mv v - elemseq _ = seq - ------------------------- --- The Torsor and Enum instances for Date and OrdinalDate --- are both bad. This only causes problems for dates --- at least a million years in the future. Some of this --- badness is caused by pragmatism, and some of it is caused by --- my own laziness. --- --- The badness that comes from pragmatism: --- - Int technically is not a good delta for Date. Date --- has too many inhabitants. If we subtract the lowest --- Date from the highest Date, we get something too --- big to fit in a machine integer. --- - There is no good way to write fromEnum or toEnum for --- Date. Again, Date has more inhabitants than Int, so --- it simply cannot be done. --- The badness that comes from laziness: --- - Technically, we should still be able to add deltas to --- Dates that do not fit in machine integers. We should --- also be able to correctly subtract Dates to cannot --- fit in machine integers. --- - For similar reasons, the Enum functions succ, pred, --- enumFromThen, enumFromThenTo, etc. could all have --- better definitions than the default ones currently --- used. --- If, for some reason, anyone ever wants to fix the badness --- that comes from laziness, all --- you really have to do is define a version of dateToDay, --- dayToDate, ordinalDateToDay, and dayToOrdinalDate --- that uses something bigger instead of Day. Maybe something like --- (Int,Word) or (Int,Word,Word). I'm not exactly sure how --- big it would need to be to work correctly. Then you could --- handle deltas of two very far off days correctly, provided --- that the two days weren't also super far from each other. --- ------------------------- -instance Torsor Date Int where - add i d = dayToDate (add i (dateToDay d)) - difference a b = difference (dateToDay a) (dateToDay b) - -instance Torsor OrdinalDate Int where - add i d = dayToOrdinalDate (add i (ordinalDateToDay d)) - difference a b = difference (ordinalDateToDay a) (ordinalDateToDay b) - -instance Enum Date where - fromEnum d = fromEnum (dateToDay d) - toEnum i = dayToDate (toEnum i) - -instance Enum OrdinalDate where - fromEnum d = fromEnum (ordinalDateToDay d) - toEnum i = dayToOrdinalDate (toEnum i) - -instance ToJSON Datetime where - toJSON = AE.String . encode_YmdHMS SubsecondPrecisionAuto hyphen - toEncoding x = AEE.unsafeToEncoding (BB.char7 '"' SG.<> builderUtf8_YmdHMS SubsecondPrecisionAuto hyphen x SG.<> BB.char7 '"') - -instance ToJSON Offset where - toJSON = AE.String . encodeOffset OffsetFormatColonOn - toEncoding x = AEE.unsafeToEncoding (BB.char7 '"' SG.<> builderOffsetUtf8 OffsetFormatColonOn x SG.<> BB.char7 '"') - -instance FromJSON Offset where - parseJSON = AE.withText "Offset" aesonParserOffset - -instance ToJSONKey Offset where - toJSONKey = AE.ToJSONKeyText - (encodeOffset OffsetFormatColonOn) - (\x -> AEE.unsafeToEncoding (BB.char7 '"' SG.<> builderOffsetUtf8 OffsetFormatColonOn x SG.<> BB.char7 '"')) - -instance FromJSONKey Offset where - fromJSONKey = AE.FromJSONKeyTextParser aesonParserOffset - -aesonParserOffset :: Text -> AET.Parser Offset -aesonParserOffset t = case decodeOffset OffsetFormatColonOn t of - Nothing -> fail "could not parse Offset" - Just x -> pure x - --- | Holds all of the parts encoded by a 'Time'. --- Can be used for formatting if what is presently in the API --- does not suffice. -data TimeParts = TimeParts - { timePartsDay :: !Int -- ^ days 0-31 - , timePartsMonth :: !Int -- ^ months 0-11 - , timePartsYear :: !Int - , timePartsHour :: !Int -- ^ hours 0-23 - , timePartsMinute :: !Int -- ^ minutes 0-59 - , timePartsSecond :: !Int -- ^ seconds 0-59 - , timePartsSubsecond :: !Int -- ^ fraction of a second with nanosecond resolution - , timePartsOffset :: !Int - } - deriving (Eq, Read, Show) - --- | Deconstruct a 'Time' into its 'TimeParts'. -timeParts :: Offset -> Time -> TimeParts -timeParts o0 t0 = - let - OffsetDatetime (Datetime dt t) o = timeToOffsetDatetime o0 t0 - Date y mo d = dt - TimeOfDay h mi s = t - (wholeSeconds, subsecond) = divMod s 100000000 - in TimeParts - { timePartsDay = fromIntegral (getDayOfMonth d) - , timePartsMonth = fromIntegral (getMonth mo) - , timePartsYear = fromIntegral (getYear y) - , timePartsHour = h - , timePartsMinute = mi - , timePartsSecond = fromIntegral wholeSeconds - , timePartsSubsecond = fromIntegral subsecond - , timePartsOffset = getOffset o - } +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +{- | Chronos is a performance-oriented time library for Haskell, with a + straightforward API. The main differences between this + and the library + are: + + * Chronos uses machine integers where possible. This means + that time-related arithmetic should be faster, with the + drawback that the types are incapable of representing times + that are very far in the future or the past (because Chronos + provides nanosecond, rather than picosecond, resolution). + For most users, this is not a hindrance. + * Chronos provides 'ToJSON'/'FromJSON' instances for serialisation. + * Chronos provides 'UVector.Unbox' instances for working with unboxed vectors. + * Chronos provides 'Prim' instances for working with byte arrays/primitive arrays. + * Chronos uses normal non-overloaded haskell functions for + encoding and decoding time. It provides parsers for both 'Text' and + 'ByteString'. Additionally, Chronos provides functions for + encoding time to 'Text' or 'ByteString'. The library accomplishes these with the + module, which uses UNIX-style datetime + format strings. The approach taken by Chronos is faster and + catches more mistakes at compile time, at the cost of being + less expressive. +-} +module Chronos + ( -- * Functions + + -- ** Current + now + , today + , tomorrow + , yesterday + , todayDayOfWeek + , yesterdayDayOfWeek + , tomorrowDayOfWeek + , timeToDayOfWeek + , epoch + + -- ** Duration + , stopwatch + , stopwatch_ + + -- ** Construction + , datetimeFromYmdhms + , timeFromYmdhms + + -- ** Conversion + , timeToDatetime + , datetimeToTime + , datetimeToDayOfWeek + , dateToDayOfWeek + , timeToOffsetDatetime + , offsetDatetimeToTime + , timeToDayTruncate + , dayToTimeMidnight + , dayToDate + , dateToDay + , dayToOrdinalDate + , ordinalDateToDay + , monthDateToDayOfYear + , dayOfYearToMonthDay + + -- ** Build Timespan + , second + , minute + , hour + , day + , week + + -- ** Matching + , buildDayOfWeekMatch + , buildMonthMatch + , buildUnboxedMonthMatch + , caseDayOfWeek + , caseMonth + , caseUnboxedMonth + + -- ** Format + -- $format + , w3c + , slash + , hyphen + , compact + , timeParts + + -- ** Months + , january + , february + , march + , april + , may + , june + , july + , august + , september + , october + , november + , december + + -- ** Days of Week + , sunday + , monday + , tuesday + , wednesday + , thursday + , friday + , saturday + + -- ** Utility + , daysInMonth + , isLeapYear + , observedOffsets + , sinceEpoch + , asSeconds + + -- * Textual Conversion + + -- ** Date + + -- *** Text + , builder_Ymd + , builder_Dmy + , builder_HMS + , parser_Ymd + , parser_Ymd_lenient + , parser_Mdy + , parser_Mdy_lenient + , parser_Dmy + , parser_Dmy_lenient + + -- *** UTF-8 ByteString + , builderUtf8_Ymd + , parserUtf8_Ymd + + -- ** Time of Day + + -- *** Text + , builder_IMS_p + , builder_IMSp + , parser_HMS + , parser_HMS_opt_S + + -- *** UTF-8 ByteString + , builderUtf8_HMS + , builderUtf8_IMS_p + , builderUtf8_IMSp + , parserUtf8_HMS + , parserUtf8_HMS_opt_S + , zeptoUtf8_HMS + + -- ** Datetime + + -- *** Text + , builder_DmyHMS + , builder_DmyIMSp + , builder_DmyIMS_p + , builder_YmdHMS + , builder_YmdIMSp + , builder_YmdIMS_p + , builderW3C + , builderIso8601 + , encodeIso8601 + , encode_Ymd + , encode_Dmy + , encode_DmyHMS + , encode_DmyIMS_p + , encode_YmdHMS + , encode_YmdIMS_p + , parser_DmyHMS + , parser_DmyHMS_lenient + , parser_YmdHMS + , parser_YmdHMS_lenient + , parser_YmdHMS_opt_S + , parser_YmdHMS_opt_S_lenient + , parser_DmyHMS_opt_S + , parser_DmyHMS_opt_S_lenient + , parser_MdyHMS + , parser_MdyHMS_lenient + , parser_MdyHMS_opt_S + , parser_MdyHMS_opt_S_lenient + , parser_lenient + , decode_DmyHMS + , decode_DmyHMS_lenient + , decode_MdyHMS + , decode_MdyHMS_lenient + , decode_MdyHMS_opt_S + , decode_MdyHMS_opt_S_lenient + , decode_YmdHMS + , decode_YmdHMS_lenient + , decode_YmdHMS_opt_S + , decode_YmdHMS_opt_S_lenient + , decode_DmyHMS_opt_S + , decode_DmyHMS_opt_S_lenient + , decode_lenient + , decodeIso8601Zulu + + -- *** UTF-8 ByteString + , encodeUtf8_YmdHMS + , encodeUtf8_YmdIMS_p + , builderUtf8_YmdHMS + , builderUtf8_YmdIMSp + , builderUtf8_YmdIMS_p + , builderUtf8W3C + , decodeUtf8_YmdHMS + , decodeUtf8_YmdHMS_opt_S + , parserUtf8_YmdHMS + , parserUtf8_YmdHMS_opt_S + , zeptoUtf8_YmdHMS + + -- *** UTF-8 Bytes + , boundedBuilderUtf8BytesIso8601Zoneless + , decodeUtf8BytesIso8601Zoneless + , decodeUtf8BytesIso8601ZonelessSpaced + + -- *** Short Text + , decodeShortTextIso8601Zulu + , decodeShortTextIso8601Zoneless + , encodeShortTextIso8601Zulu + , encodeShortTextIso8601Zoneless + + -- ** Offset Datetime + + -- *** Text + , encode_YmdHMSz + , encode_DmyHMSz + , builder_YmdHMSz + , builder_DmyHMSz + , parser_YmdHMSz + , parser_DmyHMSz + , builder_YmdIMS_p_z + , builder_DmyIMS_p_z + , builderW3Cz + + -- *** UTF-8 ByteString + , builderUtf8_YmdHMSz + , parserUtf8_YmdHMSz + , builderUtf8_YmdIMS_p_z + , builderUtf8W3Cz + + -- *** UTF-8 Bytes + , parserUtf8BytesIso8601 + , boundedBuilderUtf8BytesIso8601 + , decodeUtf8BytesIso8601 + + -- *** ShortText + , decodeShortTextIso8601 + , encodeShortTextIso8601 + + -- ** Offset + + -- *** Text + , encodeOffset + , builderOffset + , decodeOffset + , parserOffset + + -- *** UTF-8 ByteString + , encodeOffsetUtf8 + , builderOffsetUtf8 + , decodeOffsetUtf8 + , parserOffsetUtf8 + + -- ** Timespan + + -- *** Text + , encodeTimespan + , builderTimespan + + -- *** UTF-8 ByteString + , encodeTimespanUtf8 + , builderTimespanUtf8 + + -- ** TimeInterval + , within + , timeIntervalToTimespan + , whole + , singleton + , lowerBound + , upperBound + , width + , timeIntervalBuilder + , (...) + + -- * Types + , Day (..) + , DayOfWeek (..) + , DayOfMonth (..) + , DayOfYear (..) + , Month (..) + , Year (..) + , Offset (..) + , Time (..) + , DayOfWeekMatch (..) + , MonthMatch (..) + , UnboxedMonthMatch (..) + , Timespan (..) + , SubsecondPrecision (..) + , Date (..) + , OrdinalDate (..) + , MonthDate (..) + , Datetime (..) + , OffsetDatetime (..) + , TimeOfDay (..) + , DatetimeFormat (..) + , OffsetFormat (..) + , DatetimeLocale (..) + , MeridiemLocale (..) + , TimeInterval (..) + , TimeParts (..) + + -- * Lenses + , _timeToDatetime + , _datetimeToTime + , _dayToDate + , _dateToDay + , _getDay + , _getDayOfWeek + , _getDayOfMonth + , _getDayOfYear + , _getMonth + , _getOffset + , _getTime + , _getTimespan + , _dateYear + , _dateMonth + , _dateDay + , _ordinalDateYear + , _ordinalDateDayOfYear + , _monthDateMonth + , _monthDateDay + , _datetimeDate + , _datetimeTime + , _offsetDatetimeDatetime + , _offsetDatetimeOffset + , _timeOfDayHour + , _timeOfDayMinute + , _timeOfDayNanoseconds + ) where + +import Control.Applicative +import Control.DeepSeq (NFData (..), deepseq) +import Control.Exception (evaluate) +import Control.Monad +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.Attoparsec.Text (Parser) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.Bytes (Bytes) +import Data.Char (isDigit) +import Data.Foldable +import Data.Hashable (Hashable) +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.Key as AK +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.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.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.Bytes.Text.Utf8 as Utf8 +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 + +#ifdef mingw32_HOST_OS +import System.Win32.Time (SYSTEMTIME(..)) +import qualified System.Win32.Time as W32 +#else +import Chronos.Internal.CTimespec (getPosixNanoseconds) +#endif + +{- $setup +>>> import Test.QuickCheck hiding (within) +>>> import Test.QuickCheck.Gen +>>> import Data.Maybe (isJust) +>>> :set -XStandaloneDeriving +>>> :set -XGeneralizedNewtypeDeriving +>>> :set -XScopedTypeVariables + +>>> deriving instance Arbitrary Time +>>> :{ + instance Arbitrary TimeInterval where + arbitrary = do + t0 <- arbitrary + t1 <- suchThat arbitrary (>= t0) + pure (TimeInterval t0 t1) + instance Arbitrary TimeOfDay where + arbitrary = TimeOfDay + <$> choose (0,23) + <*> choose (0,59) + <*> choose (0, 60000000000 - 1) + instance Arbitrary Date where + arbitrary = Date + <$> fmap Year (choose (1800,2100)) + <*> fmap Month (choose (0,11)) + <*> fmap DayOfMonth (choose (1,28)) + instance Arbitrary Datetime where + arbitrary = Datetime <$> arbitrary <*> arbitrary + instance Arbitrary OffsetDatetime where + arbitrary = OffsetDatetime <$> arbitrary <*> arbitrary + instance Arbitrary DatetimeFormat where + arbitrary = DatetimeFormat + <$> arbitrary + <*> elements [ Nothing, Just '/', Just ':', Just '-'] + <*> arbitrary + instance Arbitrary OffsetFormat where + arbitrary = arbitraryBoundedEnum + shrink = genericShrink + instance Arbitrary Offset where + arbitrary = fmap Offset (choose ((-24) * 60, 24 * 60)) + instance Arbitrary SubsecondPrecision where + arbitrary = frequency + [ (1, pure SubsecondPrecisionAuto) + , (1, SubsecondPrecisionFixed <$> choose (0,9)) + ] + instance Arbitrary Day where + arbitrary = fmap Day (choose (0,50000)) +:} +-} + +-- | A 'Timespan' representing a single second. +second :: Timespan +second = Timespan 1000000000 + +-- | A 'Timespan' representing a single minute. +minute :: Timespan +minute = Timespan 60000000000 + +-- | A 'Timespan' representing a single hour. +hour :: Timespan +hour = Timespan 3600000000000 + +-- | A 'Timespan' representing a single day. +day :: Timespan +day = Timespan 86400000000000 + +-- | A 'Timespan' representing a single week. +week :: Timespan +week = Timespan 604800000000000 + +{- | Convert 'Time' to 'Datetime'. + + prop> \(t :: Time) -> (datetimeToTime (timeToDatetime t)) == t +-} +timeToDatetime :: Time -> Datetime +timeToDatetime = utcTimeToDatetime . toUtc + +{- | Convert 'Datetime' to 'Time'. + + prop> \(d :: Datetime) -> timeToDatetime (datetimeToTime d) == d +-} +datetimeToTime :: Datetime -> Time +datetimeToTime = fromUtc . datetimeToUtcTime + +{- | A lens-compatible variant of half of the `timeToDatetime`/`datetimeToTime` isomorphism. + +__Note__: We do not provide an iso as that requires a dependence on the `profunctor` +package. +-} +_timeToDatetime :: forall f. (Functor f) => (Datetime -> f Datetime) -> Time -> f Time +_timeToDatetime f = fmap datetimeToTime . f . timeToDatetime + +{- | A lens-compatible variant of half of the `timeToDatetime`/`datetimeToTime` isomorphism. + +__Note__: We do not provide an iso as that requires a dependence on the `profunctor` +package. +-} +_datetimeToTime :: forall f. (Functor f) => (Time -> f Time) -> Datetime -> f Datetime +_datetimeToTime f = fmap timeToDatetime . f . datetimeToTime + +-- | Convert 'Datetime' to 'DayOfWeek' +datetimeToDayOfWeek :: Datetime -> DayOfWeek +datetimeToDayOfWeek (Datetime date _) = dateToDayOfWeek date + +-- | Convert 'Date' to 'DayOfWeek' +dateToDayOfWeek :: Date -> DayOfWeek +dateToDayOfWeek (Date year month date) = + let k = getDayOfMonth date + m = ((getMonth month + 10) `mod` 12) + 1 + y = adjustedYear `mod` 100 + c = adjustedYear `div` 100 + adjustedYear = if m >= 11 then getYear year - 1 else getYear year + in DayOfWeek $ (k + (floor $ ((2.6 :: Double) * fromIntegral m) - 0.2) - (2 * c) + y + (y `div` 4) + (c `div` 4)) `mod` 7 + +-- | Convert 'Time' to 'OffsetDatetime' by providing an 'Offset'. +timeToOffsetDatetime :: Offset -> Time -> OffsetDatetime +timeToOffsetDatetime offset = utcTimeToOffsetDatetime offset . toUtc + +-- | Convert 'OffsetDatetime' to 'Time'. +offsetDatetimeToTime :: OffsetDatetime -> Time +offsetDatetimeToTime = fromUtc . offsetDatetimeToUtcTime + +{- | Convert 'Time' to 'Day'. This function is lossy; consequently, it + does not roundtrip with 'dayToTimeMidnight'. +-} +timeToDayTruncate :: Time -> Day +timeToDayTruncate (Time i) = Day (fromIntegral (div i 86400000000000) + 40587) + +-- | Convert midnight of the given 'Day' to 'Time'. +dayToTimeMidnight :: Day -> Time +dayToTimeMidnight (Day d) = Time (fromIntegral (d - 40587) * 86400000000000) + +{- | Convert 'Day' to a 'Date'. + + prop> \(d :: Day) -> dateToDay (dayToDate d) == d +-} +dayToDate :: Day -> Date +dayToDate theDay = Date year month dayOfMonth + where + OrdinalDate year yd = dayToOrdinalDate theDay + MonthDate month dayOfMonth = dayOfYearToMonthDay (isLeapYear year) yd + +{- | Convert a 'Date' to a 'Day'. + + prop> \(d :: Date) -> dayToDate (dateToDay d) == d +-} +dateToDay :: Date -> Day +dateToDay (Date y m d) = + ordinalDateToDay $ + OrdinalDate + y + (monthDateToDayOfYear (isLeapYear y) (MonthDate m d)) + +{- | A lens-compatible variant of half of the `dayToDate`/`dateToDay` isomorphism. + +__Note__: We do not provide an iso as that requires a dependence on the `profunctor` +package. +-} +_dayToDate :: forall f. (Functor f) => (Date -> f Date) -> Day -> f Day +_dayToDate f = fmap dateToDay . f . dayToDate + +{- | A lens-compatible variant of half of the `dayToDate`/`dateToDay` isomorphism. + +__Note__: We do not provide an iso as that requires a dependence on the `profunctor` +package. +-} +_dateToDay :: forall f. (Functor f) => (Day -> f Day) -> Date -> f Date +_dateToDay f = fmap dayToDate . f . dateToDay + +{- | Construct a 'Datetime' from year, month, day, hour, minute, second: + + >>> datetimeFromYmdhms 2014 2 26 17 58 52 + Datetime {datetimeDate = Date {dateYear = Year {getYear = 2014}, dateMonth = Month {getMonth = 1}, dateDay = DayOfMonth {getDayOfMonth = 26}}, datetimeTime = TimeOfDay {timeOfDayHour = 17, timeOfDayMinute = 58, timeOfDayNanoseconds = 52000000000}} +-} +datetimeFromYmdhms :: + -- | Year + Int -> + -- | Month + Int -> + -- | Day + Int -> + -- | Hour + Int -> + -- | Minute + Int -> + -- | Second + Int -> + Datetime +datetimeFromYmdhms y m d h m' s = + Datetime + ( Date + (Year $ fromIntegral y) + (Month mx) + (DayOfMonth $ fromIntegral d) + ) + ( TimeOfDay + (fromIntegral h) + (fromIntegral m') + (fromIntegral s * 1000000000) + ) + where + mx = + if m >= 1 && m <= 12 + then fromIntegral (m - 1) + else 0 + +{- | Construct a 'Time' from year, month, day, hour, minute, second: + + >>> timeFromYmdhms 2014 2 26 17 58 52 + Time {getTime = 1393437532000000000} +-} +timeFromYmdhms :: + -- | Year + Int -> + -- | Month + Int -> + -- | Day + Int -> + -- | Hour + Int -> + -- | Minute + Int -> + -- | Second + Int -> + Time +timeFromYmdhms y m d h m' s = datetimeToTime (datetimeFromYmdhms y m d h m' s) + +{- | Gets the current 'Day'. This does not take the user\'s + time zone into account. +-} +today :: IO Day +today = fmap timeToDayTruncate now + +-- | Gets the 'Day' of tomorrow. +tomorrow :: IO Day +tomorrow = fmap (add 1 . timeToDayTruncate) now + +-- | Gets the 'Day' of yesterday. +yesterday :: IO Day +yesterday = fmap (add (-1) . timeToDayTruncate) now + +-- | Get the current time from the system clock. +now :: IO Time +#ifdef mingw32_HOST_OS +now = do + SYSTEMTIME{..} <- W32.getSystemTime + let date = Date + { dateYear = Year (fromIntegral wYear) + , dateMonth = Month (fromIntegral wMonth - 1) + , dateDay = DayOfMonth (fromIntegral wDay) + } + let secNano = (fromIntegral wSecond :: Int64) * 1000000000 + msNano = (fromIntegral wMilliseconds :: Int64) * 1000000 + nano = secNano + msNano + let time = TimeOfDay + { timeOfDayHour = fromIntegral wHour + , timeOfDayMinute = fromIntegral wMinute + , timeOfDayNanoseconds = fromIntegral nano + } + let dt = Datetime date time + pure $ datetimeToTime dt +#else +now = fmap Time getPosixNanoseconds +#endif + +-- | Convert from 'Time' to 'DayOfWeek'. +timeToDayOfWeek :: Time -> DayOfWeek +timeToDayOfWeek (Time time) = + DayOfWeek $ + (fromIntegral @Int64 @Int ((time `div` 86400000000000) + 4) `mod` 7) + +-- | Get the current 'DayOfWeek' from the system clock. +todayDayOfWeek :: IO DayOfWeek +todayDayOfWeek = timeToDayOfWeek <$> now + +-- | Get the yesterday\'s 'DayOfWeek' from the system clock. +yesterdayDayOfWeek :: IO DayOfWeek +yesterdayDayOfWeek = + timeToDayOfWeek . (add (Timespan (-86400000000000))) <$> now + +-- | Get the tomorrow\'s 'DayOfWeek' from the system clock. +tomorrowDayOfWeek :: IO DayOfWeek +tomorrowDayOfWeek = + timeToDayOfWeek . (add (Timespan (86400000000000))) <$> now + +-- | The Unix epoch, that is 1970-01-01 00:00:00. +epoch :: Time +epoch = Time 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. +-} +stopwatch :: IO a -> IO (Timespan, a) +stopwatch action = do + start <- getMonotonicTimeNSec + a <- action >>= evaluate + end <- getMonotonicTimeNSec + pure ((Timespan (fromIntegral (end - start))), a) + +{- | 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_ action = do + start <- getMonotonicTimeNSec + _ <- action + end <- getMonotonicTimeNSec + pure (Timespan (fromIntegral (end - start))) + +-- UtcTime. Used internally only. +data UtcTime + = UtcTime + {-# UNPACK #-} !Day -- day + {-# UNPACK #-} !Int64 -- nanoseconds + +toUtc :: Time -> UtcTime +toUtc (Time i) = + let (d, t) = divMod i (getTimespan day) + in UtcTime (add (fromIntegral d) epochDay) (fromIntegral t) + +fromUtc :: UtcTime -> Time +fromUtc (UtcTime d ns') = + Time $ + getTimespan $ + plus + (scale (intToInt64 (difference d epochDay)) day) + (if ns > day then day else ns) + where + ns = Timespan ns' + +intToInt64 :: Int -> Int64 +intToInt64 = fromIntegral + +epochDay :: Day +epochDay = Day 40587 + +dayLengthInt64 :: Int64 +dayLengthInt64 = getTimespan day + +nanosecondsInMinute :: Int64 +nanosecondsInMinute = 60000000000 + +-- | All UTC time offsets. See . +observedOffsets :: Vector Offset +observedOffsets = + Vector.fromList $ + map + Offset + [ -1200 + , -1100 + , -1000 + , -930 + , -900 + , -800 + , -700 + , -600 + , -500 + , -400 + , -330 + , -300 + , -230 + , -200 + , -100 + , 0 + , 100 + , 200 + , 300 + , 330 + , 400 + , 430 + , 500 + , 530 + , 545 + , 600 + , 630 + , 700 + , 800 + , 845 + , 900 + , 930 + , 1000 + , 1030 + , 1100 + , 1200 + , 1245 + , 1300 + , 1345 + , 1400 + ] + +{- | Compute the 'Timespan' between the given date and 'epoch'. + +@since 1.1.6.0 +-} +sinceEpoch :: Time -> Timespan +sinceEpoch t = difference t epoch + +{- | Convert a 'Timespan' to its equivalent in seconds. + +@since 1.1.6.0 +-} +asSeconds :: Timespan -> Int64 +asSeconds (Timespan t) = case second of + Timespan s -> t `div` s + +{- | The first argument in the resulting tuple in a day + adjustment. It should be either -1, 0, or 1, as no + offset should ever exceed 24 hours. +-} +offsetTimeOfDay :: Offset -> TimeOfDay -> (Int, TimeOfDay) +offsetTimeOfDay (Offset offset) (TimeOfDay h m s) = + (dayAdjustment, TimeOfDay h'' m'' s) + where + (!dayAdjustment, !h'') = divMod h' 24 + (!hourAdjustment, !m'') = divMod m' 60 + m' = m + offset + h' = h + hourAdjustment + +nanosecondsSinceMidnightToTimeOfDay :: Int64 -> TimeOfDay +nanosecondsSinceMidnightToTimeOfDay ns = + if ns >= dayLengthInt64 + then TimeOfDay 23 59 (nanosecondsInMinute + (ns - dayLengthInt64)) + else TimeOfDay h' m' ns' + where + (!mInt64, !ns') = quotRem ns nanosecondsInMinute + !m = fromIntegral mInt64 + (!h', !m') = quotRem m 60 + +timeOfDayToNanosecondsSinceMidnight :: TimeOfDay -> Int64 +timeOfDayToNanosecondsSinceMidnight (TimeOfDay h m ns) = + fromIntegral h * 3600000000000 + fromIntegral m * 60000000000 + ns + +-- datetimeToOffsetDatetime :: Offset -> Datetime -> OffsetDatetime +-- datetimeToOffsetDatetime offset + +utcTimeToOffsetDatetime :: Offset -> UtcTime -> OffsetDatetime +utcTimeToOffsetDatetime offset (UtcTime (Day d) nanoseconds) = + let (!dayAdjustment, !tod) = offsetTimeOfDay offset (nanosecondsSinceMidnightToTimeOfDay nanoseconds) + !date = dayToDate (Day (d + dayAdjustment)) + in OffsetDatetime (Datetime date tod) offset + +utcTimeToDatetime :: UtcTime -> Datetime +utcTimeToDatetime (UtcTime d nanoseconds) = + let !tod = nanosecondsSinceMidnightToTimeOfDay nanoseconds + !date = dayToDate d + in Datetime date tod + +datetimeToUtcTime :: Datetime -> UtcTime +datetimeToUtcTime (Datetime date timeOfDay) = + UtcTime (dateToDay date) (timeOfDayToNanosecondsSinceMidnight timeOfDay) + +offsetDatetimeToUtcTime :: OffsetDatetime -> UtcTime +offsetDatetimeToUtcTime (OffsetDatetime (Datetime date timeOfDay) (Offset off)) = + let (!dayAdjustment, !tod) = offsetTimeOfDay (Offset $ negate off) timeOfDay + !(Day !theDay) = dateToDay date + in UtcTime + (Day (theDay + dayAdjustment)) + (timeOfDayToNanosecondsSinceMidnight tod) + +-- | Convert a 'MonthDate' to a 'DayOfYear'. +monthDateToDayOfYear :: + -- | Is it a leap year? + Bool -> + MonthDate -> + DayOfYear +monthDateToDayOfYear isLeap (MonthDate month@(Month m) (DayOfMonth dayOfMonth)) = + DayOfYear ((div (367 * (fromIntegral m + 1) - 362) 12) + k + day') + where + day' = fromIntegral $ clip 1 (daysInMonth isLeap month) dayOfMonth + k = if month < Month 2 then 0 else if isLeap then -1 else -2 + +-- | Convert an 'OrdinalDate' to a 'Day'. +ordinalDateToDay :: OrdinalDate -> Day +ordinalDateToDay (OrdinalDate year@(Year y') theDay) = Day mjd + where + y = y' - 1 + mjd = + ( fromIntegral . getDayOfYear $ + (clip (DayOfYear 1) (if isLeapYear year then DayOfYear 366 else DayOfYear 365) theDay) + ) + + (365 * y) + + (div y 4) + - (div y 100) + + (div y 400) + - 678576 + +{- | Is the 'Year' a leap year? + + >>> isLeapYear (Year 1996) + True + + >>> isLeapYear (Year 2019) + False +-} +isLeapYear :: Year -> Bool +isLeapYear (Year year) = (mod year 4 == 0) && ((mod year 400 == 0) || not (mod year 100 == 0)) + +-- | Convert a 'DayOfYear' to a 'MonthDate'. +dayOfYearToMonthDay :: + -- | Is it a leap year? + Bool -> + DayOfYear -> + MonthDate +dayOfYearToMonthDay isLeap dayOfYear = + let (!doyUpperBound, !monthTable, !dayTable) = + if isLeap + then (DayOfYear 366, leapYearDayOfYearMonthTable, leapYearDayOfYearDayOfMonthTable) + else (DayOfYear 365, normalYearDayOfYearMonthTable, normalYearDayOfYearDayOfMonthTable) + DayOfYear clippedDay = clip (DayOfYear 1) doyUpperBound dayOfYear + clippedDayInt = fromIntegral clippedDay :: Int + month = UVector.unsafeIndex monthTable clippedDayInt + theDay = UVector.unsafeIndex dayTable clippedDayInt + in MonthDate month theDay + +-- | Convert a 'Day' to an 'OrdinalDate'. +dayToOrdinalDate :: Day -> OrdinalDate +dayToOrdinalDate (Day mjd) = OrdinalDate (Year $ fromIntegral year) (DayOfYear $ fromIntegral yd) + where + a = (fromIntegral mjd :: Int64) + 678575 + quadcent = div a 146097 + b = mod a 146097 + cent = min (div b 36524) 3 + c = b - (cent * 36524) + quad = div c 1461 + d = mod c 1461 + y = min (div d 365) 3 + yd = (d - (y * 365) + 1) + year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 + +{- $format + +The formats provided is this module are language-agnostic. +To find meridiem formats and month formats, look in a +language-specific module. +-} + +{- | The W3C 'DatetimeFormat'. + + >>> encode_YmdHMS SubsecondPrecisionAuto w3c (timeToDatetime (timeFromYmdhms 2014 2 26 17 58 52)) + "2014-02-26T17:58:52" + + prop> \(s :: SubsecondPrecision) (dt :: Datetime) -> isJust (decode_YmdHMS w3c (encode_YmdHMS s w3c dt)) +-} +w3c :: DatetimeFormat +w3c = DatetimeFormat (Just '-') (Just 'T') (Just ':') + +{- | A 'DatetimeFormat' that separates the members of + the 'Date' by slashes. + + >>> encode_YmdHMS SubsecondPrecisionAuto slash (timeToDatetime (timeFromYmdhms 2014 2 26 17 58 52)) + "2014/02/26 17:58:52" + + prop> \(s :: SubsecondPrecision) (dt :: Datetime) -> isJust (decode_YmdHMS slash (encode_YmdHMS s slash dt)) +-} +slash :: DatetimeFormat +slash = DatetimeFormat (Just '/') (Just ' ') (Just ':') + +{- | A 'DatetimeFormat' that separates the members of + the 'Date' by hyphens. + + >>> encode_YmdHMS SubsecondPrecisionAuto hyphen (timeToDatetime (timeFromYmdhms 2014 2 26 17 58 52)) + "2014-02-26 17:58:52" + + prop> \(s :: SubsecondPrecision) (dt :: Datetime) -> isJust (decode_YmdHMS hyphen (encode_YmdHMS s hyphen dt)) +-} +hyphen :: DatetimeFormat +hyphen = DatetimeFormat (Just '-') (Just ' ') (Just ':') + +{- | A 'DatetimeFormat' with no separators, except for a + `T` between the 'Date' and 'Time'. + + >>> encode_YmdHMS SubsecondPrecisionAuto compact (timeToDatetime (timeFromYmdhms 2014 2 26 17 58 52)) + "20140226T175852" + + prop> \(s :: SubsecondPrecision) (dt :: Datetime) -> isJust (decode_YmdHMS compact (encode_YmdHMS s compact dt)) +-} +compact :: DatetimeFormat +compact = DatetimeFormat Nothing (Just 'T') Nothing + +-- | Return the number of days in a given month. +daysInMonth :: + -- | Is this a leap year? + Bool -> + -- | Month of year + Month -> + Int +daysInMonth isLeap m = + if isLeap + then caseMonth leapYearMonthLength m + else caseMonth normalYearMonthLength m + +leapYearMonthLength :: MonthMatch Int +leapYearMonthLength = buildMonthMatch 31 29 31 30 31 30 31 31 30 31 30 31 + +normalYearMonthLength :: MonthMatch Int +normalYearMonthLength = buildMonthMatch 31 28 31 30 31 30 31 31 30 31 30 31 + +leapYearDayOfYearDayOfMonthTable :: UVector.Vector DayOfMonth +leapYearDayOfYearDayOfMonthTable = + UVector.fromList $ + (DayOfMonth 1 :) $ + concat + [ enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 29) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 30) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 30) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 30) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 30) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + ] +{-# NOINLINE leapYearDayOfYearDayOfMonthTable #-} + +normalYearDayOfYearDayOfMonthTable :: UVector.Vector DayOfMonth +normalYearDayOfYearDayOfMonthTable = + UVector.fromList $ + (DayOfMonth 1 :) $ + concat + [ enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 28) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 30) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 30) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 30) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + , enumFromTo (DayOfMonth 1) (DayOfMonth 30) + , enumFromTo (DayOfMonth 1) (DayOfMonth 31) + ] +{-# NOINLINE normalYearDayOfYearDayOfMonthTable #-} + +leapYearDayOfYearMonthTable :: UVector.Vector Month +leapYearDayOfYearMonthTable = + UVector.fromList $ + (Month 0 :) $ + concat + [ replicate 31 (Month 0) + , replicate 29 (Month 1) + , replicate 31 (Month 2) + , replicate 30 (Month 3) + , replicate 31 (Month 4) + , replicate 30 (Month 5) + , replicate 31 (Month 6) + , replicate 31 (Month 7) + , replicate 30 (Month 8) + , replicate 31 (Month 9) + , replicate 30 (Month 10) + , replicate 31 (Month 11) + ] +{-# NOINLINE leapYearDayOfYearMonthTable #-} + +normalYearDayOfYearMonthTable :: UVector.Vector Month +normalYearDayOfYearMonthTable = + UVector.fromList $ + (Month 0 :) $ + concat + [ replicate 31 (Month 0) + , replicate 28 (Month 1) + , replicate 31 (Month 2) + , replicate 30 (Month 3) + , replicate 31 (Month 4) + , replicate 30 (Month 5) + , replicate 31 (Month 6) + , replicate 31 (Month 7) + , replicate 30 (Month 8) + , replicate 31 (Month 9) + , replicate 30 (Month 10) + , replicate 31 (Month 11) + ] +{-# NOINLINE normalYearDayOfYearMonthTable #-} + +-- | Build a 'MonthMatch' from twelve (12) values. +buildMonthMatch :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> MonthMatch a +buildMonthMatch a b c d e f g h i j k l = + MonthMatch (Vector.fromListN 12 [a, b, c, d, e, f, g, h, i, j, k, l]) + +-- | Match a 'Month' against a 'MonthMatch'. +caseMonth :: MonthMatch a -> Month -> a +caseMonth (MonthMatch v) (Month ix) = Vector.unsafeIndex v ix + +-- | Build an 'UnboxedMonthMatch' from twelve (12) values. +buildUnboxedMonthMatch :: (UVector.Unbox a) => a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> UnboxedMonthMatch a +buildUnboxedMonthMatch a b c d e f g h i j k l = + UnboxedMonthMatch (UVector.fromListN 12 [a, b, c, d, e, f, g, h, i, j, k, l]) + +-- | Match a 'Month' against an 'UnboxedMonthMatch'. +caseUnboxedMonth :: (UVector.Unbox a) => UnboxedMonthMatch a -> Month -> a +caseUnboxedMonth (UnboxedMonthMatch v) (Month ix) = UVector.unsafeIndex v ix + +-- | Build a 'DayOfWeekMatch' from seven (7) values. +buildDayOfWeekMatch :: a -> a -> a -> a -> a -> a -> a -> DayOfWeekMatch a +buildDayOfWeekMatch a b c d e f g = + DayOfWeekMatch (Vector.fromListN 7 [a, b, c, d, e, f, g]) + +-- | Match a 'DayOfWeek' against a 'DayOfWeekMatch'. +caseDayOfWeek :: DayOfWeekMatch a -> DayOfWeek -> a +caseDayOfWeek (DayOfWeekMatch v) (DayOfWeek ix) = Vector.unsafeIndex v ix + +{- | Given a 'Date' and a separator, construct a 'Text' 'TB.Builder' + corresponding to Year\/Month\/Day encoding. +-} +builder_Ymd :: Maybe Char -> Date -> TB.Builder +builder_Ymd msep (Date y m d) = case msep of + Nothing -> + yearToZeroPaddedDigit y + <> monthToZeroPaddedDigit m + <> zeroPadDayOfMonth d + Just sep -> + let sepBuilder = TB.singleton sep + in yearToZeroPaddedDigit y + <> sepBuilder + <> monthToZeroPaddedDigit m + <> sepBuilder + <> zeroPadDayOfMonth d + +{- | Given a 'Date' and a separator, construct a 'Text.Text' + corresponding to a Year\/Month\/Day encoding. + + >>> encode_Ymd (Just ':') (Date (Year 2022) january (DayOfMonth 13)) + "2022:01:13" +-} +encode_Ymd :: Maybe Char -> Date -> Text +encode_Ymd msep = LT.toStrict . TB.toLazyText . builder_Ymd msep + +{- | Given a 'Date' and a separator, construct a 'Text' 'TB.Builder' + corresponding to a Day\/Month\/Year encoding. +-} +builder_Dmy :: Maybe Char -> Date -> TB.Builder +builder_Dmy msep (Date y m d) = case msep of + Nothing -> + zeroPadDayOfMonth d + <> monthToZeroPaddedDigit m + <> yearToZeroPaddedDigit y + Just sep -> + let sepBuilder = TB.singleton sep + in zeroPadDayOfMonth d + <> sepBuilder + <> monthToZeroPaddedDigit m + <> sepBuilder + <> yearToZeroPaddedDigit y + +{- | Given a 'Date' and a separator, construct a 'Text.Text' + corresponding to a Day\/Month\/Year encoding. + + >>> encode_Dmy (Just ':') (Date (Year 2022) january (DayOfMonth 13)) + "13:01:2022" +-} +encode_Dmy :: Maybe Char -> Date -> Text +encode_Dmy msep = LT.toStrict . TB.toLazyText . builder_Dmy msep + +{- | Parse a Year\/Month\/Day-encoded 'Date' that uses the + given separator. +-} +parser_Ymd :: Maybe Char -> Parser Date +parser_Ymd msep = do + y <- parseFixedDigits 4 + traverse_ AT.char msep + m <- parseFixedDigits 2 + when (m < 1 || m > 12) (fail "month must be between 1 and 12") + traverse_ AT.char msep + d <- parseFixedDigits 2 + when (d < 1 || d > 31) (fail "day must be between 1 and 31") + pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +{- | Parse a Year\/Month\/Day-encoded 'Date' that either has no separators or + uses any non-numeric character for each separator. +-} +parser_Ymd_lenient :: Parser Date +parser_Ymd_lenient = do + y <- parseFixedDigits 4 + sep1 <- optional parserLenientSeparator + m <- parseFixedDigits 2 + when (m < 1 || m > 12) (fail "month must be between 1 and 12") + sep2 <- optional parserLenientSeparator + d <- parseFixedDigits 2 + when (d < 1 || d > 31) (fail "day must be between 1 and 31") + case (sep1, sep2) of + (Nothing, Just _) -> fail "Separators must all exist or not" + (Just _, Nothing) -> fail "Separators must all exist or not" + _ -> pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +{- | Parse a Month\/Day\/Year-encoded 'Date' that uses the + given separator. +-} +parser_Mdy :: Maybe Char -> Parser Date +parser_Mdy msep = do + m <- parseFixedDigits 2 + when (m < 1 || m > 12) (fail "month must be between 1 and 12") + traverse_ AT.char msep + d <- parseFixedDigits 2 + when (d < 1 || d > 31) (fail "day must be between 1 and 31") + traverse_ AT.char msep + y <- parseFixedDigits 4 + pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +{- | Parse a Month\/Day\/Year-encoded 'Date' that either has no separators or +uses any non-numeric character for each separator. +-} +parser_Mdy_lenient :: Parser Date +parser_Mdy_lenient = do + m <- parseFixedDigits 2 + when (m < 1 || m > 12) (fail "month must be between 1 and 12") + sep1 <- optional parserLenientSeparator + d <- parseFixedDigits 2 + when (d < 1 || d > 31) (fail "day must be between 1 and 31") + sep2 <- optional parserLenientSeparator + y <- parseFixedDigits 4 + case (sep1, sep2) of + (Nothing, Just _) -> fail "Separators must all exist or not" + (Just _, Nothing) -> fail "Separators must all exist or not" + _ -> pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +{- | Parse a Day\/Month\/Year-encoded 'Date' that uses the + given separator. +-} +parser_Dmy :: Maybe Char -> Parser Date +parser_Dmy msep = do + d <- parseFixedDigits 2 + when (d < 1 || d > 31) (fail "day must be between 1 and 31") + traverse_ AT.char msep + m <- parseFixedDigits 2 + when (m < 1 || m > 12) (fail "month must be between 1 and 12") + traverse_ AT.char msep + y <- parseFixedDigits 4 + pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +{- | Parse a Day\/Month\/Year-encoded 'Date' that either has no separators or + uses any non-numeric character for each separator. +-} +parser_Dmy_lenient :: Parser Date +parser_Dmy_lenient = do + d <- parseFixedDigits 2 + when (d < 1 || d > 31) (fail "day must be between 1 and 31") + sep1 <- optional parserLenientSeparator + m <- parseFixedDigits 2 + when (m < 1 || m > 12) (fail "month must be between 1 and 12") + sep2 <- optional parserLenientSeparator + y <- parseFixedDigits 4 + case (sep1, sep2) of + (Nothing, Just _) -> fail "Separators must all exist or not" + (Just _, Nothing) -> fail "Separators must all exist or not" + _ -> pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +{- | Given a 'Date' and a separator, construct a 'ByteString' 'BB.Builder' + corresponding to a Day\/Month\/Year encoding. +-} +builderUtf8_Ymd :: Maybe Char -> Date -> BB.Builder +builderUtf8_Ymd msep (Date y m d) = case msep of + Nothing -> + yearToZeroPaddedDigitBS y + <> monthToZeroPaddedDigitBS m + <> zeroPadDayOfMonthBS d + Just sep -> + let sepBuilder = BB.char7 sep + in yearToZeroPaddedDigitBS y + <> sepBuilder + <> monthToZeroPaddedDigitBS m + <> sepBuilder + <> zeroPadDayOfMonthBS d + +{- | Parse a Year\/Month\/Day-encoded 'Date' that uses the + given separator. +-} +parserUtf8_Ymd :: Maybe Char -> AB.Parser Date +parserUtf8_Ymd msep = do + y <- parseFixedDigitsIntBS 4 + traverse_ AB.char msep + m <- parseFixedDigitsIntBS 2 + when (m < 1 || m > 12) (fail "month must be between 1 and 12") + traverse_ AB.char msep + d <- parseFixedDigitsIntBS 2 + when (d < 1 || d > 31) (fail "day must be between 1 and 31") + pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +{- | Given a 'SubsecondPrecision' and a separator, construct a + 'Text' 'TB.Builder' corresponding to an Hour\/Minute\/Second + encoding. +-} +builder_HMS :: SubsecondPrecision -> Maybe Char -> TimeOfDay -> TB.Builder +builder_HMS sp msep (TimeOfDay h m ns) = + indexTwoDigitTextBuilder h + <> internalBuilder_NS sp msep m ns + +{- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a separator, + construct a 'Text' 'TB.Builder' according to an IMS encoding. + + This differs from 'builder_IMSp' in that their is a space + between the seconds and locale. +-} +builder_IMS_p :: MeridiemLocale Text -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> TB.Builder +builder_IMS_p meridiemLocale sp msep (TimeOfDay h m ns) = + internalBuilder_I h + <> internalBuilder_NS sp msep m ns + <> " " + <> internalBuilder_p meridiemLocale h + +{- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a separator, + construct a 'Text' 'TB.Builder' according to an IMS encoding. +-} +builder_IMSp :: MeridiemLocale Text -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> TB.Builder +builder_IMSp meridiemLocale sp msep (TimeOfDay h m ns) = + internalBuilder_I h + <> internalBuilder_NS sp msep m ns + <> internalBuilder_p meridiemLocale h + +internalBuilder_I :: Int -> TB.Builder +internalBuilder_I h = + indexTwoDigitTextBuilder $ + if h > 12 + then h - 12 + else + if h == 0 + then 12 + else h + +internalBuilder_p :: MeridiemLocale Text -> Int -> TB.Builder +internalBuilder_p (MeridiemLocale am pm) h = + if h > 11 + then TB.fromText pm + else TB.fromText am + +{- | Parse an Hour\/Minute\/Second-encoded 'TimeOfDay' that uses + the given separator. +-} +parser_HMS :: Maybe Char -> Parser TimeOfDay +parser_HMS msep = do + h <- parseFixedDigits 2 + when (h > 23) (fail "hour must be between 0 and 23") + traverse_ AT.char msep + m <- parseFixedDigits 2 + when (m > 59) (fail "minute must be between 0 and 59") + traverse_ AT.char msep + ns <- parseSecondsAndNanoseconds + pure (TimeOfDay h m ns) + +parserLenientSeparator :: Parser () +parserLenientSeparator = AT.satisfy (not . isDigit) *> pure () + +{- | Parse an Hour\/Minute\/Second-encoded 'TimeOfDay' that either has no + separators or uses any given non-numeric character for each separator. +-} +parser_HMS_lenient :: Parser TimeOfDay +parser_HMS_lenient = do + h <- parseFixedDigits 2 + when (h > 23) (fail "hour must be between 0 and 23") + parserLenientSeparator + m <- parseFixedDigits 2 + when (m > 59) (fail "minute must be between 0 and 59") + parserLenientSeparator + ns <- parseSecondsAndNanoseconds + pure (TimeOfDay h m ns) + +{- | Parses text that is formatted as either of the following: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +parser_HMS_opt_S :: Maybe Char -> Parser TimeOfDay +parser_HMS_opt_S msep = do + h <- parseFixedDigits 2 + when (h > 23) (fail "hour must be between 0 and 23") + traverse_ AT.char msep + m <- parseFixedDigits 2 + when (m > 59) (fail "minute must be between 0 and 59") + mc <- AT.peekChar + case mc of + Nothing -> pure (TimeOfDay h m 0) + Just c -> case msep of + Just sep -> + if c == sep + then do + _ <- AT.anyChar -- should be the separator + ns <- parseSecondsAndNanoseconds + pure (TimeOfDay h m ns) + else pure (TimeOfDay h m 0) + -- if there is no separator, we will try to parse the + -- remaining part as seconds. We commit to trying to + -- parse as seconds if we see any number as the next + -- character. + Nothing -> + if isDigit c + then do + ns <- parseSecondsAndNanoseconds + pure (TimeOfDay h m ns) + else pure (TimeOfDay h m 0) + +{- | Parses text that is formatted as either of the following with either no +separators or any non-numeric characters for each separator: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +parser_HMS_opt_S_lenient :: Parser TimeOfDay +parser_HMS_opt_S_lenient = do + h <- parseFixedDigits 2 + when (h > 23) (fail "hour must be between 0 and 23") + parserLenientSeparator + m <- parseFixedDigits 2 + when (m > 59) (fail "minute must be between 0 and 59") + mc <- AT.peekChar + case mc of + Nothing -> pure (TimeOfDay h m 0) + Just c | not (isDigit c) -> do + _ <- AT.anyChar -- should be the separator + ns <- parseSecondsAndNanoseconds + pure (TimeOfDay h m ns) + Just _ -> do + ns <- parseSecondsAndNanoseconds + pure (TimeOfDay h m ns) + +parseSecondsAndNanoseconds :: Parser Int64 +parseSecondsAndNanoseconds = do + s' <- parseFixedDigits 2 + let s = fromIntegral s' :: Int64 + when (s > 60) (fail "seconds must be between 0 and 60") + nanoseconds <- + ( do + _ <- AT.char '.' + numberOfZeroes <- countZeroes + 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) + +countZeroes :: AT.Parser Int +countZeroes = go 0 + where + go !i = do + m <- AT.peekChar + case m of + Nothing -> pure i + Just c -> + if c == '0' + then AT.anyChar *> go (i + 1) + else pure i + +nanosecondsBuilder :: Int64 -> TB.Builder +nanosecondsBuilder w + | w == 0 = mempty + | w > 99999999 = "." <> TB.decimal w + | w > 9999999 = ".0" <> TB.decimal w + | w > 999999 = ".00" <> TB.decimal w + | w > 99999 = ".000" <> TB.decimal w + | w > 9999 = ".0000" <> TB.decimal w + | w > 999 = ".00000" <> TB.decimal w + | w > 99 = ".000000" <> TB.decimal w + | w > 9 = ".0000000" <> TB.decimal w + | otherwise = ".00000000" <> TB.decimal w + +microsecondsBuilder :: Int64 -> TB.Builder +microsecondsBuilder w + | w == 0 = mempty + | w > 99999 = "." <> TB.decimal w + | w > 9999 = ".0" <> TB.decimal w + | w > 999 = ".00" <> TB.decimal w + | w > 99 = ".000" <> TB.decimal w + | w > 9 = ".0000" <> TB.decimal w + | otherwise = ".00000" <> TB.decimal w + +millisecondsBuilder :: Int64 -> TB.Builder +millisecondsBuilder w + | w == 0 = mempty + | w > 99 = "." <> TB.decimal w + | w > 9 = ".0" <> TB.decimal w + | otherwise = ".00" <> TB.decimal w + +prettyNanosecondsBuilder :: SubsecondPrecision -> Int64 -> TB.Builder +prettyNanosecondsBuilder sp nano = case sp of + SubsecondPrecisionAuto + | milliRem == 0 -> millisecondsBuilder milli + | microRem == 0 -> microsecondsBuilder micro + | otherwise -> nanosecondsBuilder nano + SubsecondPrecisionFixed d -> + if d == 0 + then mempty + else + let newSubsecondPart = quot nano (raiseTenTo (9 - d)) + in "." + <> TB.fromText (Text.replicate (d - countDigits newSubsecondPart) "0") + <> TB.decimal newSubsecondPart + where + (milli, milliRem) = quotRem nano 1000000 + (micro, microRem) = quotRem nano 1000 + +-- | Encode a 'Timespan' as 'Text' using the given 'SubsecondPrecision'. +encodeTimespan :: SubsecondPrecision -> Timespan -> Text +encodeTimespan sp = + LT.toStrict . TB.toLazyText . builderTimespan sp + +{- | Construct a 'Text' 'TB.Builder' corresponding to an encoding + of the given 'Timespan' using the given 'SubsecondPrecision'. +-} +builderTimespan :: SubsecondPrecision -> Timespan -> TB.Builder +builderTimespan sp (Timespan ns) = + TB.decimal sInt64 <> prettyNanosecondsBuilder sp nsRemainder + where + (!sInt64, !nsRemainder) = quotRem ns 1000000000 + +internalBuilder_NS :: SubsecondPrecision -> Maybe Char -> Int -> Int64 -> TB.Builder +internalBuilder_NS sp msep m ns = case msep of + Nothing -> + indexTwoDigitTextBuilder m + <> indexTwoDigitTextBuilder s + <> prettyNanosecondsBuilder sp nsRemainder + Just sep -> + let sepBuilder = TB.singleton sep + in sepBuilder + <> indexTwoDigitTextBuilder m + <> sepBuilder + <> indexTwoDigitTextBuilder s + <> prettyNanosecondsBuilder sp nsRemainder + where + (!sInt64, !nsRemainder) = quotRem ns 1000000000 + !s = fromIntegral sInt64 + +{- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct a + 'Text' 'TB.Builder' corresponding to a + Day\/Month\/Year,Hour\/Minute\/Second encoding of the given 'Datetime'. +-} +builder_DmyHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder +builder_DmyHMS sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = + case msep of + Nothing -> + builder_Dmy mdateSep date + <> builder_HMS sp mtimeSep time + Just sep -> + builder_Dmy mdateSep date + <> TB.singleton sep + <> builder_HMS sp mtimeSep time + +{- | Given a 'MeridiemLocale', a 'SubsecondPrecision', + and a 'DatetimeFormat', construct a 'Text' 'TB.Builder' + corresponding to a Day\/Month\/Year,IMS encoding of the given + 'Datetime'. This differs from 'builder_DmyIMSp' in that + it adds a space between the locale and seconds. +-} +builder_DmyIMS_p :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder +builder_DmyIMS_p locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = + builder_Dmy mdateSep date + <> maybe mempty TB.singleton msep + <> builder_IMS_p locale sp mtimeSep time + +{- | Given a 'MeridiemLocale', a 'SubsecondPrecision', + and a 'DatetimeFormat', construct a 'Text' 'TB.Builder' + corresponding to a Day\/Month\/Year,IMS encoding of the given + 'Datetime'. +-} +builder_DmyIMSp :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder +builder_DmyIMSp locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = + builder_Dmy mdateSep date + <> maybe mempty TB.singleton msep + <> builder_IMS_p locale sp mtimeSep time + +{- | Given a 'SubsecondPrecision' and 'DatetimeFormat', construct + 'Text' that corresponds to a Day\/Month\/Year,Hour\/Minute\/Second + encoding of the given 'Datetime'. +-} +encode_DmyHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> Text +encode_DmyHMS sp format = + LT.toStrict . TB.toLazyText . builder_DmyHMS sp format + +{- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a + 'DatetimeFormat', construct 'Text' that corresponds to a + Day\/Month\/Year,IMS encoding of the given 'Datetime'. This + inserts a space between the locale and seconds. +-} +encode_DmyIMS_p :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> Text +encode_DmyIMS_p a sp b = LT.toStrict . TB.toLazyText . builder_DmyIMS_p a sp b + +{- | Given a 'SubsecondPrecision' and 'DatetimeFormat', construct + 'Text' that corresponds to a Year\/Month\/Day,Hour\/Minute\/Second + encoding of the given 'Datetime'. +-} +encode_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> Text +encode_YmdHMS sp format = + LT.toStrict . TB.toLazyText . builder_YmdHMS sp format + +{- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a + 'DatetimeFormat', construct 'Text' that corresponds to a + Year\/Month\/Day,IMS encoding of the given 'Datetime'. This + inserts a space between the locale and seconds. +-} +encode_YmdIMS_p :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> Text +encode_YmdIMS_p a sp b = LT.toStrict . TB.toLazyText . builder_YmdIMS_p a sp b + +{- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct + a 'Text' 'TB.Builder' corresponding to a + Year\/Month\/Day,Hour\/Minute\/Second encoding of the given 'Datetime'. +-} +builder_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder +builder_YmdHMS sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = + case msep of + Nothing -> + builder_Ymd mdateSep date + <> builder_HMS sp mtimeSep time + Just sep -> + builder_Ymd mdateSep date + <> TB.singleton sep + <> builder_HMS sp mtimeSep time + +{- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a + 'DatetimeFormat', construct a 'Text' 'TB.Builder' that + corresponds to a Year\/Month\/Day,IMS encoding of the + given 'Datetime'. This inserts a space between the locale + and seconds. +-} +builder_YmdIMS_p :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder +builder_YmdIMS_p locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = + builder_Ymd mdateSep date + <> maybe mempty TB.singleton msep + <> builder_IMS_p locale sp mtimeSep time + +{- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a + 'DatetimeFormat', construct a 'Text' 'TB.Builder' that + corresponds to a Year\/Month\/Day,IMS encoding of the + given 'Datetime'. +-} +builder_YmdIMSp :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> TB.Builder +builder_YmdIMSp locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = + builder_Ymd mdateSep date + <> maybe mempty TB.singleton msep + <> builder_IMS_p locale sp mtimeSep time + +{- | Construct a 'Text' 'TB.Builder' corresponding to the W3C + encoding of the given 'Datetime'. + + Deprecated. This is just a poorly named alias for 'builderIso8601'. +-} +builderW3C :: Datetime -> TB.Builder +builderW3C = builderIso8601 + +{- | Construct a 'Text' 'TB.Builder' corresponding to the ISO-8601 + encoding of the given 'Datetime'. +-} +builderIso8601 :: Datetime -> TB.Builder +builderIso8601 = builder_YmdHMS SubsecondPrecisionAuto w3c + +{- | Construct 'Text' corresponding to the ISO-8601 + encoding of the given 'Datetime'. + + >>> encodeIso8601 (datetimeFromYmdhms 2014 2 26 17 58 52) + "2014-02-26T17:58:52" +-} +encodeIso8601 :: Datetime -> Text +encodeIso8601 = LT.toStrict . TB.toLazyText . builderIso8601 + +{- | Decode a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'Datetime' + from 'Text' that was encoded with the given 'DatetimeFormat'. +-} +decode_YmdHMS :: DatetimeFormat -> Text -> Maybe Datetime +decode_YmdHMS format = + either (const Nothing) Just . AT.parseOnly (parser_YmdHMS format) + +{- | Decode a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with either no separators or any non-numeric + character for each separator. +-} +decode_YmdHMS_lenient :: Text -> Maybe Datetime +decode_YmdHMS_lenient = + either (const Nothing) Just . AT.parseOnly parser_YmdHMS_lenient + +{- | Parse a Day\/Month\/Year,Hour\/Minute\/Second-encoded 'Datetime' + that was encoded with the given 'DatetimeFormat'. +-} +parser_DmyHMS :: DatetimeFormat -> Parser Datetime +parser_DmyHMS (DatetimeFormat mdateSep msep mtimeSep) = do + date <- parser_Dmy mdateSep + traverse_ AT.char msep + time <- parser_HMS mtimeSep + pure (Datetime date time) + +{- | Parses text that is formatted as either of the following: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +parser_DmyHMS_opt_S :: DatetimeFormat -> Parser Datetime +parser_DmyHMS_opt_S (DatetimeFormat mdateSep msep mtimeSep) = do + date <- parser_Dmy mdateSep + traverse_ AT.char msep + time <- parser_HMS_opt_S mtimeSep + pure (Datetime date time) + +{- | Parse a Day\/Month\/Year,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with either no separators or any non-numeric + character for each separator, such as: + +01-05-2017T23:13:05 +01-05-2017 23:13:05 +01/05/2017 23:13:05 +01y01/2018x23;50&29 +-} +parser_DmyHMS_lenient :: Parser Datetime +parser_DmyHMS_lenient = do + mdate <- optional $ parser_Dmy Nothing + case mdate of + Just date -> Datetime date <$> parser_HMS Nothing + Nothing -> Datetime <$> parser_Dmy_lenient <* parserLenientSeparator <*> parser_HMS_lenient + +{- | Parse a Day\/Month\/Year,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with either no separators or any non-numeric + character for each separator and with either of the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +parser_DmyHMS_opt_S_lenient :: Parser Datetime +parser_DmyHMS_opt_S_lenient = do + mdate <- optional $ parser_Dmy Nothing + case mdate of + Just date -> Datetime date <$> parser_HMS_opt_S Nothing + Nothing -> Datetime <$> parser_Dmy_lenient <* parserLenientSeparator <*> parser_HMS_opt_S_lenient + +{- | Decodes Day\/Month\/Year,Hour\/Minute\/Second-encoded 'Datetime' from +'Text' that is encoded with either no separators or any non-numeric +characters as separators, such as: + +2017-01-05T23:13:05 +2017-01-05 23:13:05 +2017/01/05 23:13:05 +2018x01y01/23;50&29 +-} +decode_DmyHMS_lenient :: Text -> Maybe Datetime +decode_DmyHMS_lenient = either (const Nothing) Just . AT.parseOnly parser_DmyHMS_lenient + +{- | Decode a Day\/Month\/Year,Hour\/Minute\/Second-encoded 'Datetime' + from 'Text' that was encoded with the given 'DatetimeFormat'. +-} +decode_DmyHMS :: DatetimeFormat -> Text -> Maybe Datetime +decode_DmyHMS format = + either (const Nothing) Just . AT.parseOnly (parser_DmyHMS format) + +{- | Decode a Day\/Month\/Year,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with with the given 'DatetimeFormat' and with + either of the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +decode_DmyHMS_opt_S :: DatetimeFormat -> Text -> Maybe Datetime +decode_DmyHMS_opt_S format = + either (const Nothing) Just . AT.parseOnly (parser_DmyHMS_opt_S format) + +{- | Decode a Day\/Month\/Year,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with either no separators or any non-numeric + character for each separator and with either of the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +decode_DmyHMS_opt_S_lenient :: Text -> Maybe Datetime +decode_DmyHMS_opt_S_lenient = + either (const Nothing) Just . AT.parseOnly parser_DmyHMS_opt_S_lenient + +{- | Parses a Month\/Day\/Year,Hour\/Minute\/Second-encoded 'Datetime' + that was encoded using the given 'DatetimeFormat'. +-} +parser_MdyHMS :: DatetimeFormat -> Parser Datetime +parser_MdyHMS (DatetimeFormat mdateSep msep mtimeSep) = do + date <- parser_Mdy mdateSep + traverse_ AT.char msep + time <- parser_HMS mtimeSep + pure (Datetime date time) + +{- | Parses a Month\/Day\/Year,Hour\/Minute\/Second-encoded 'Datetime' that was + encoded with either no separators or any non-numeric character for each + separator. +-} +parser_MdyHMS_lenient :: Parser Datetime +parser_MdyHMS_lenient = do + mdate <- optional $ parser_Mdy Nothing + case mdate of + Just date -> Datetime date <$> parser_HMS Nothing + Nothing -> Datetime <$> parser_Mdy_lenient <* parserLenientSeparator <*> parser_HMS_lenient + +{- | Parse a Month\/Day\/Year,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with with the given 'DatetimeFormat' and with + either of the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. +-} +parser_MdyHMS_opt_S :: DatetimeFormat -> Parser Datetime +parser_MdyHMS_opt_S (DatetimeFormat mdateSep msep mtimeSep) = do + date <- parser_Mdy mdateSep + traverse_ AT.char msep + time <- parser_HMS_opt_S mtimeSep + pure (Datetime date time) + +{- | Parse a Month\/Day\/Year,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with either no separators or any non-numeric + character for each separator and with either of the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. +-} +parser_MdyHMS_opt_S_lenient :: Parser Datetime +parser_MdyHMS_opt_S_lenient = do + mdate <- optional $ parser_Mdy Nothing + case mdate of + Just date -> Datetime date <$> parser_HMS_opt_S Nothing + Nothing -> Datetime <$> parser_Mdy_lenient <* parserLenientSeparator <*> parser_HMS_opt_S_lenient + +{- | Decode a Month\/Day\/Year,Hour\/Minute\/Second-encoded 'Datetime' + from 'Text' that was encoded with the given 'DatetimeFormat'. +-} +decode_MdyHMS :: DatetimeFormat -> Text -> Maybe Datetime +decode_MdyHMS format = + either (const Nothing) Just . AT.parseOnly (parser_MdyHMS format) + +{- | Decode a Month\/Day\/Year,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' with either no separators or any non-numeric character for each + separator. +-} +decode_MdyHMS_lenient :: Text -> Maybe Datetime +decode_MdyHMS_lenient = + either (const Nothing) Just . AT.parseOnly parser_MdyHMS_lenient + +{- | Decode a Month\/Day\/Year,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with the given 'DatetimeFormat' and with either of + the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. +-} +decode_MdyHMS_opt_S :: DatetimeFormat -> Text -> Maybe Datetime +decode_MdyHMS_opt_S format = + either (const Nothing) Just . AT.parseOnly (parser_MdyHMS_opt_S format) + +{- | Parse a Month\/Day\/Year,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' with either no separators or any non-numeric character for each + separator and with either of the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. +-} +decode_MdyHMS_opt_S_lenient :: Text -> Maybe Datetime +decode_MdyHMS_opt_S_lenient = + either (const Nothing) Just . AT.parseOnly parser_MdyHMS_opt_S_lenient + +{- | Parses a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'Datetime' + that was encoded using the given 'DatetimeFormat'. +-} +parser_YmdHMS :: DatetimeFormat -> Parser Datetime +parser_YmdHMS (DatetimeFormat mdateSep msep mtimeSep) = do + date <- parser_Ymd mdateSep + traverse_ AT.char msep + time <- parser_HMS mtimeSep + pure (Datetime date time) + +{- | Parses a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'Datetime' that was + encoded with either no separators or any non-numeric character for each + separator. +-} +parser_YmdHMS_lenient :: Parser Datetime +parser_YmdHMS_lenient = do + mdate <- optional $ parser_Ymd Nothing + case mdate of + Just date -> Datetime date <$> parser_HMS Nothing + Nothing -> Datetime <$> parser_Ymd_lenient <* parserLenientSeparator <*> parser_HMS_lenient + +{- | Parses a Year\/Month\/Date,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with the given 'DatetimeFormat' and with either of + the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +parser_YmdHMS_opt_S :: DatetimeFormat -> Parser Datetime +parser_YmdHMS_opt_S (DatetimeFormat mdateSep msep mtimeSep) = do + date <- parser_Ymd mdateSep + traverse_ AT.char msep + time <- parser_HMS_opt_S mtimeSep + pure (Datetime date time) + +{- | Parses a Year\/Month\/Date,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with either no separators or any non-numeric + character for each separator and with either of the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +parser_YmdHMS_opt_S_lenient :: Parser Datetime +parser_YmdHMS_opt_S_lenient = do + mdate <- optional $ parser_Ymd Nothing + case mdate of + Just date -> Datetime date <$> parser_HMS_opt_S Nothing + Nothing -> Datetime <$> parser_Ymd_lenient <* parserLenientSeparator <*> parser_HMS_opt_S_lenient + +{- | Decode a Year\/Month\/Date,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with the given 'DatetimeFormat' and with either of + the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +decode_YmdHMS_opt_S :: DatetimeFormat -> Text -> Maybe Datetime +decode_YmdHMS_opt_S format = + either (const Nothing) Just . AT.parseOnly (parser_YmdHMS_opt_S format) + +{- | Decode a Year\/Month\/Date,Hour\/Minute\/Second-encoded 'Datetime' from + 'Text' that was encoded with either no separators or any non-numeric + character for each separator and with either of the following time formats: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +decode_YmdHMS_opt_S_lenient :: Text -> Maybe Datetime +decode_YmdHMS_opt_S_lenient = + either (const Nothing) Just . AT.parseOnly parser_YmdHMS_opt_S_lenient + +{- | Parses a 'Datetime' from 'Text' that was encoded with any of the following +formats and with either no separators or any non-numeric character for each +separator. + +* @%Y-%M-%D %H:%M@ +* @%Y-%M-%D %H:%M:%S@ +* @%D-%M-%Y %H:%M@ +* @%D-%M-%Y %H:%M:%S@ +* @%M-%D-%Y %H:%M@ +* @%M-%D-%Y %H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is not provided, +it is assumed to be zero. Note that this is the least performant parser due +to backtracking +-} +parser_lenient :: Parser Datetime +parser_lenient = parser_YmdHMS_opt_S_lenient <|> parser_DmyHMS_opt_S_lenient <|> parser_MdyHMS_opt_S_lenient + +{- | Parses text that was encoded in DMY, YMD, or MDY format with optional +seconds and any non-numeric character as separators. +-} +decode_lenient :: Text -> Maybe Datetime +decode_lenient = + either (const Nothing) Just . AT.parseOnly parser_lenient + +--------------- +-- ByteString stuff +--------------- + +-- | Given a 'SubsecondPrecision' and a separator, construct a 'ByteString' 'BB.Builder' corresponding to an Hour\/Minute\/Second encoding of the given 'TimeOfDay'. +builderUtf8_HMS :: SubsecondPrecision -> Maybe Char -> TimeOfDay -> BB.Builder +builderUtf8_HMS sp msep (TimeOfDay h m ns) = + indexTwoDigitByteStringBuilder h + <> internalBuilderUtf8_NS sp msep m ns + +{- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a separator, construct a 'ByteString' 'BB.Builder' corresponding to an IMS encoding of the given 'TimeOfDay'. This differs from 'builderUtf8_IMSp' in that +there is a space between the seconds and locale. +-} +builderUtf8_IMS_p :: MeridiemLocale ByteString -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> BB.Builder +builderUtf8_IMS_p meridiemLocale sp msep (TimeOfDay h m ns) = + internalBuilderUtf8_I h + <> internalBuilderUtf8_NS sp msep m ns + <> " " + <> internalBuilderUtf8_p meridiemLocale h + +internalBuilderUtf8_I :: Int -> BB.Builder +internalBuilderUtf8_I h = + indexTwoDigitByteStringBuilder $ + if h > 12 + then h - 12 + else + if h == 0 + then 12 + else h + +internalBuilderUtf8_p :: MeridiemLocale ByteString -> Int -> BB.Builder +internalBuilderUtf8_p (MeridiemLocale am pm) h = + if h > 11 + then BB.byteString pm + else BB.byteString am + +-- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a separator, construct a 'ByteString' 'BB.Builder' corresponding to an IMS encoding of the given 'TimeOfDay'. +builderUtf8_IMSp :: MeridiemLocale ByteString -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> BB.Builder +builderUtf8_IMSp meridiemLocale sp msep (TimeOfDay h m ns) = + internalBuilderUtf8_I h + <> internalBuilderUtf8_NS sp msep m ns + <> internalBuilderUtf8_p meridiemLocale h + +{- | Parse an Hour\/Minute\/Second-encoded 'TimeOfDay' that uses + the given separator. +-} +parserUtf8_HMS :: Maybe Char -> AB.Parser TimeOfDay +parserUtf8_HMS msep = do + h <- parseFixedDigitsIntBS 2 + when (h > 23) (fail "hour must be between 0 and 23") + traverse_ AB.char msep + m <- parseFixedDigitsIntBS 2 + when (m > 59) (fail "minute must be between 0 and 59") + traverse_ AB.char msep + ns <- parseSecondsAndNanosecondsUtf8 + pure (TimeOfDay h m ns) + +{- | Parses text that is formatted as either of the following: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +parserUtf8_HMS_opt_S :: Maybe Char -> AB.Parser TimeOfDay +parserUtf8_HMS_opt_S msep = do + h <- parseFixedDigitsIntBS 2 + when (h > 23) (fail "hour must be between 0 and 23") + traverse_ AB.char msep + m <- parseFixedDigitsIntBS 2 + when (m > 59) (fail "minute must be between 0 and 59") + mc <- AB.peekChar + case mc of + Nothing -> pure (TimeOfDay h m 0) + Just c -> case msep of + Just sep -> + if c == sep + then do + _ <- AB.anyChar -- should be the separator + ns <- parseSecondsAndNanosecondsUtf8 + pure (TimeOfDay h m ns) + else pure (TimeOfDay h m 0) + -- if there is no separator, we will try to parse the + -- remaining part as seconds. We commit to trying to + -- parse as seconds if we see any number as the next + -- character. + Nothing -> + if isDigit c + then do + ns <- parseSecondsAndNanosecondsUtf8 + pure (TimeOfDay h m ns) + else pure (TimeOfDay h m 0) + +parseSecondsAndNanosecondsUtf8 :: AB.Parser Int64 +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 + 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) + +countZeroesUtf8 :: AB.Parser Int +countZeroesUtf8 = go 0 + where + go !i = do + m <- AB.peekChar + case m of + Nothing -> pure i + Just c -> + if c == '0' + then AB.anyChar *> go (i + 1) + else pure i + +nanosecondsBuilderUtf8 :: Int64 -> BB.Builder +nanosecondsBuilderUtf8 w + | w == 0 = mempty + | w > 99999999 = "." <> int64Builder w + | w > 9999999 = ".0" <> int64Builder w + | w > 999999 = ".00" <> int64Builder w + | w > 99999 = ".000" <> int64Builder w + | w > 9999 = ".0000" <> int64Builder w + | w > 999 = ".00000" <> int64Builder w + | w > 99 = ".000000" <> int64Builder w + | w > 9 = ".0000000" <> int64Builder w + | otherwise = ".00000000" <> int64Builder w + +microsecondsBuilderUtf8 :: Int64 -> BB.Builder +microsecondsBuilderUtf8 w + | w == 0 = mempty + | w > 99999 = "." <> int64Builder w + | w > 9999 = ".0" <> int64Builder w + | w > 999 = ".00" <> int64Builder w + | w > 99 = ".000" <> int64Builder w + | w > 9 = ".0000" <> int64Builder w + | otherwise = ".00000" <> int64Builder w + +millisecondsBuilderUtf8 :: Int64 -> BB.Builder +millisecondsBuilderUtf8 w + | w == 0 = mempty + | w > 99 = "." <> int64Builder w + | w > 9 = ".0" <> int64Builder w + | otherwise = ".00" <> int64Builder w + +prettyNanosecondsBuilderUtf8 :: SubsecondPrecision -> Int64 -> BB.Builder +prettyNanosecondsBuilderUtf8 sp nano = case sp of + SubsecondPrecisionAuto + | milliRem == 0 -> millisecondsBuilderUtf8 milli + | microRem == 0 -> microsecondsBuilderUtf8 micro + | otherwise -> nanosecondsBuilderUtf8 nano + SubsecondPrecisionFixed d -> + if d == 0 + then mempty + else + let newSubsecondPart = quot nano (raiseTenTo (9 - d)) + in BB.char7 '.' + <> BB.byteString (BC.replicate (d - countDigits newSubsecondPart) '0') + <> int64Builder newSubsecondPart + where + (milli, milliRem) = quotRem nano 1000000 + (micro, microRem) = quotRem nano 1000 + +{- | Given a 'SubsecondPrecision', construct a 'ByteString' corresponding + to an encoding of the given 'Timespan'. +-} +encodeTimespanUtf8 :: SubsecondPrecision -> Timespan -> ByteString +encodeTimespanUtf8 sp = + LB.toStrict . BB.toLazyByteString . builderTimespanUtf8 sp + +{- | Given a 'SubsecondPrecision', construct a 'ByteString' 'BB.Builder' + corresponding to an encoding of the given 'Timespan'. +-} +builderTimespanUtf8 :: SubsecondPrecision -> Timespan -> BB.Builder +builderTimespanUtf8 sp (Timespan ns) = + int64Builder sInt64 <> prettyNanosecondsBuilderUtf8 sp nsRemainder + where + (!sInt64, !nsRemainder) = quotRem ns 1000000000 + +int64Builder :: Int64 -> BB.Builder +int64Builder = BB.integerDec . fromIntegral + +internalBuilderUtf8_NS :: SubsecondPrecision -> Maybe Char -> Int -> Int64 -> BB.Builder +internalBuilderUtf8_NS sp msep m ns = case msep of + Nothing -> + indexTwoDigitByteStringBuilder m + <> indexTwoDigitByteStringBuilder s + <> prettyNanosecondsBuilderUtf8 sp nsRemainder + Just sep -> + let sepBuilder = BB.char7 sep + in sepBuilder + <> indexTwoDigitByteStringBuilder m + <> sepBuilder + <> indexTwoDigitByteStringBuilder s + <> prettyNanosecondsBuilderUtf8 sp nsRemainder + where + (!sInt64, !nsRemainder) = quotRem ns 1000000000 + !s = fromIntegral sInt64 + +{- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct + a 'ByteString' corresponding to a Year\/Month\/Day,Hour\/Minute\/Second + encoding of the given 'Datetime'. +-} +encodeUtf8_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> ByteString +encodeUtf8_YmdHMS sp format = + LB.toStrict . BB.toLazyByteString . builderUtf8_YmdHMS sp format + +{- | Given a 'MeridiemLocale', a 'SubsecondPrecision', and a 'DatetimeFormat', + construct a 'ByteString' corresponding to a Year\/Month\/Day,IMS encoding + of the given 'Datetime'. This inserts a space between the locale and + seconds. +-} +encodeUtf8_YmdIMS_p :: MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> Datetime -> ByteString +encodeUtf8_YmdIMS_p a sp b = LB.toStrict . BB.toLazyByteString . builderUtf8_YmdIMS_p a sp b + +{- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct + a 'ByteString' 'BB.Builder' corresponding to a + Year\/Month\/Day,Hour\/Minute\/Second encoding of the + given 'Datetime'. +-} +builderUtf8_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> BB.Builder +builderUtf8_YmdHMS sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = + case msep of + Nothing -> + builderUtf8_Ymd mdateSep date + <> builderUtf8_HMS sp mtimeSep time + Just sep -> + builderUtf8_Ymd mdateSep date + <> BB.char7 sep + <> builderUtf8_HMS sp mtimeSep time + +{- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct + a 'ByteString' 'BB.Builder' corresponding to a + Year\/Month\/Day,IMS encoding of the given 'Datetime'. This inserts + a space between the locale and seconds. +-} +builderUtf8_YmdIMS_p :: MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> Datetime -> BB.Builder +builderUtf8_YmdIMS_p locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = + builderUtf8_Ymd mdateSep date + <> maybe mempty BB.char7 msep + <> builderUtf8_IMS_p locale sp mtimeSep time + +{- | Given a 'SubsecondPrecision' and a 'DatetimeFormat', construct + a 'ByteString' 'BB.Builder' corresponding to a + Year\/Month\/Day,IMS encoding of the given 'Datetime'. +-} +builderUtf8_YmdIMSp :: MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> Datetime -> BB.Builder +builderUtf8_YmdIMSp locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = + builderUtf8_Ymd mdateSep date + <> maybe mempty BB.char7 msep + <> builderUtf8_IMS_p locale sp mtimeSep time + +{- | Construct a 'ByteString' 'BB.Builder' corresponding to + a W3C encoding of the given 'Datetime'. +-} +builderUtf8W3C :: Datetime -> BB.Builder +builderUtf8W3C = builderUtf8_YmdHMS SubsecondPrecisionAuto (DatetimeFormat (Just '-') (Just 'T') (Just ':')) + +{- | Decode a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'Datetime' from + a 'ByteString'. +-} +decodeUtf8_YmdHMS :: DatetimeFormat -> ByteString -> Maybe Datetime +decodeUtf8_YmdHMS format = + either (const Nothing) Just . AB.parseOnly (parserUtf8_YmdHMS format) + +{- | Parse a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'Datetime' that was + encoded using the given 'DatetimeFormat'. +-} +parserUtf8_YmdHMS :: DatetimeFormat -> AB.Parser Datetime +parserUtf8_YmdHMS (DatetimeFormat mdateSep msep mtimeSep) = do + date <- parserUtf8_Ymd mdateSep + traverse_ AB.char msep + time <- parserUtf8_HMS mtimeSep + pure (Datetime date time) + +{- | Parses text that is formatted as either of the following: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +parserUtf8_YmdHMS_opt_S :: DatetimeFormat -> AB.Parser Datetime +parserUtf8_YmdHMS_opt_S (DatetimeFormat mdateSep msep mtimeSep) = do + date <- parserUtf8_Ymd mdateSep + traverse_ AB.char msep + time <- parserUtf8_HMS_opt_S mtimeSep + pure (Datetime date time) + +{- | Parses text that is formatted as either of the following: + +* @%H:%M@ +* @%H:%M:%S@ + +That is, the seconds and subseconds part is optional. If it is +not provided, it is assumed to be zero. This format shows up +in Google Chrome\'s @datetime-local@ inputs. +-} +decodeUtf8_YmdHMS_opt_S :: DatetimeFormat -> ByteString -> Maybe Datetime +decodeUtf8_YmdHMS_opt_S format = + either (const Nothing) Just . AB.parseOnly (parserUtf8_YmdHMS_opt_S format) + +{- | Given an 'OffsetFormat', a 'SubsecondPrecision', and + a 'DatetimeFormat', construct a 'Text' 'TB.Builder' + corresponding to a Year\/Month\/Day,Hour\/Minute\/Second encoding + of the given 'OffsetDatetime'. +-} +builder_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> TB.Builder +builder_YmdHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = + builder_YmdHMS sp datetimeFormat datetime + <> builderOffset offsetFormat offset + +{- | Parse a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'OffsetDatetime' + that was encoded using the given 'OffsetFormat' + and 'DatetimeFormat'. +-} +parser_YmdHMSz :: OffsetFormat -> DatetimeFormat -> Parser OffsetDatetime +parser_YmdHMSz offsetFormat datetimeFormat = + OffsetDatetime + <$> parser_YmdHMS datetimeFormat + <*> parserOffset offsetFormat + +{- | Given an 'OffsetFormat', a 'MeridiemLocale', a + 'SubsecondPrecision', and 'DatetimeFormat', construct a + 'Text' 'TB.Builder' corresponding to a Year\/Month\/Day,IMS-encoding + of the given 'OffsetDatetime'. +-} +builder_YmdIMS_p_z :: OffsetFormat -> MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> TB.Builder +builder_YmdIMS_p_z offsetFormat meridiemLocale sp datetimeFormat (OffsetDatetime datetime offset) = + builder_YmdIMS_p meridiemLocale sp datetimeFormat datetime + <> " " + <> builderOffset offsetFormat offset + +{- | Given an 'OffsetFormat', a 'SubsecondPrecision', + and a 'DatetimeFormat', construct 'Text' corresponding to + the Year\/Month\/Day,Hour\/Minute\/Second-encoding of + the given 'OffsetDatetime'. +-} +encode_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> Text +encode_YmdHMSz offsetFormat sp datetimeFormat = + LT.toStrict . TB.toLazyText . builder_YmdHMSz offsetFormat sp datetimeFormat + +{- | Given an 'OffsetFormat', a 'SubsecondPrecision', and a + 'DatetimeFormat', construct a 'Text' 'TB.Builder' corresponding + to the Day\/Month\/Year,Hour\/Minute\/Second-encoding of + the given 'OffsetDatetime'. +-} +builder_DmyHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> TB.Builder +builder_DmyHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = + builder_DmyHMS sp datetimeFormat datetime + <> builderOffset offsetFormat offset + +{- | Parse a Day\/Month\/Year,Hour\/Minute\/Second-encoded 'OffsetDatetime' + that was encoded using the given 'OffsetFormat' + and 'DatetimeFormat'. +-} +parser_DmyHMSz :: OffsetFormat -> DatetimeFormat -> AT.Parser OffsetDatetime +parser_DmyHMSz offsetFormat datetimeFormat = + OffsetDatetime + <$> parser_DmyHMS datetimeFormat + <*> parserOffset offsetFormat + +{- | Given an 'OffsetFormat', a 'MeridiemLocale', a + 'SubsecondPrecision', and a 'DatetimeFormat', construct a 'Text' + 'TB.Builder' corresponding to the Day\/Month\/Year,IMS encoding + of the given 'OffsetDatetime'. +-} +builder_DmyIMS_p_z :: OffsetFormat -> MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> TB.Builder +builder_DmyIMS_p_z offsetFormat meridiemLocale sp datetimeFormat (OffsetDatetime datetime offset) = + builder_DmyIMS_p meridiemLocale sp datetimeFormat datetime + <> " " + <> builderOffset offsetFormat offset + +{- | Given an 'OffsetFormat', a 'SubsecondPrecision', and a + 'DatetimeFormat', construct 'Text' corresponding to the + Day\/Month\/Year,Hour\/Minute\/Second encoding of the given + 'OffsetDatetime'. +-} +encode_DmyHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> Text +encode_DmyHMSz offsetFormat sp datetimeFormat = + LT.toStrict . TB.toLazyText . builder_DmyHMSz offsetFormat sp datetimeFormat + +{- | Construct a 'Text' 'TB.Builder' corresponding to the w3c-formatting + of the given 'OffsetDatetime'. +-} +builderW3Cz :: OffsetDatetime -> TB.Builder +builderW3Cz = + builder_YmdHMSz + OffsetFormatColonOn + SubsecondPrecisionAuto + (DatetimeFormat (Just '-') (Just 'T') (Just ':')) + +-- | Encode an 'Offset' to 'Text' using the given 'OffsetFormat'. +encodeOffset :: OffsetFormat -> Offset -> Text +encodeOffset fmt = LT.toStrict . TB.toLazyText . builderOffset fmt + +{- | Construct a 'TB.Builder' corresponding to the given 'Offset' + encoded using the given 'OffsetFormat'. +-} +builderOffset :: OffsetFormat -> Offset -> TB.Builder +builderOffset x = case x of + OffsetFormatColonOff -> builderOffset_z + OffsetFormatColonOn -> builderOffset_z1 + OffsetFormatSecondsPrecision -> builderOffset_z2 + OffsetFormatColonAuto -> builderOffset_z3 + +{- | Decode an 'Offset' from 'Text' that was encoded + using the given 'OffsetFormat'. +-} +decodeOffset :: OffsetFormat -> Text -> Maybe Offset +decodeOffset fmt = + either (const Nothing) Just . AT.parseOnly (parserOffset fmt <* AT.endOfInput) + +-- | Parse an 'Offset' that was encoded using the given 'OffsetFormat'. +parserOffset :: OffsetFormat -> Parser Offset +parserOffset x = case x of + OffsetFormatColonOff -> parserOffset_z + OffsetFormatColonOn -> parserOffset_z1 + OffsetFormatSecondsPrecision -> parserOffset_z2 + OffsetFormatColonAuto -> parserOffset_z3 + +-- | True means positive, false means negative +parseSignedness :: Parser Bool +parseSignedness = do + c <- AT.anyChar + if c == '-' + then pure False + else + if c == '+' + then pure True + else fail "while parsing offset, expected [+] or [-]" + +parserOffset_z :: Parser Offset +parserOffset_z = do + pos <- parseSignedness + h <- parseFixedDigits 2 + m <- parseFixedDigits 2 + let !res = h * 60 + m + pure . Offset $ + if pos + then res + else negate res + +parserOffset_z1 :: Parser Offset +parserOffset_z1 = do + pos <- parseSignedness + h <- parseFixedDigits 2 + _ <- AT.char ':' + m <- parseFixedDigits 2 + let !res = h * 60 + m + pure . Offset $ + if pos + then res + else negate res + +parserOffset_z2 :: AT.Parser Offset +parserOffset_z2 = do + pos <- parseSignedness + h <- parseFixedDigits 2 + _ <- AT.char ':' + m <- parseFixedDigits 2 + _ <- AT.string ":00" + let !res = h * 60 + m + pure . Offset $ + if pos + then res + else negate res + +{- | This is generous in what it accepts. If you give + something like +04:00 as the offset, it will be + allowed, even though it could be shorter. +-} +parserOffset_z3 :: AT.Parser Offset +parserOffset_z3 = do + pos <- parseSignedness + h <- parseFixedDigits 2 + mc <- AT.peekChar + case mc of + Just ':' -> do + _ <- AT.anyChar -- should be a colon + m <- parseFixedDigits 2 + let !res = h * 60 + m + pure . Offset $ + if pos + then res + else negate res + _ -> + pure . Offset $ + if pos + then h * 60 + else h * (-60) + +builderOffset_z :: Offset -> TB.Builder +builderOffset_z (Offset i) = + let (!a, !b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitTextBuilder a + <> indexTwoDigitTextBuilder b + +builderOffset_z1 :: Offset -> TB.Builder +builderOffset_z1 (Offset i) = + let (!a, !b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitTextBuilder a + <> ":" + <> indexTwoDigitTextBuilder b + +builderOffset_z2 :: Offset -> TB.Builder +builderOffset_z2 (Offset i) = + let (!a, !b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitTextBuilder a + <> ":" + <> indexTwoDigitTextBuilder b + <> ":00" + +builderOffset_z3 :: Offset -> TB.Builder +builderOffset_z3 (Offset i) = + let (!a, !b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in if b == 0 + then + prefix + <> indexTwoDigitTextBuilder a + else + prefix + <> indexTwoDigitTextBuilder a + <> ":" + <> indexTwoDigitTextBuilder b + +{- | Given an 'OffsetFormat', a 'SubsecondPrecision', and a + 'DatetimeFormat', construct a 'ByteString' 'BB.Builder' + corresponding to the Year\/Month\/Day,Hour\/Minute\/Second + encoding of the given 'OffsetDatetime'. +-} +builderUtf8_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> BB.Builder +builderUtf8_YmdHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = + builderUtf8_YmdHMS sp datetimeFormat datetime + <> builderOffsetUtf8 offsetFormat offset + +{- | Parse a Year\/Month\/Day,Hour\/Minute\/Second-encoded 'OffsetDatetime' + that was encoded using the given 'OffsetFormat' and + 'DatetimeFormat'. +-} +parserUtf8_YmdHMSz :: OffsetFormat -> DatetimeFormat -> AB.Parser OffsetDatetime +parserUtf8_YmdHMSz offsetFormat datetimeFormat = + OffsetDatetime + <$> parserUtf8_YmdHMS datetimeFormat + <*> parserOffsetUtf8 offsetFormat + +{- | Given an 'OffsetFormat', a 'MeridiemLocale, a 'SubsecondPrecision', + and a 'DatetimeFormat', construct a 'ByteString' 'BB.Builder' + corresponding to a Year\/Month\/Day,IMS-encoded 'OffsetDatetime'. +-} +builderUtf8_YmdIMS_p_z :: OffsetFormat -> MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> BB.Builder +builderUtf8_YmdIMS_p_z offsetFormat meridiemLocale sp datetimeFormat (OffsetDatetime datetime offset) = + builderUtf8_YmdIMS_p meridiemLocale sp datetimeFormat datetime + <> " " + <> builderOffsetUtf8 offsetFormat offset + +{- | Construct a 'ByteString' 'BB.Builder' corresponding to the W3C + encoding of the given 'Datetime'. +-} +builderUtf8W3Cz :: OffsetDatetime -> BB.Builder +builderUtf8W3Cz = + builderUtf8_YmdHMSz + OffsetFormatColonOn + SubsecondPrecisionAuto + (DatetimeFormat (Just '-') (Just 'T') (Just ':')) + +-- | Encode an 'Offset' as a 'ByteString' using the given 'OffsetFormat'. +encodeOffsetUtf8 :: OffsetFormat -> Offset -> ByteString +encodeOffsetUtf8 fmt = LB.toStrict . BB.toLazyByteString . builderOffsetUtf8 fmt + +{- | Decode an 'Offset' from a 'ByteString' that was encoded using the given + 'OffsetFormat'. +-} +decodeOffsetUtf8 :: OffsetFormat -> ByteString -> Maybe Offset +decodeOffsetUtf8 fmt = + either (const Nothing) Just . AB.parseOnly (parserOffsetUtf8 fmt) + +{- | Construct a 'ByteString' 'BB.Builder' corresponding to the + encoding of an 'Offset' using the given 'OffsetFormat'. +-} +builderOffsetUtf8 :: OffsetFormat -> Offset -> BB.Builder +builderOffsetUtf8 x = case x of + OffsetFormatColonOff -> builderOffsetUtf8_z + OffsetFormatColonOn -> builderOffsetUtf8_z1 + OffsetFormatSecondsPrecision -> builderOffsetUtf8_z2 + OffsetFormatColonAuto -> builderOffsetUtf8_z3 + +{- | Parse an 'Offset' that was encoded using the given + 'OffsetFormat'. +-} +parserOffsetUtf8 :: OffsetFormat -> AB.Parser Offset +parserOffsetUtf8 x = case x of + OffsetFormatColonOff -> parserOffsetUtf8_z + OffsetFormatColonOn -> parserOffsetUtf8_z1 + OffsetFormatSecondsPrecision -> parserOffsetUtf8_z2 + OffsetFormatColonAuto -> parserOffsetUtf8_z3 + +-- | True means positive, false means negative +parseSignednessUtf8 :: AB.Parser Bool +parseSignednessUtf8 = do + c <- AB.anyChar + if c == '-' + then pure False + else + if c == '+' + then pure True + else fail "while parsing offset, expected [+] or [-]" + +parserOffsetUtf8_z :: AB.Parser Offset +parserOffsetUtf8_z = do + pos <- parseSignednessUtf8 + h <- parseFixedDigitsIntBS 2 + m <- parseFixedDigitsIntBS 2 + let !res = h * 60 + m + pure . Offset $ + if pos + then res + else negate res + +parserOffsetUtf8_z1 :: AB.Parser Offset +parserOffsetUtf8_z1 = do + pos <- parseSignednessUtf8 + h <- parseFixedDigitsIntBS 2 + _ <- AB.char ':' + m <- parseFixedDigitsIntBS 2 + let !res = h * 60 + m + pure . Offset $ + if pos + then res + else negate res + +parserOffsetUtf8_z2 :: AB.Parser Offset +parserOffsetUtf8_z2 = do + pos <- parseSignednessUtf8 + h <- parseFixedDigitsIntBS 2 + _ <- AB.char ':' + m <- parseFixedDigitsIntBS 2 + _ <- AB.string ":00" + let !res = h * 60 + m + pure . Offset $ + if pos + then res + else negate res + +{- | This is generous in what it accepts. If you give + something like +04:00 as the offset, it will be + allowed, even though it could be shorter. +-} +parserOffsetUtf8_z3 :: AB.Parser Offset +parserOffsetUtf8_z3 = do + pos <- parseSignednessUtf8 + h <- parseFixedDigitsIntBS 2 + mc <- AB.peekChar + case mc of + Just ':' -> do + _ <- AB.anyChar -- should be a colon + m <- parseFixedDigitsIntBS 2 + let !res = h * 60 + m + pure . Offset $ + if pos + then res + else negate res + _ -> + pure . Offset $ + if pos + then h * 60 + else h * (-60) + +builderOffsetUtf8_z :: Offset -> BB.Builder +builderOffsetUtf8_z (Offset i) = + let (!a, !b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitByteStringBuilder a + <> indexTwoDigitByteStringBuilder b + +builderOffsetUtf8_z1 :: Offset -> BB.Builder +builderOffsetUtf8_z1 (Offset i) = + let (!a, !b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitByteStringBuilder a + <> ":" + <> indexTwoDigitByteStringBuilder b + +builderOffsetUtf8_z2 :: Offset -> BB.Builder +builderOffsetUtf8_z2 (Offset i) = + let (!a, !b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitByteStringBuilder a + <> ":" + <> indexTwoDigitByteStringBuilder b + <> ":00" + +builderOffsetUtf8_z3 :: Offset -> BB.Builder +builderOffsetUtf8_z3 (Offset i) = + let (!a, !b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in if b == 0 + then + prefix + <> indexTwoDigitByteStringBuilder a + else + prefix + <> indexTwoDigitByteStringBuilder a + <> ":" + <> indexTwoDigitByteStringBuilder b + +-- Zepto parsers + +{- | Parse a 'Datetime' that was encoded using the + given 'DatetimeFormat'. +-} +zeptoUtf8_YmdHMS :: DatetimeFormat -> Z.Parser Datetime +zeptoUtf8_YmdHMS (DatetimeFormat mdateSep msep' mtimeSep) = do + date <- zeptoUtf8_Ymd mdateSep + let msep = BC.singleton <$> msep' + traverse_ Z.string msep + time <- zeptoUtf8_HMS mtimeSep + pure (Datetime date time) + +zeptoCountZeroes :: Z.Parser Int +zeptoCountZeroes = do + bs <- Z.takeWhile (0x30 ==) + pure $! BC.length bs + +{- | Parse a 'Date' that was encoded using + the given separator. +-} +zeptoUtf8_Ymd :: Maybe Char -> Z.Parser Date +zeptoUtf8_Ymd msep' = do + y <- zeptoFixedDigitsIntBS 4 + let msep = BC.singleton <$> msep' + traverse_ Z.string msep + m <- zeptoFixedDigitsIntBS 2 + when (m < 1 || m > 12) (fail "month must be between 1 and 12") + traverse_ Z.string msep + d <- zeptoFixedDigitsIntBS 2 + when (d < 1 || d > 31) (fail "day must be between 1 and 31") + pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +{- | Parse a 'TimeOfDay' that was encoded using + the given separator. +-} +zeptoUtf8_HMS :: Maybe Char -> Z.Parser TimeOfDay +zeptoUtf8_HMS msep' = do + h <- zeptoFixedDigitsIntBS 2 + when (h > 23) (fail "hour must be between 0 and 23") + let msep = BC.singleton <$> msep' + traverse_ Z.string msep + m <- zeptoFixedDigitsIntBS 2 + when (m > 59) (fail "minute must be between 0 and 59") + traverse_ Z.string msep + ns <- zeptoSecondsAndNanosecondsUtf8 + pure (TimeOfDay h m ns) + +zeptoFixedDigitsIntBS :: Int -> Z.Parser Int +zeptoFixedDigitsIntBS n = do + t <- Z.take n + case BC.readInt t of + Nothing -> fail "datetime decoding could not parse integral bytestring (a)" + Just (i, r) -> + if BC.null r + then pure i + else fail "datetime decoding could not parse integral bytestring (b)" + +zeptoSecondsAndNanosecondsUtf8 :: Z.Parser Int64 +zeptoSecondsAndNanosecondsUtf8 = do + s' <- zeptoFixedDigitsIntBS 2 + let s = fromIntegral s' :: Int64 + when (s > 60) (fail "seconds must be between 0 and 60") + nanoseconds <- + ( do + _ <- Z.string "." + numberOfZeroes <- zeptoCountZeroes + x <- zdecimal + 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 (s * 1000000000 + nanoseconds) + +zdecimal :: Z.Parser Int64 +zdecimal = do + digits <- Z.takeWhile wordIsDigit + case BC.readInt digits of + Nothing -> fail "somehow this didn't work" + Just (i, _) -> pure $! fromIntegral i + +wordIsDigit :: Word8 -> Bool +wordIsDigit a = 0x30 <= a && a <= 0x39 + +-- | The 'Month' of January. +january :: Month +january = Month 0 + +-- | The 'Month' of February. +february :: Month +february = Month 1 + +-- | The 'Month' of March. +march :: Month +march = Month 2 + +-- | The 'Month' of April. +april :: Month +april = Month 3 + +-- | The 'Month' of May. +may :: Month +may = Month 4 + +-- | The 'Month' of June. +june :: Month +june = Month 5 + +-- | The 'Month' of July. +july :: Month +july = Month 6 + +-- | The 'Month' of August. +august :: Month +august = Month 7 + +-- | The 'Month' of September. +september :: Month +september = Month 8 + +-- | The 'Month' of October. +october :: Month +october = Month 9 + +-- | The 'Month' of November. +november :: Month +november = Month 10 + +-- | The 'Month' of December. +december :: Month +december = Month 11 + +-- | The 'DayOfWeek' Sunday. +sunday :: DayOfWeek +sunday = DayOfWeek 0 + +-- | The 'DayOfWeek' Monday. +monday :: DayOfWeek +monday = DayOfWeek 1 + +-- | The 'DayOfWeek' Tuesday. +tuesday :: DayOfWeek +tuesday = DayOfWeek 2 + +-- | The 'DayOfWeek' Wednesday. +wednesday :: DayOfWeek +wednesday = DayOfWeek 3 + +-- | The 'DayOfWeek' Thursday. +thursday :: DayOfWeek +thursday = DayOfWeek 4 + +-- | The 'DayOfWeek' Friday. +friday :: DayOfWeek +friday = DayOfWeek 5 + +-- | The 'DayOfWeek' Saturday. +saturday :: DayOfWeek +saturday = DayOfWeek 6 + +countDigits :: (Integral a) => a -> Int +countDigits v0 + | fromIntegral v64 == v0 = go 1 v64 + | otherwise = goBig 1 (fromIntegral v0) + where + v64 = fromIntegral v0 + goBig !k (v :: Integer) + | v > big = goBig (k + 19) (v `quot` big) + | otherwise = go k (fromIntegral v) + big = 10000000000000000000 + go !k (v :: Word64) + | v < 10 = k + | v < 100 = k + 1 + | v < 1000 = k + 2 + | v < 1000000000000 = + k + + if v < 100000000 + then + if v < 1000000 + then + if v < 10000 + then 3 + else 4 + fin v 100000 + else 6 + fin v 10000000 + else + if v < 10000000000 + then 8 + fin v 1000000000 + else 10 + fin v 100000000000 + | otherwise = go (k + 12) (v `quot` 1000000000000) + fin v n = if v >= n then 1 else 0 + +clip :: (Ord t) => t -> t -> t -> t +clip a _ x | x < a = a +clip _ b x | x > b = b +clip _ _ x = x + +parseFixedDigits :: Int -> AT.Parser Int +parseFixedDigits n = do + t <- AT.take n + case Text.decimal t of + Left err -> fail err + Right (i, r) -> + if Text.null r + then pure i + else fail "datetime decoding could not parse integral text" + +parseFixedDigitsIntBS :: Int -> AB.Parser Int +parseFixedDigitsIntBS n = do + t <- AB.take n + case BC.readInt t of + Nothing -> fail "datetime decoding could not parse integral bytestring (a)" + Just (i, r) -> + if BC.null r + then pure i + else fail "datetime decoding could not parse integral bytestring (b)" + +-- Only provide positive numbers to this function. +indexTwoDigitTextBuilder :: Int -> TB.Builder +indexTwoDigitTextBuilder i = + if i < 100 + then Vector.unsafeIndex twoDigitTextBuilder (fromIntegral i) + else TB.decimal i + +-- | Only provide positive numbers to this function. +indexTwoDigitByteStringBuilder :: Int -> BB.Builder +indexTwoDigitByteStringBuilder i = + if i < 100 + then Vector.unsafeIndex twoDigitByteStringBuilder (fromIntegral i) + else BB.intDec i + +twoDigitByteStringBuilder :: Vector BB.Builder +twoDigitByteStringBuilder = + Vector.fromList $ + map (BB.byteString . BC.pack) twoDigitStrings +{-# NOINLINE twoDigitByteStringBuilder #-} + +twoDigitTextBuilder :: Vector TB.Builder +twoDigitTextBuilder = + Vector.fromList $ + map (TB.fromText . Text.pack) twoDigitStrings +{-# NOINLINE twoDigitTextBuilder #-} + +twoDigitStrings :: [String] +twoDigitStrings = + [ "00" + , "01" + , "02" + , "03" + , "04" + , "05" + , "06" + , "07" + , "08" + , "09" + , "10" + , "11" + , "12" + , "13" + , "14" + , "15" + , "16" + , "17" + , "18" + , "19" + , "20" + , "21" + , "22" + , "23" + , "24" + , "25" + , "26" + , "27" + , "28" + , "29" + , "30" + , "31" + , "32" + , "33" + , "34" + , "35" + , "36" + , "37" + , "38" + , "39" + , "40" + , "41" + , "42" + , "43" + , "44" + , "45" + , "46" + , "47" + , "48" + , "49" + , "50" + , "51" + , "52" + , "53" + , "54" + , "55" + , "56" + , "57" + , "58" + , "59" + , "60" + , "61" + , "62" + , "63" + , "64" + , "65" + , "66" + , "67" + , "68" + , "69" + , "70" + , "71" + , "72" + , "73" + , "74" + , "75" + , "76" + , "77" + , "78" + , "79" + , "80" + , "81" + , "82" + , "83" + , "84" + , "85" + , "86" + , "87" + , "88" + , "89" + , "90" + , "91" + , "92" + , "93" + , "94" + , "95" + , "96" + , "97" + , "98" + , "99" + ] + +raiseTenTo :: Int -> Int64 +raiseTenTo i = + if i > 15 + then 10 ^ i + else UVector.unsafeIndex tenRaisedToSmallPowers i + +tenRaisedToSmallPowers :: UVector.Vector Int64 +tenRaisedToSmallPowers = UVector.fromList $ map (10 ^) [0 :: Int .. 15] + +yearToZeroPaddedDigit :: Year -> TB.Builder +yearToZeroPaddedDigit (Year x) + | x < 10 = "000" <> TB.decimal x + | x < 100 = "00" <> TB.decimal x + | x < 1000 = "0" <> TB.decimal x + | otherwise = TB.decimal x + +monthToZeroPaddedDigit :: Month -> TB.Builder +monthToZeroPaddedDigit (Month x) = + indexTwoDigitTextBuilder (x + 1) + +zeroPadDayOfMonth :: DayOfMonth -> TB.Builder +zeroPadDayOfMonth (DayOfMonth d) = indexTwoDigitTextBuilder d + +yearToZeroPaddedDigitBS :: Year -> BB.Builder +yearToZeroPaddedDigitBS (Year x) + | x < 10 = "000" <> BB.intDec x + | x < 100 = "00" <> BB.intDec x + | x < 1000 = "0" <> BB.intDec x + | otherwise = BB.intDec x + +monthToZeroPaddedDigitBS :: Month -> BB.Builder +monthToZeroPaddedDigitBS (Month x) = + indexTwoDigitByteStringBuilder (x + 1) + +zeroPadDayOfMonthBS :: DayOfMonth -> BB.Builder +zeroPadDayOfMonthBS (DayOfMonth d) = indexTwoDigitByteStringBuilder d + +-- | Is the given 'Time' within the 'TimeInterval'? +within :: Time -> TimeInterval -> Bool +t `within` (TimeInterval t0 t1) = t >= t0 && t <= t1 + +-- | Convert a 'TimeInterval' to a 'Timespan'. This is equivalent to 'width'. +timeIntervalToTimespan :: TimeInterval -> Timespan +timeIntervalToTimespan = width + +{- | The 'TimeInterval' that covers the entire range of 'Time's that Chronos supports. + + prop> \(t :: Time) -> within t whole +-} +whole :: TimeInterval +whole = TimeInterval minBound maxBound + +-- | The singleton (degenerate) 'TimeInterval'. +singleton :: Time -> TimeInterval +singleton x = TimeInterval x x + +-- | Get the lower bound of the 'TimeInterval'. +lowerBound :: TimeInterval -> Time +lowerBound (TimeInterval t0 _) = t0 + +-- | Get the upper bound of the 'TimeInterval'. +upperBound :: TimeInterval -> Time +upperBound (TimeInterval _ t1) = t1 + +-- | The width of the 'TimeInterval'. This is equivalent to 'timeIntervalToTimespan'. +width :: TimeInterval -> Timespan +width (TimeInterval x y) = difference y x + +{- | A smart constructor for 'TimeInterval'. In general, you should prefer using this + over the 'TimeInterval' constructor, since it maintains the invariant that + @'lowerBound' interval '<=' 'upperBound' interval@. +-} +timeIntervalBuilder :: Time -> Time -> TimeInterval +timeIntervalBuilder x y = case compare x y of + GT -> TimeInterval y x + _ -> TimeInterval x y + +infix 3 ... + +-- | An infix 'timeIntervalBuilder'. +(...) :: Time -> Time -> TimeInterval +(...) = timeIntervalBuilder + +{- | A day represented as the modified Julian date, the number of days + since midnight on November 17, 1858. +-} +newtype Day = Day {getDay :: Int} + deriving (Show, Read, Eq, Ord, Hashable, Enum, ToJSON, FromJSON, Storable, Prim, NFData) + +instance Torsor Day Int where + add i (Day d) = Day (d + i) + difference (Day a) (Day b) = a - b + +-- | a lens for accessing the `getDay` field. +_getDay :: (Functor f) => (Int -> f Int) -> Day -> f Day +_getDay f = fmap Day . f . getDay + +-- | The day of the week. +newtype DayOfWeek = DayOfWeek {getDayOfWeek :: Int} + deriving (Show, Read, Eq, Ord, Hashable, NFData) + +-- | a lens for accessing the `getDayOfWeek` field. +_getDayOfWeek :: (Functor f) => (Int -> f Int) -> DayOfWeek -> f DayOfWeek +_getDayOfWeek f = fmap DayOfWeek . f . getDayOfWeek + +-- | The day of the month. +newtype DayOfMonth = DayOfMonth {getDayOfMonth :: Int} + deriving (Show, Read, Eq, Ord, Prim, Enum, NFData) + +-- | a lens for accessing the `getDayOfMonth` field. +_getDayOfMonth :: (Functor f) => (Int -> f Int) -> DayOfMonth -> f DayOfMonth +_getDayOfMonth f = fmap DayOfMonth . f . getDayOfMonth + +-- | The day of the year. +newtype DayOfYear = DayOfYear {getDayOfYear :: Int} + deriving (Show, Read, Eq, Ord, Prim, NFData) + +-- | a lens for accessing the `getDayOfYear` field. +_getDayOfYear :: (Functor f) => (Int -> f Int) -> DayOfYear -> f DayOfYear +_getDayOfYear f = fmap DayOfYear . f . getDayOfYear + +-- | The month of the year. +newtype Month = Month {getMonth :: Int} + deriving (Show, Read, Eq, Ord, Prim, NFData) + +-- | a lens for accessing the `getMonth` field. +_getMonth :: (Functor f) => (Int -> f Int) -> Month -> f Month +_getMonth f = fmap Month . f . getMonth + +instance Enum Month where + fromEnum = getMonth + toEnum = Month + succ (Month x) = + if x < 11 + then Month (x + 1) + else error "Enum.succ{Month}: tried to take succ of December" + pred (Month x) = + if x > 0 + then Month (x - 1) + else error "Enum.pred{Month}: tried to take pred of January" + enumFrom x = enumFromTo x (Month 11) + +-- | 'Month' starts at 0 and ends at 11 (January to December) +instance Bounded Month where + minBound = Month 0 + maxBound = Month 11 + +{- | The number of years elapsed since the beginning + of the Common Era. +-} +newtype Year = Year {getYear :: Int} + deriving (Show, Read, Eq, Ord, NFData) + +-- | a lens for accessing the `getYear` field. +_getYear :: (Functor f) => (Int -> f Int) -> Year -> f Year +_getYear f = fmap Year . f . getYear + +-- | A in minutes. +newtype Offset = Offset {getOffset :: Int} + deriving (Show, Read, Eq, Ord, Enum, NFData) + +-- | a lens for accessing the `getOffset` field. +_getOffset :: (Functor f) => (Int -> f Int) -> Offset -> f Offset +_getOffset f = fmap Offset . f . getOffset + +-- | POSIX time with nanosecond resolution. +newtype Time = Time {getTime :: Int64} + deriving (FromJSON, ToJSON, Hashable, Eq, Ord, Show, Read, Storable, Prim, Bounded, NFData) + +-- | a lens for accessing the `getTime` field. +_getTime :: (Functor f) => (Int64 -> f Int64) -> Time -> f Time +_getTime f = fmap Time . f . getTime + +{- | Match a 'DayOfWeek'. By `match`, we mean that a 'DayOfWeekMatch' + is a mapping from the integer value of a 'DayOfWeek' to some value + of type @a@. You should construct a 'DayOfWeekMatch' with + 'buildDayOfWeekMatch', and match it using 'caseDayOfWeek'. +-} +newtype DayOfWeekMatch a = DayOfWeekMatch {getDayOfWeekMatch :: Vector a} + deriving (NFData) + +{- | Match a 'Month'. By `match`, we mean that a 'MonthMatch' is + a mapping from the integer value of a 'Month' to some value of + type @a@. You should construct a 'MonthMatch' with + 'buildMonthMatch', and match it using 'caseMonth'. +-} +newtype MonthMatch a = MonthMatch {getMonthMatch :: Vector a} + deriving (NFData) + +{- | Like 'MonthMatch', but the matched value can have an instance of + 'UVector.Unbox'. +-} +newtype UnboxedMonthMatch a = UnboxedMonthMatch {getUnboxedMonthMatch :: UVector.Vector a} + deriving (NFData) + +{- | A timespan. This is represented internally as a number + of nanoseconds. +-} +newtype Timespan = Timespan {getTimespan :: Int64} + deriving (Show, Read, Eq, Ord, ToJSON, FromJSON, Additive, NFData) + +-- | a lens for accessing the `getTimespan` field. +_getTimespan :: (Functor f) => (Int64 -> f Int64) -> Timespan -> f Timespan +_getTimespan f = fmap Timespan . f . getTimespan + +instance Semigroup Timespan where + (Timespan a) <> (Timespan b) = Timespan (a + b) + +instance Monoid Timespan where + mempty = Timespan 0 + mappend = (SG.<>) + +instance Torsor Time Timespan where + add (Timespan ts) (Time t) = Time (t + ts) + difference (Time t) (Time s) = Timespan (t - s) + +instance Scaling Timespan Int64 where + scale i (Timespan ts) = Timespan (i * ts) + +instance Torsor Offset Int where + add i (Offset x) = Offset (x + i) + difference (Offset x) (Offset y) = x - y + +-- | The precision used when encoding seconds to a human-readable format. +data SubsecondPrecision + = -- | Rounds to second, millisecond, microsecond, or nanosecond + SubsecondPrecisionAuto + | -- | Specify number of places after decimal + SubsecondPrecisionFixed {-# UNPACK #-} !Int + deriving (Eq, Ord, Show, Read) + +instance NFData SubsecondPrecision where + rnf (SubsecondPrecisionAuto) = () + rnf (SubsecondPrecisionFixed a) = a `deepseq` () + +-- | A date as represented by the Gregorian calendar. +data Date = Date + { dateYear :: {-# UNPACK #-} !Year + , dateMonth :: {-# UNPACK #-} !Month + , dateDay :: {-# UNPACK #-} !DayOfMonth + } + deriving (Show, Read, Eq, Ord) + +instance NFData Date where + rnf (Date y m d) = y `deepseq` m `deepseq` d `deepseq` () + +-- | a lens for accessing the `dateYear` field. +_dateYear :: (Functor f) => (Year -> f Year) -> Date -> f Date +_dateYear f date = fmap (\y -> date {dateYear = y}) . f . dateYear $ date + +-- | a lens for accessing the `dateMonth` field. +_dateMonth :: (Functor f) => (Month -> f Month) -> Date -> f Date +_dateMonth f date = fmap (\m -> date {dateMonth = m}) . f . dateMonth $ date + +-- | a lens for accessing the `dateDay` field. +_dateDay :: (Functor f) => (DayOfMonth -> f DayOfMonth) -> Date -> f Date +_dateDay f date = fmap (\d -> date {dateDay = d}) . f . dateDay $ date + +{- | An 'OrdinalDate' is a 'Year' and the number of days elapsed + since the 'Year' began. +-} +data OrdinalDate = OrdinalDate + { ordinalDateYear :: {-# UNPACK #-} !Year + , ordinalDateDayOfYear :: {-# UNPACK #-} !DayOfYear + } + deriving (Show, Read, Eq, Ord) + +instance NFData OrdinalDate where + rnf (OrdinalDate y d) = y `deepseq` d `deepseq` () + +-- | a lens for accessing the `ordinalDateYear` field. +_ordinalDateYear :: (Functor f) => (Year -> f Year) -> OrdinalDate -> f OrdinalDate +_ordinalDateYear f date = fmap (\y -> date {ordinalDateYear = y}) . f . ordinalDateYear $ date + +-- | a lens for accessing the `ordinalDateDayOfYear` field. +_ordinalDateDayOfYear :: (Functor f) => (DayOfYear -> f DayOfYear) -> OrdinalDate -> f OrdinalDate +_ordinalDateDayOfYear f date = + fmap (\d -> date {ordinalDateDayOfYear = d}) . f . ordinalDateDayOfYear $ date + +{- | A month and the day of the month. This does not actually represent + a specific date, since this recurs every year. +-} +data MonthDate = MonthDate + { monthDateMonth :: {-# UNPACK #-} !Month + , monthDateDay :: {-# UNPACK #-} !DayOfMonth + } + deriving (Show, Read, Eq, Ord) + +instance NFData MonthDate where + rnf (MonthDate m d) = m `deepseq` d `deepseq` () + +-- | a lens for accessing the `monthDateMonth` field. +_monthDateMonth :: (Functor f) => (Month -> f Month) -> MonthDate -> f MonthDate +_monthDateMonth f date = fmap (\m -> date {monthDateMonth = m}) . f . monthDateMonth $ date + +-- | a lens for accessing the `monthDateDay` field. +_monthDateDay :: (Functor f) => (DayOfMonth -> f DayOfMonth) -> MonthDate -> f MonthDate +_monthDateDay f date = fmap (\d -> date {monthDateDay = d}) . f . monthDateDay $ date + +{- | A 'Date' as represented by the Gregorian calendar + and a 'TimeOfDay'. + While the 'ToJSON' instance encodes with a hyphen separator, the + 'FromJSON' instance allows any non-digit character to act as + separator, using the lenient parser. +-} +data Datetime = Datetime + { datetimeDate :: {-# UNPACK #-} !Date + , datetimeTime :: {-# UNPACK #-} !TimeOfDay + } + deriving (Show, Read, Eq, Ord) + +instance NFData Datetime where + rnf (Datetime d t) = d `deepseq` t `deepseq` () + +-- | a lens for accessing the `datetimeDate` field. +_datetimeDate :: (Functor f) => (Date -> f Date) -> Datetime -> f Datetime +_datetimeDate f date = fmap (\y -> date {datetimeDate = y}) . f . datetimeDate $ date + +-- | a lens for accessing the `datetimeTime` field. +_datetimeTime :: (Functor f) => (TimeOfDay -> f TimeOfDay) -> Datetime -> f Datetime +_datetimeTime f date = fmap (\t -> date {datetimeTime = t}) . f . datetimeTime $ date + +-- | A 'Datetime' with a time zone 'Offset'. +data OffsetDatetime = OffsetDatetime + { offsetDatetimeDatetime :: {-# UNPACK #-} !Datetime + , offsetDatetimeOffset :: {-# UNPACK #-} !Offset + } + deriving (Show, Read, Eq, Ord) + +instance NFData OffsetDatetime where + rnf (OffsetDatetime dt o) = dt `deepseq` o `deepseq` () + +-- | a lens for accessing the `offsetDatetimeDatetime` field. +_offsetDatetimeDatetime :: + (Functor f) => (Datetime -> f Datetime) -> OffsetDatetime -> f OffsetDatetime +_offsetDatetimeDatetime f date = + fmap (\d -> date {offsetDatetimeDatetime = d}) . f . offsetDatetimeDatetime $ date + +-- | a lens for accessing the `offsetDatetimeOffset` field. +_offsetDatetimeOffset :: + (Functor f) => (Offset -> f Offset) -> OffsetDatetime -> f OffsetDatetime +_offsetDatetimeOffset f date = + fmap (\y -> date {offsetDatetimeOffset = y}) . f . offsetDatetimeOffset $ date + +-- | A time of day with nanosecond resolution. +data TimeOfDay = TimeOfDay + { timeOfDayHour :: {-# UNPACK #-} !Int + , timeOfDayMinute :: {-# UNPACK #-} !Int + , timeOfDayNanoseconds :: {-# UNPACK #-} !Int64 + } + deriving (Show, Read, Eq, Ord) + +instance NFData TimeOfDay where + rnf (TimeOfDay h m s) = h `deepseq` m `deepseq` s `deepseq` () + +-- | a lens for accessing the `timeOfDayHour` field. +_timeOfDayHour :: + (Functor f) => (Int -> f Int) -> TimeOfDay -> f TimeOfDay +_timeOfDayHour f time = + fmap (\h -> time {timeOfDayHour = h}) . f . timeOfDayHour $ time + +-- | a lens for accessing the `timeOfDayMinute` field. +_timeOfDayMinute :: + (Functor f) => (Int -> f Int) -> TimeOfDay -> f TimeOfDay +_timeOfDayMinute f time = + fmap (\m -> time {timeOfDayMinute = m}) . f . timeOfDayMinute $ time + +-- | a lens for accessing the `timeOfDayNanoseconds` field. +_timeOfDayNanoseconds :: + (Functor f) => (Int64 -> f Int64) -> TimeOfDay -> f TimeOfDay +_timeOfDayNanoseconds f time = + fmap (\n -> time {timeOfDayNanoseconds = n}) . f . timeOfDayNanoseconds $ time + +{- | The format of a 'Datetime'. In particular + this provides separators for parts of the 'Datetime' + and nothing else. +-} +data DatetimeFormat = DatetimeFormat + { datetimeFormatDateSeparator :: !(Maybe Char) + -- ^ Separator in the date + , datetimeFormatSeparator :: !(Maybe Char) + -- ^ Separator between date and time + , datetimeFormatTimeSeparator :: !(Maybe Char) + -- ^ Separator in the time + } + deriving (Show, Read, Eq, Ord) + +instance NFData DatetimeFormat where + rnf (DatetimeFormat s1 s2 s3) = s1 `deepseq` s2 `deepseq` s3 `deepseq` () + +-- | Formatting settings for a timezone offset. +data OffsetFormat + = -- | @%z@ (e.g., -0400) + OffsetFormatColonOff + | -- | @%:z@ (e.g., -04:00) + OffsetFormatColonOn + | -- | @%::z@ (e.g., -04:00:00) + OffsetFormatSecondsPrecision + | -- | @%:::z@ (e.g., -04, +05:30) + OffsetFormatColonAuto + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) + +instance NFData OffsetFormat where + rnf !_ = () + +{- | Locale-specific formatting for weekdays and months. The + type variable will likely be instantiated to @Text@ + or @ByteString@. +-} +data DatetimeLocale a = DatetimeLocale + { datetimeLocaleDaysOfWeekFull :: !(DayOfWeekMatch a) + -- ^ full weekdays starting with Sunday, 7 elements + , datetimeLocaleDaysOfWeekAbbreviated :: !(DayOfWeekMatch a) + -- ^ abbreviated weekdays starting with Sunday, 7 elements + , datetimeLocaleMonthsFull :: !(MonthMatch a) + -- ^ full months starting with January, 12 elements + , datetimeLocaleMonthsAbbreviated :: !(MonthMatch a) + -- ^ abbreviated months starting with January, 12 elements + } + +instance (NFData a) => NFData (DatetimeLocale a) where + rnf (DatetimeLocale d1 d2 m1 m2) = + d1 `deepseq` d2 `deepseq` m1 `deepseq` m2 `deepseq` () + +{- | A TimeInterval represents a start and end time. + It can sometimes be more ergonomic than the 'Torsor' API when + you only care about whether or not a 'Time' is within a certain range. + + To construct a 'TimeInterval', it is best to use 'timeIntervalBuilder', + which maintains the invariant that @'lowerBound' interval '<=' 'upperBound' interval@ + (all functions that act on 'TimeInterval's assume this invariant). +-} +data TimeInterval = TimeInterval {-# UNPACK #-} !Time {-# UNPACK #-} !Time + deriving (Read, Show, Eq, Ord, Bounded) + +instance NFData TimeInterval where + rnf (TimeInterval t1 t2) = t1 `deepseq` t2 `deepseq` () + +-- | Locale-specific formatting for AM and PM. +data MeridiemLocale a = MeridiemLocale + { meridiemLocaleAm :: !a + , meridiemLocalePm :: !a + } + deriving (Read, Show, Eq, Ord) + +instance (NFData a) => NFData (MeridiemLocale a) where + rnf (MeridiemLocale am pm) = am `deepseq` pm `deepseq` () + +newtype instance UVector.MVector s Month = MV_Month (PVector.MVector s Month) +newtype instance UVector.Vector Month = V_Month (PVector.Vector Month) + +instance UVector.Unbox Month + +instance MGVector.MVector UVector.MVector Month where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicInitialize #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeGrow #-} + basicLength (MV_Month v) = MGVector.basicLength v + basicUnsafeSlice i n (MV_Month v) = MV_Month $ MGVector.basicUnsafeSlice i n v + basicOverlaps (MV_Month v1) (MV_Month v2) = MGVector.basicOverlaps v1 v2 + basicUnsafeNew n = MV_Month `liftM` MGVector.basicUnsafeNew n + basicInitialize (MV_Month v) = MGVector.basicInitialize v + basicUnsafeReplicate n x = MV_Month `liftM` MGVector.basicUnsafeReplicate n x + basicUnsafeRead (MV_Month v) i = MGVector.basicUnsafeRead v i + basicUnsafeWrite (MV_Month v) i x = MGVector.basicUnsafeWrite v i x + basicClear (MV_Month v) = MGVector.basicClear v + basicSet (MV_Month v) x = MGVector.basicSet v x + basicUnsafeCopy (MV_Month v1) (MV_Month v2) = MGVector.basicUnsafeCopy v1 v2 + basicUnsafeMove (MV_Month v1) (MV_Month v2) = MGVector.basicUnsafeMove v1 v2 + basicUnsafeGrow (MV_Month v) n = MV_Month `liftM` MGVector.basicUnsafeGrow v n + +instance GVector.Vector UVector.Vector Month where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE elemseq #-} + basicUnsafeFreeze (MV_Month v) = V_Month `liftM` GVector.basicUnsafeFreeze v + basicUnsafeThaw (V_Month v) = MV_Month `liftM` GVector.basicUnsafeThaw v + basicLength (V_Month v) = GVector.basicLength v + basicUnsafeSlice i n (V_Month v) = V_Month $ GVector.basicUnsafeSlice i n v + basicUnsafeIndexM (V_Month v) i = GVector.basicUnsafeIndexM v i + basicUnsafeCopy (MV_Month mv) (V_Month v) = GVector.basicUnsafeCopy mv v + elemseq _ = seq + +newtype instance UVector.MVector s DayOfMonth = MV_DayOfMonth (PVector.MVector s DayOfMonth) +newtype instance UVector.Vector DayOfMonth = V_DayOfMonth (PVector.Vector DayOfMonth) + +instance UVector.Unbox DayOfMonth + +instance MGVector.MVector UVector.MVector DayOfMonth where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicInitialize #-} + {-# INLINE basicUnsafeReplicate #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicClear #-} + {-# INLINE basicSet #-} + {-# INLINE basicUnsafeCopy #-} + {-# INLINE basicUnsafeGrow #-} + basicLength (MV_DayOfMonth v) = MGVector.basicLength v + basicUnsafeSlice i n (MV_DayOfMonth v) = MV_DayOfMonth $ MGVector.basicUnsafeSlice i n v + basicOverlaps (MV_DayOfMonth v1) (MV_DayOfMonth v2) = MGVector.basicOverlaps v1 v2 + basicUnsafeNew n = MV_DayOfMonth `liftM` MGVector.basicUnsafeNew n + basicInitialize (MV_DayOfMonth v) = MGVector.basicInitialize v + basicUnsafeReplicate n x = MV_DayOfMonth `liftM` MGVector.basicUnsafeReplicate n x + basicUnsafeRead (MV_DayOfMonth v) i = MGVector.basicUnsafeRead v i + basicUnsafeWrite (MV_DayOfMonth v) i x = MGVector.basicUnsafeWrite v i x + basicClear (MV_DayOfMonth v) = MGVector.basicClear v + basicSet (MV_DayOfMonth v) x = MGVector.basicSet v x + basicUnsafeCopy (MV_DayOfMonth v1) (MV_DayOfMonth v2) = MGVector.basicUnsafeCopy v1 v2 + basicUnsafeMove (MV_DayOfMonth v1) (MV_DayOfMonth v2) = MGVector.basicUnsafeMove v1 v2 + basicUnsafeGrow (MV_DayOfMonth v) n = MV_DayOfMonth `liftM` MGVector.basicUnsafeGrow v n + +instance GVector.Vector UVector.Vector DayOfMonth where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE elemseq #-} + basicUnsafeFreeze (MV_DayOfMonth v) = V_DayOfMonth `liftM` GVector.basicUnsafeFreeze v + basicUnsafeThaw (V_DayOfMonth v) = MV_DayOfMonth `liftM` GVector.basicUnsafeThaw v + basicLength (V_DayOfMonth v) = GVector.basicLength v + basicUnsafeSlice i n (V_DayOfMonth v) = V_DayOfMonth $ GVector.basicUnsafeSlice i n v + basicUnsafeIndexM (V_DayOfMonth v) i = GVector.basicUnsafeIndexM v i + basicUnsafeCopy (MV_DayOfMonth mv) (V_DayOfMonth v) = GVector.basicUnsafeCopy mv v + elemseq _ = seq + +------------------------ +-- The Torsor and Enum instances for Date and OrdinalDate +-- are both bad. This only causes problems for dates +-- at least a million years in the future. Some of this +-- badness is caused by pragmatism, and some of it is caused by +-- my own laziness. +-- +-- The badness that comes from pragmatism: +-- - Int technically is not a good delta for Date. Date +-- has too many inhabitants. If we subtract the lowest +-- Date from the highest Date, we get something too +-- big to fit in a machine integer. +-- - There is no good way to write fromEnum or toEnum for +-- Date. Again, Date has more inhabitants than Int, so +-- it simply cannot be done. +-- The badness that comes from laziness: +-- - Technically, we should still be able to add deltas to +-- Dates that do not fit in machine integers. We should +-- also be able to correctly subtract Dates to cannot +-- fit in machine integers. +-- - For similar reasons, the Enum functions succ, pred, +-- enumFromThen, enumFromThenTo, etc. could all have +-- better definitions than the default ones currently +-- used. +-- If, for some reason, anyone ever wants to fix the badness +-- that comes from laziness, all +-- you really have to do is define a version of dateToDay, +-- dayToDate, ordinalDateToDay, and dayToOrdinalDate +-- that uses something bigger instead of Day. Maybe something like +-- (Int,Word) or (Int,Word,Word). I'm not exactly sure how +-- big it would need to be to work correctly. Then you could +-- handle deltas of two very far off days correctly, provided +-- that the two days weren't also super far from each other. +-- +------------------------ +instance Torsor Date Int where + add i d = dayToDate (add i (dateToDay d)) + difference a b = difference (dateToDay a) (dateToDay b) + +instance Torsor OrdinalDate Int where + add i d = dayToOrdinalDate (add i (ordinalDateToDay d)) + difference a b = difference (ordinalDateToDay a) (ordinalDateToDay b) + +instance Enum Date where + fromEnum d = fromEnum (dateToDay d) + toEnum i = dayToDate (toEnum i) + +instance Enum OrdinalDate where + fromEnum d = fromEnum (ordinalDateToDay d) + toEnum i = dayToOrdinalDate (toEnum i) + +instance ToJSON Datetime where + toJSON = AE.String . encode_YmdHMS SubsecondPrecisionAuto hyphen + toEncoding x = AEE.unsafeToEncoding (BB.char7 '"' SG.<> builderUtf8_YmdHMS SubsecondPrecisionAuto hyphen x SG.<> BB.char7 '"') + +instance FromJSON Datetime where + parseJSON = + AE.withText "Datetime" aesonParserDatetime + +aesonParserDatetime :: Text -> AET.Parser Datetime +aesonParserDatetime = + either (const (fail "could not parse Datetime")) pure . AT.parseOnly (parser_lenient <* AT.endOfInput) + +instance ToJSON Offset where + toJSON = AE.String . encodeOffset OffsetFormatColonOn + toEncoding x = AEE.unsafeToEncoding (BB.char7 '"' SG.<> builderOffsetUtf8 OffsetFormatColonOn x SG.<> BB.char7 '"') + +instance FromJSON Offset where + parseJSON = AE.withText "Offset" aesonParserOffset + +instance ToJSONKey Offset where + toJSONKey = + AE.ToJSONKeyText + (keyFromText . encodeOffset OffsetFormatColonOn) + (\x -> AEE.unsafeToEncoding (BB.char7 '"' SG.<> builderOffsetUtf8 OffsetFormatColonOn x SG.<> BB.char7 '"')) + where +#if MIN_VERSION_aeson(2,0,0) + keyFromText = AK.fromText +#else + keyFromText = id +#endif + +instance FromJSONKey Offset where + fromJSONKey = AE.FromJSONKeyTextParser aesonParserOffset + +aesonParserOffset :: Text -> AET.Parser Offset +aesonParserOffset t = case decodeOffset OffsetFormatColonOn t of + Nothing -> fail "could not parse Offset" + Just x -> pure x + +{- | Holds all of the parts encoded by a 'Time'. + Can be used for formatting if what is presently in the API + does not suffice. +-} +data TimeParts = TimeParts + { timePartsDay :: !Int + -- ^ days 0-31 + , timePartsMonth :: !Int + -- ^ months 0-11 + , timePartsYear :: !Int + , timePartsHour :: !Int + -- ^ hours 0-23 + , timePartsMinute :: !Int + -- ^ minutes 0-59 + , timePartsSecond :: !Int + -- ^ seconds 0-59 + , timePartsSubsecond :: !Int + -- ^ fraction of a second with nanosecond resolution + , timePartsOffset :: !Int + } + deriving (Eq, Read, Show) + +instance NFData TimeParts where + rnf (TimeParts d mo y h m s ss o) = + d `deepseq` mo `deepseq` y `deepseq` h `deepseq` m `deepseq` s `deepseq` ss `deepseq` o `deepseq` () + +-- | Deconstruct a 'Time' into its 'TimeParts'. +timeParts :: Offset -> Time -> TimeParts +timeParts o0 t0 = + let + OffsetDatetime (Datetime dt t) o = timeToOffsetDatetime o0 t0 + Date y mo d = dt + TimeOfDay h mi s = t + (wholeSeconds, subsecond) = divMod s 100000000 + in + TimeParts + { timePartsDay = fromIntegral (getDayOfMonth d) + , timePartsMonth = fromIntegral (getMonth mo) + , timePartsYear = fromIntegral (getYear y) + , timePartsHour = h + , timePartsMinute = mi + , timePartsSecond = fromIntegral wholeSeconds + , timePartsSubsecond = fromIntegral subsecond + , timePartsOffset = getOffset o + } + +{- | Decode an ISO-8601-encode datetime. The encoded time must be suffixed +by either @Z@ or @+00:00@ or @+00@. +-} +decodeIso8601Zulu :: Text -> Maybe Chronos.Datetime +{-# INLINE decodeIso8601Zulu #-} +decodeIso8601Zulu !t = + BVP.parseBytesMaybe parserIso8601Zulu (Utf8.fromText t) + +{- | Decode an ISO-8601-encode datetime. The encoded time must be suffixed +by either @Z@ or @+00:00@ or @+00@. +-} +decodeShortTextIso8601Zulu :: ShortText -> Maybe Chronos.Datetime +{-# INLINE decodeShortTextIso8601Zulu #-} +decodeShortTextIso8601Zulu !t = + BVP.parseBytesMaybe parserIso8601Zulu (Utf8.fromShortText t) + +parserIso8601Zulu :: BVP.Parser () s Chronos.Datetime +{-# NOINLINE parserIso8601Zulu #-} +parserIso8601Zulu = do + d <- parserUtf8BytesIso8601Zoneless 'T' + remaining <- BVP.remaining + case Bytes.length remaining of + 1 | Bytes.unsafeIndex remaining 0 == 0x5A -> pure d + 3 | Bytes.equalsCString (Ptr "+00"#) remaining -> pure d + 6 | Bytes.equalsCString (Ptr "+00:00"#) remaining -> pure d + _ -> BVP.fail () + +{- | Decode an ISO-8601-encode datetime. The encoded time must not be 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)) + +-- | Decode an ISO-8601-encode datetime. +decodeUtf8BytesIso8601Zoneless :: Bytes -> Maybe Chronos.Datetime +decodeUtf8BytesIso8601Zoneless !b = + BVP.parseBytesMaybe (parserUtf8BytesIso8601Zoneless 'T' <* BVP.endOfInput ()) b + +{- | Decode a datetime that is nearly ISO-8601-encoded but uses a space +instead of a T to separate the date and the time. For example: +@2022-10-29 14:00:05@. +-} +decodeUtf8BytesIso8601ZonelessSpaced :: Bytes -> Maybe Chronos.Datetime +decodeUtf8BytesIso8601ZonelessSpaced !b = + BVP.parseBytesMaybe (parserUtf8BytesIso8601Zoneless ' ' <* BVP.endOfInput ()) b + +decodeUtf8BytesIso8601 :: Bytes -> Maybe Chronos.OffsetDatetime +decodeUtf8BytesIso8601 !b = + BVP.parseBytesMaybe (parserUtf8BytesIso8601 <* BVP.endOfInput ()) b + +parserUtf8BytesIso8601Zoneless :: Char -> BVP.Parser () s Chronos.Datetime +{-# NOINLINE parserUtf8BytesIso8601Zoneless #-} +parserUtf8BytesIso8601Zoneless !sep = 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 () sep + 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 'T' + 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.123 +> 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 + _ -> + let (ms, us) = quotRem ns 1_000_000 + in case us of + 0 -> + Bounded.weaken @4 @10 + Lte.constant + ( Bounded.ascii '.' + `Bounded.append` Bounded.wordPaddedDec3 (fromIntegral ms) + ) + _ -> + 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/src/Chronos/Internal/CTimespec.hs b/src/Chronos/Internal/CTimespec.hs --- a/src/Chronos/Internal/CTimespec.hs +++ b/src/Chronos/Internal/CTimespec.hs @@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} + +#if defined(ghcjs_HOST_OS) {-# LANGUAGE JavaScriptFFI #-} +#endif {-# OPTIONS_HADDOCK hide #-} -- for doctests @@ -7,8 +10,10 @@ ( #ifndef mingw32_HOST_OS getPosixNanoseconds +#ifndef ghcjs_HOST_OS , CTimespec(..) #endif +#endif ) where import Foreign @@ -57,6 +62,8 @@ throwErrnoIfMinus1_ "clock_gettime" $ clock_gettime 0 ptspec peek ptspec - return ((s * 1000000000) + ns) + -- On most 64-bit platforms, the uses of fromIntegral here end up + -- being i64->i64, but on 32-bit platforms, they are i32->i64. + return ((fromIntegral s * 1000000000) + fromIntegral ns) #endif diff --git a/src/Chronos/Locale/English.hs b/src/Chronos/Locale/English.hs --- a/src/Chronos/Locale/English.hs +++ b/src/Chronos/Locale/English.hs @@ -1,11 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{-| This module provides some english locale helpers. +{- | This module provides some english locale helpers. It is very incomplete. Please send a pull request - to https://github.com/andrewthad/chronos if you need + to https://github.com/byteverse/chronos if you need additions to this API. - -} - +-} module Chronos.Locale.English ( lower , upper @@ -19,11 +18,12 @@ import Chronos.Types import Data.Text (Text) --- $setup --- --- >>> :set -XOverloadedStrings --- >>> import Chronos (january, august, december, october, caseMonth) +{- $setup +>>> :set -XOverloadedStrings +>>> import Chronos (january, august, december, october, caseMonth) +-} + -- | Lowercase "am"/"pm". lower :: MeridiemLocale Text lower = MeridiemLocale "am" "pm" @@ -40,28 +40,50 @@ upperDots :: MeridiemLocale Text upperDots = MeridiemLocale "A.M." "P.M." --- | Unabbreviated 'Month's of the year. --- --- >>> caseMonth unabbreviated january --- "January" --- --- >>> caseMonth unabbreviated december --- "December" +{- | Unabbreviated 'Month's of the year. + + >>> caseMonth unabbreviated january + "January" + + >>> caseMonth unabbreviated december + "December" +-} unabbreviated :: MonthMatch Text -unabbreviated = buildMonthMatch - "January" "February" "March" "April" - "May" "June" "July" "August" - "September" "October" "November" "December" +unabbreviated = + buildMonthMatch + "January" + "February" + "March" + "April" + "May" + "June" + "July" + "August" + "September" + "October" + "November" + "December" --- | Abbreviated 'Month's of the year. --- --- >>> caseMonth abbreviated october --- "Oct" --- --- >>> caseMonth abbreviated august --- "Aug" -abbreviated :: MonthMatch Text -abbreviated = buildMonthMatch - "Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" +{- | Abbreviated 'Month's of the year. + >>> caseMonth abbreviated october + "Oct" + + >>> caseMonth abbreviated august + "Aug" +-} +abbreviated :: MonthMatch Text +abbreviated = + buildMonthMatch + "Jan" + "Feb" + "Mar" + "Apr" + "May" + "Jun" + "Jul" + "Aug" + "Sep" + "Oct" + "Nov" + "Dec" diff --git a/src/Chronos/Types.hs b/src/Chronos/Types.hs --- a/src/Chronos/Types.hs +++ b/src/Chronos/Types.hs @@ -24,35 +24,33 @@ corruption of data if the user is trying to use out-of-bounds values for the month and the day. Users are advised to not use the data types provided here to model non-existent times. - -} - module Chronos.Types - ( Day(..) - , DayOfWeek(..) - , DayOfMonth(..) - , DayOfYear(..) - , Month(..) - , Year(..) - , Offset(..) - , Time(..) - , DayOfWeekMatch(..) - , MonthMatch(..) - , UnboxedMonthMatch(..) - , Timespan(..) - , SubsecondPrecision(..) - , Date(..) - , OrdinalDate(..) - , MonthDate(..) - , Datetime(..) - , OffsetDatetime(..) - , TimeOfDay(..) - , DatetimeFormat(..) - , OffsetFormat(..) - , DatetimeLocale(..) - , MeridiemLocale(..) - , TimeInterval(..) - , TimeParts(..) + ( Day (..) + , DayOfWeek (..) + , DayOfMonth (..) + , DayOfYear (..) + , Month (..) + , Year (..) + , Offset (..) + , Time (..) + , DayOfWeekMatch (..) + , MonthMatch (..) + , UnboxedMonthMatch (..) + , Timespan (..) + , SubsecondPrecision (..) + , Date (..) + , OrdinalDate (..) + , MonthDate (..) + , Datetime (..) + , OffsetDatetime (..) + , TimeOfDay (..) + , DatetimeFormat (..) + , OffsetFormat (..) + , DatetimeLocale (..) + , MeridiemLocale (..) + , TimeInterval (..) + , TimeParts (..) ) where import Chronos diff --git a/test/Doctests.hs b/test/Doctests.hs deleted file mode 100644 --- a/test/Doctests.hs +++ /dev/null @@ -1,8 +0,0 @@ -import Test.DocTest - -main :: IO () -main = doctest - [ "-isrc" - , "src/Chronos.hs" - , "src/Chronos/Locale/English.hs" - ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,398 +1,926 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module Main (main) where - -import Chronos.Types -import Data.ByteString (ByteString) -import Data.Int (Int64) -import Data.List (intercalate) -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) -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.Property (failed,succeeded,Result(..)) -import qualified Chronos as C -import qualified Data.Attoparsec.ByteString as AttoBS -import qualified Data.Attoparsec.Text as Atto -import qualified Data.ByteString.Builder as BBuilder -import qualified Data.ByteString.Lazy as LByteString -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LText -import qualified Data.Text.Lazy.Builder as Builder -import qualified Test.Framework as TF -import qualified Test.Framework.Providers.HUnit as PH -import qualified Torsor as T - --- We increase the default number of property-based tests (provided --- by quickcheck) to 1000. Some of the encoding and decoding functions --- we test have special behavior when the minute is zero, which only --- happens in 1/60 of the generated scenarios. If we only generate 100 --- scenarios, there is a 18.62% chance that none of these will have zero --- as the minute. If we increase this to 1000, that probability drops to --- almost nothing. -main :: IO () -main = defaultMainWithOpts tests mempty - { TF.ropt_test_options = Just mempty - { TF.topt_maximum_generated_tests = Just 1000 - , TF.topt_maximum_unsuitable_generated_tests = Just 10000 - } - } - -tests :: [Test] -tests = - [ testGroup "Time of Day" - [ testGroup "Text" - [ testGroup "Text Parsing Spec Tests" - [ PH.testCase "No Separator + microseconds" - (timeOfDayParse Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) - , PH.testCase "Separator + microseconds" - (timeOfDayParse (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) - , PH.testCase "Separator + milliseconds" - (timeOfDayParse (Just ':') "05:00:58.675" (TimeOfDay 05 00 58675000000)) - , PH.testCase "Separator + deciseconds" - (timeOfDayParse (Just ':') "05:00:58.9" (TimeOfDay 05 00 58900000000)) - , PH.testCase "Separator + no subseconds" - (timeOfDayParse (Just ':') "23:08:01" (TimeOfDay 23 8 1000000000)) - , PH.testCase "Separator + nanoseconds" - (timeOfDayParse (Just ':') "05:00:58.111222999" (TimeOfDay 05 00 58111222999)) - , PH.testCase "Separator + 10e-18 seconds (truncate)" - (timeOfDayParse (Just ':') "05:00:58.111222333444555666" (TimeOfDay 05 00 58111222333)) - , PH.testCase "Separator + opt seconds (absent)" - (parseMatch (C.parser_HMS_opt_S (Just ':')) "00:01" (TimeOfDay 0 1 0)) - , PH.testCase "Separator + opt seconds (present)" - (parseMatch (C.parser_HMS_opt_S (Just ':')) "00:01:05" (TimeOfDay 0 1 5000000000)) - , PH.testCase "No Separator + opt seconds (absent)" - (parseMatch (C.parser_HMS_opt_S Nothing) "0001" (TimeOfDay 0 1 0)) - , PH.testCase "No Separator + opt seconds (present)" - (parseMatch (C.parser_HMS_opt_S Nothing) "000105" (TimeOfDay 0 1 5000000000)) - ] - , testGroup "Text Builder Spec Tests" - [ PH.testCase "No Separator + microseconds" - (timeOfDayBuilder (SubsecondPrecisionFixed 6) Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) - , PH.testCase "Separator + microseconds" - (timeOfDayBuilder (SubsecondPrecisionFixed 6) (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) - , PH.testCase "Separator + no subseconds" - (timeOfDayBuilder (SubsecondPrecisionFixed 0) (Just ':') "23:08:01" (TimeOfDay 23 8 1000000000)) - ] - , testProperty "Text Builder Parser Isomorphism (H:M:S)" $ propEncodeDecodeIso - (LText.toStrict . Builder.toLazyText . C.builder_HMS (SubsecondPrecisionFixed 9) (Just ':')) - (either (const Nothing) Just . Atto.parseOnly (C.parser_HMS (Just ':'))) - ] - , testGroup "ByteString" - [ testGroup "Parser Spec Tests" - [ PH.testCase "No Separator + microseconds" - (bsTimeOfDayParse Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) - , PH.testCase "Separator + microseconds" - (bsTimeOfDayParse (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) - , PH.testCase "Separator + milliseconds" - (bsTimeOfDayParse (Just ':') "05:00:58.675" (TimeOfDay 05 00 58675000000)) - , PH.testCase "Separator + deciseconds" - (bsTimeOfDayParse (Just ':') "05:00:58.9" (TimeOfDay 05 00 58900000000)) - , PH.testCase "Separator + no subseconds" - (bsTimeOfDayParse (Just ':') "23:08:01" (TimeOfDay 23 8 1000000000)) - , PH.testCase "Separator + nanoseconds" - (bsTimeOfDayParse (Just ':') "05:00:58.111222999" (TimeOfDay 05 00 58111222999)) - , PH.testCase "Separator + 10e-18 seconds (truncate)" - (bsTimeOfDayParse (Just ':') "05:00:58.111222333444555666" (TimeOfDay 05 00 58111222333)) - , PH.testCase "Separator + opt seconds (absent)" - (bsParseMatch (C.parserUtf8_HMS_opt_S (Just ':')) "00:01" (TimeOfDay 0 1 0)) - , PH.testCase "Separator + opt seconds (present)" - (bsParseMatch (C.parserUtf8_HMS_opt_S (Just ':')) "00:01:05" (TimeOfDay 0 1 5000000000)) - , PH.testCase "No Separator + opt seconds (absent)" - (bsParseMatch (C.parserUtf8_HMS_opt_S Nothing) "0001" (TimeOfDay 0 1 0)) - , PH.testCase "No Separator + opt seconds (present)" - (bsParseMatch (C.parserUtf8_HMS_opt_S Nothing) "000105" (TimeOfDay 0 1 5000000000)) - ] - , testGroup "Builder Spec Tests" - [ PH.testCase "No Separator + microseconds" - (bsTimeOfDayBuilder (SubsecondPrecisionFixed 6) Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) - , PH.testCase "Separator + microseconds" - (bsTimeOfDayBuilder (SubsecondPrecisionFixed 6) (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) - , PH.testCase "Separator + no subseconds" - (bsTimeOfDayBuilder (SubsecondPrecisionFixed 0) (Just ':') "23:08:01" (TimeOfDay 23 8 1000000000)) - ] - , testProperty "Builder Parser Isomorphism (H:M:S)" $ propEncodeDecodeIso - (LByteString.toStrict . BBuilder.toLazyByteString . C.builderUtf8_HMS (SubsecondPrecisionFixed 9) (Just ':')) - (either (const Nothing) Just . AttoBS.parseOnly (C.parserUtf8_HMS (Just ':'))) - ] - ] - , testGroup "Date" - [ testGroup "Parser Spec Tests" $ - [ PH.testCase "No Separator" - (dateParse Nothing "20160101" (Date (Year 2016) (Month 0) (DayOfMonth 1))) - , PH.testCase "Separator 1" - (dateParse (Just '-') "2016-01-01" (Date (Year 2016) (Month 0) (DayOfMonth 1))) - , PH.testCase "Separator 2" - (dateParse (Just '-') "1876-09-27" (Date (Year 1876) (Month 8) (DayOfMonth 27))) - ] - , testGroup "Builder Spec Tests" $ - [ PH.testCase "No Separator" - (dateBuilder Nothing "20160101" (Date (Year 2016) (Month 0) (DayOfMonth 1))) - , PH.testCase "Separator 1" - (dateBuilder (Just '-') "2016-01-01" (Date (Year 2016) (Month 0) (DayOfMonth 1))) - , PH.testCase "Separator 2" - (dateBuilder (Just '-') "1876-09-27" (Date (Year 1876) (Month 8) (DayOfMonth 27))) - ] - , testProperty "Builder Parser Isomorphism (Y-m-d)" $ propEncodeDecodeIso - (LText.toStrict . Builder.toLazyText . C.builder_Ymd (Just '-')) - (either (const Nothing) Just . Atto.parseOnly (C.parser_Ymd (Just '-'))) - ] - , testGroup "Datetime" - [ testProperty "Builder Parser Isomorphism (Y-m-dTH:M:S)" $ propEncodeDecodeIsoSettings - (\format -> LText.toStrict . Builder.toLazyText . C.builder_YmdHMS (SubsecondPrecisionFixed 9) format) - (\format -> either (const Nothing) Just . Atto.parseOnly (C.parser_YmdHMS format)) - , testProperty "Builder Parser Isomorphism (YmdHMS)" $ propEncodeDecodeIso - (LText.toStrict . Builder.toLazyText . C.builder_YmdHMS (SubsecondPrecisionFixed 9) (DatetimeFormat Nothing Nothing Nothing)) - (either (const Nothing) Just . Atto.parseOnly (C.parser_YmdHMS (DatetimeFormat Nothing Nothing Nothing))) - ] - , testGroup "Offset Datetime" - [ testGroup "Builder Spec Tests" $ - [ PH.testCase "W3C" $ matchBuilder "1997-07-16T19:20:30.450+01:00" $ - C.builderW3Cz $ OffsetDatetime - ( Datetime - ( Date (Year 1997) C.july (DayOfMonth 16) ) - ( TimeOfDay 19 20 30450000000 ) - ) (Offset 60) - ] - , testProperty "Builder Parser Isomorphism (YmdHMSz)" $ propEncodeDecodeIsoSettings - (\(offsetFormat,datetimeFormat) offsetDatetime -> - LText.toStrict $ Builder.toLazyText $ - C.builder_YmdHMSz offsetFormat (SubsecondPrecisionFixed 9) datetimeFormat offsetDatetime - ) - (\(offsetFormat,datetimeFormat) input -> - either (const Nothing) Just $ flip Atto.parseOnly input $ - C.parser_YmdHMSz offsetFormat datetimeFormat - ) - ] - , testGroup "Posix Time" - [ PH.testCase "Get now" $ do - now <- C.now - assertBool "Current time is the beginning of the epoch." (now /= C.epoch) - ] - , testGroup "Conversion" - [ testGroup "POSIX to Datetime" - [ PH.testCase "Epoch" $ C.timeToDatetime (Time 0) - @?= Datetime (Date (Year 1970) C.january (DayOfMonth 1)) - (TimeOfDay 0 0 0) - , PH.testCase "Billion Seconds" $ C.timeToDatetime (Time $ 10 ^ 18) - @?= Datetime (Date (Year 2001) C.september (DayOfMonth 9)) - (TimeOfDay 1 46 (40 * 10 ^ 9)) - , testProperty "Isomorphism" $ propEncodeDecodeFullIso C.timeToDatetime C.datetimeToTime - ] - ] - , testGroup "TimeInterval" - [ testGroup "within" - [ testProperty "Verify that Time bounds are inside TimeInterval" propWithinInsideInterval - , testProperty "Verify that the sum of Time and the span of TimeInterval is outside the interval" - propWithinOutsideInterval - ] - , testGroup "timeIntervalToTimespan" - [ PH.testCase "Verify Timespan correctness with TimeInterval" - (C.timeIntervalToTimespan (TimeInterval (Time 13) (Time 25)) @?= Timespan 12) - , PH.testCase "Verify Timespan correctness with equal TimeInterval bounds" - (C.timeIntervalToTimespan (TimeInterval (Time 13) (Time 13)) @?= Timespan 0) - , testProperty "Almost isomorphism" propEncodeDecodeTimeInterval - ] - , testGroup "whole" - [ PH.testCase "Verify TimeInterval's bound correctness" - (C.whole @?= TimeInterval (Time (minBound :: Int64)) (Time (maxBound :: Int64))) - ] - , testGroup "singleton" - [ testProperty "Verify that upper and lower bound are always equals" propSingletonBoundsEquals - ] - , testGroup "width" - [ testProperty "Verify Time bounds correctness with TimeSpan" propWidthVerifyBounds - ] - , testGroup "timeIntervalBuilder" - [ testProperty "Verify TimeInterval construction correctness" propTimeIntervalBuilder - ] - ] - ] - -failure :: String -> Result -failure msg = failed - { reason = msg - , theException = Nothing - } - -propEncodeDecodeFullIso :: (Eq a,Show a,Show b) => (a -> b) -> (b -> a) -> a -> Result -propEncodeDecodeFullIso f g a = - let fa = f a - gfa = g fa - in if gfa == a - then succeeded - else failure $ concat - [ "x: ", show a, "\n" - , "f(x): ", show fa, "\n" - , "g(f(x)): ", show gfa, "\n" - ] - -propEncodeDecodeIso :: Eq a => (a -> b) -> (b -> Maybe a) -> a -> Bool -propEncodeDecodeIso f g a = g (f a) == Just a - -propEncodeDecodeIsoSettings :: (Eq a,Show a,Show b,Show e) - => (e -> a -> b) -> (e -> b -> Maybe a) -> e -> a -> Result -propEncodeDecodeIsoSettings f g e a = - let fa = f e a - gfa = g e fa - in if gfa == Just a - then succeeded - else failure $ concat - [ "env: ", show e, "\n" - , "x: ", show a, "\n" - , "f(x): ", show fa, "\n" - , "g(f(x)): ", show gfa, "\n" - ] - -parseMatch :: (Eq a, Show a) => Atto.Parser a -> Text -> a -> Assertion -parseMatch p t expected = do - Atto.parseOnly (p <* Atto.endOfInput) t - @?= Right expected - -bsParseMatch :: (Eq a, Show a) => AttoBS.Parser a -> ByteString -> a -> Assertion -bsParseMatch p t expected = do - AttoBS.parseOnly (p <* AttoBS.endOfInput) t - @?= Right expected - -timeOfDayParse :: Maybe Char -> Text -> TimeOfDay -> Assertion -timeOfDayParse m t expected = - Atto.parseOnly (C.parser_HMS m <* Atto.endOfInput) t - @?= Right expected - -bsTimeOfDayParse :: Maybe Char -> ByteString -> TimeOfDay -> Assertion -bsTimeOfDayParse m t expected = - AttoBS.parseOnly (C.parserUtf8_HMS m <* AttoBS.endOfInput) t - @?= Right expected - -timeOfDayBuilder :: SubsecondPrecision -> Maybe Char -> Text -> TimeOfDay -> Assertion -timeOfDayBuilder sp m expected tod = - LText.toStrict (Builder.toLazyText (C.builder_HMS sp m tod)) - @?= expected - -bsTimeOfDayBuilder :: SubsecondPrecision -> Maybe Char -> Text -> TimeOfDay -> Assertion -bsTimeOfDayBuilder sp m expected tod = - LText.toStrict (Builder.toLazyText (C.builder_HMS sp m tod)) - @?= expected - -dateParse :: Maybe Char -> Text -> Date -> Assertion -dateParse m t expected = - Atto.parseOnly (C.parser_Ymd m <* Atto.endOfInput) t - @?= Right expected - -dateBuilder :: Maybe Char -> Text -> Date -> Assertion -dateBuilder m expected tod = - LText.toStrict (Builder.toLazyText (C.builder_Ymd m tod)) - @?= expected - -matchBuilder :: Text -> Builder -> Assertion -matchBuilder a b = LText.toStrict (Builder.toLazyText b) @?= a - -propWithinInsideInterval :: TimeInterval -> Bool -propWithinInsideInterval ti@(TimeInterval t0 t1) = C.within t1 ti && C.within t0 ti - -propWithinOutsideInterval :: RelatedTimes -> Bool -propWithinOutsideInterval (RelatedTimes t ti@(TimeInterval t0 t1)) - | t == t0 = discard - | t == t1 = discard - | t1 <= t0 = discard - | t0 < (Time 0) = discard - | t < (Time 0) = discard - | otherwise = - let - span = C.timeIntervalToTimespan ti - tm = T.add span t - in - not $ C.within tm ti - -propEncodeDecodeTimeInterval :: TimeInterval -> Bool -propEncodeDecodeTimeInterval ti@(TimeInterval t0 t1) - | t0 < (Time 0) = discard - | t0 >= t1 = discard - | otherwise = - let - span = C.timeIntervalToTimespan ti - tm = T.add span t0 - in - t1 == tm - -propSingletonBoundsEquals :: Time -> Bool -propSingletonBoundsEquals tm = - let - (TimeInterval (Time ti) (Time te)) = C.singleton tm - in - ti == te - -propWidthVerifyBounds :: TimeInterval -> Bool -propWidthVerifyBounds ti@(TimeInterval (Time lower) (Time upper)) = - let - tiWidth = (getTimespan . C.width) ti - in - T.add lower tiWidth == upper && T.difference upper tiWidth == lower - -propTimeIntervalBuilder :: Time -> Time -> Bool -propTimeIntervalBuilder t0 t1 = - let - (TimeInterval ti te) = (C.timeIntervalBuilder t0 t1) - in - (getTime te) >= (getTime ti) - -instance Arbitrary TimeOfDay where - arbitrary = TimeOfDay - <$> choose (0,23) - <*> choose (0,59) - -- never use leap seconds for property-based tests - <*> choose (0,60000000000 - 1) - -instance Arbitrary Date where - arbitrary = Date - <$> fmap Year (choose (1800,2100)) - <*> fmap Month (choose (0,11)) - <*> fmap DayOfMonth (choose (1,28)) - -instance Arbitrary Datetime where - arbitrary = Datetime <$> arbitrary <*> arbitrary - --- instance Arbitrary UtcTime where --- arbitrary = UtcTime --- <$> fmap Day (choose (-100000,100000)) --- <*> choose (0,24 * 60 * 60 * 1000000000 - 1) - -instance Arbitrary OffsetDatetime where - arbitrary = OffsetDatetime - <$> arbitrary - <*> arbitrary - -instance Arbitrary DatetimeFormat where - arbitrary = DatetimeFormat - <$> arbitrary - <*> elements [Nothing, Just '/', Just ':', Just '-'] - <*> arbitrary - -instance Arbitrary OffsetFormat where - arbitrary = arbitraryBoundedEnum - shrink = genericShrink - -deriving instance Arbitrary Time - -instance Arbitrary TimeInterval where - arbitrary = do - t0 <- arbitrary - t1 <- suchThat arbitrary (>= t0) - pure (TimeInterval t0 t1) - -data RelatedTimes = RelatedTimes Time TimeInterval - deriving (Show) - -instance Arbitrary RelatedTimes where - arbitrary = do - ti@(TimeInterval t0 t1) <- arbitrary - tm <- fmap Time (choose (getTime t0, getTime t1)) - pure $ RelatedTimes tm ti +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main (main) where + +import qualified Chronos as C +import Chronos.Types +import qualified Data.Aeson as AE +import qualified Data.Attoparsec.ByteString as AttoBS +import qualified Data.Attoparsec.Text as Atto +import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BBuilder +import qualified Data.ByteString.Lazy as LByteString +import Data.Int (Int64) +import Data.Text (Text) +import qualified Data.Text.Lazy as LText +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as Builder +import Test.Framework (Test, defaultMainWithOpts, testGroup) +import qualified Test.Framework as TF +import qualified Test.Framework.Providers.HUnit as PH +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, assertBool, (@?=)) +import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum, choose, chooseInt, discard, elements, genericShrink, suchThat) +import Test.QuickCheck.Property (Result (..), failed, succeeded) +import qualified Torsor as T + +-- We increase the default number of property-based tests (provided +-- by quickcheck) to 1000. Some of the encoding and decoding functions +-- we test have special behavior when the minute is zero, which only +-- happens in 1/60 of the generated scenarios. If we only generate 100 +-- scenarios, there is a 18.62% chance that none of these will have zero +-- as the minute. If we increase this to 1000, that probability drops to +-- almost nothing. +main :: IO () +main = + defaultMainWithOpts + tests + mempty + { TF.ropt_test_options = + Just + mempty + { TF.topt_maximum_generated_tests = Just 1000 + , TF.topt_maximum_unsuitable_generated_tests = Just 10000 + } + } + +tests :: [Test] +tests = + [ testGroup + "Time of Day" + [ testGroup + "Text" + [ testGroup + "Text Parsing Spec Tests" + [ PH.testCase + "No Separator + microseconds" + (timeOfDayParse Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) + , PH.testCase + "Separator + microseconds" + (timeOfDayParse (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) + , PH.testCase + "Separator + milliseconds" + (timeOfDayParse (Just ':') "05:00:58.675" (TimeOfDay 05 00 58675000000)) + , PH.testCase + "Separator + deciseconds" + (timeOfDayParse (Just ':') "05:00:58.9" (TimeOfDay 05 00 58900000000)) + , PH.testCase + "Separator + no subseconds" + (timeOfDayParse (Just ':') "23:08:01" (TimeOfDay 23 8 1000000000)) + , PH.testCase + "Separator + nanoseconds" + (timeOfDayParse (Just ':') "05:00:58.111222999" (TimeOfDay 05 00 58111222999)) + , PH.testCase + "Separator + 10e-18 seconds (truncate)" + (timeOfDayParse (Just ':') "05:00:58.111222333444555666" (TimeOfDay 05 00 58111222333)) + , PH.testCase + "Separator + opt seconds (absent)" + (parseMatch (C.parser_HMS_opt_S (Just ':')) "00:01" (TimeOfDay 0 1 0)) + , PH.testCase + "Separator + opt seconds (present)" + (parseMatch (C.parser_HMS_opt_S (Just ':')) "00:01:05" (TimeOfDay 0 1 5000000000)) + , PH.testCase + "No Separator + opt seconds (absent)" + (parseMatch (C.parser_HMS_opt_S Nothing) "0001" (TimeOfDay 0 1 0)) + , PH.testCase + "No Separator + opt seconds (present)" + (parseMatch (C.parser_HMS_opt_S Nothing) "000105" (TimeOfDay 0 1 5000000000)) + ] + , testGroup + "Text Builder Spec Tests" + [ PH.testCase + "No Separator + microseconds" + (timeOfDayBuilder (SubsecondPrecisionFixed 6) Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) + , PH.testCase + "Separator + microseconds" + (timeOfDayBuilder (SubsecondPrecisionFixed 6) (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) + , PH.testCase + "Separator + no subseconds" + (timeOfDayBuilder (SubsecondPrecisionFixed 0) (Just ':') "23:08:01" (TimeOfDay 23 8 1000000000)) + ] + , testProperty "Text Builder Parser Isomorphism (H:M:S)" $ + propEncodeDecodeIso + (LText.toStrict . Builder.toLazyText . C.builder_HMS (SubsecondPrecisionFixed 9) (Just ':')) + (either (const Nothing) Just . Atto.parseOnly (C.parser_HMS (Just ':'))) + ] + , testGroup + "ByteString" + [ testGroup + "Parser Spec Tests" + [ PH.testCase + "No Separator + microseconds" + (bsTimeOfDayParse Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) + , PH.testCase + "Separator + microseconds" + (bsTimeOfDayParse (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) + , PH.testCase + "Separator + milliseconds" + (bsTimeOfDayParse (Just ':') "05:00:58.675" (TimeOfDay 05 00 58675000000)) + , PH.testCase + "Separator + deciseconds" + (bsTimeOfDayParse (Just ':') "05:00:58.9" (TimeOfDay 05 00 58900000000)) + , PH.testCase + "Separator + no subseconds" + (bsTimeOfDayParse (Just ':') "23:08:01" (TimeOfDay 23 8 1000000000)) + , PH.testCase + "Separator + nanoseconds" + (bsTimeOfDayParse (Just ':') "05:00:58.111222999" (TimeOfDay 05 00 58111222999)) + , PH.testCase + "Separator + 10e-18 seconds (truncate)" + (bsTimeOfDayParse (Just ':') "05:00:58.111222333444555666" (TimeOfDay 05 00 58111222333)) + , PH.testCase + "Separator + opt seconds (absent)" + (bsParseMatch (C.parserUtf8_HMS_opt_S (Just ':')) "00:01" (TimeOfDay 0 1 0)) + , PH.testCase + "Separator + opt seconds (present)" + (bsParseMatch (C.parserUtf8_HMS_opt_S (Just ':')) "00:01:05" (TimeOfDay 0 1 5000000000)) + , PH.testCase + "No Separator + opt seconds (absent)" + (bsParseMatch (C.parserUtf8_HMS_opt_S Nothing) "0001" (TimeOfDay 0 1 0)) + , PH.testCase + "No Separator + opt seconds (present)" + (bsParseMatch (C.parserUtf8_HMS_opt_S Nothing) "000105" (TimeOfDay 0 1 5000000000)) + ] + , testGroup + "Builder Spec Tests" + [ PH.testCase + "No Separator + microseconds" + (bsTimeOfDayBuilder (SubsecondPrecisionFixed 6) Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) + , PH.testCase + "Separator + microseconds" + (bsTimeOfDayBuilder (SubsecondPrecisionFixed 6) (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) + , PH.testCase + "Separator + no subseconds" + (bsTimeOfDayBuilder (SubsecondPrecisionFixed 0) (Just ':') "23:08:01" (TimeOfDay 23 8 1000000000)) + ] + , testProperty "Builder Parser Isomorphism (H:M:S)" $ + propEncodeDecodeIso + (LByteString.toStrict . BBuilder.toLazyByteString . C.builderUtf8_HMS (SubsecondPrecisionFixed 9) (Just ':')) + (either (const Nothing) Just . AttoBS.parseOnly (C.parserUtf8_HMS (Just ':'))) + ] + ] + , testGroup + "Date" + [ testGroup "Ymd Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + (dateParse (C.parser_Ymd Nothing) "20160101" (Date (Year 2016) (Month 0) (DayOfMonth 1))) + , PH.testCase + "Passes With Separator 1" + (dateParse (C.parser_Ymd (Just '-')) "2016-01-01" (Date (Year 2016) (Month 0) (DayOfMonth 1))) + , PH.testCase + "Passes With Separator 2" + (dateParse (C.parser_Ymd (Just '-')) "1876-09-27" (Date (Year 1876) (Month 8) (DayOfMonth 27))) + ] + , testGroup "Dmy Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + (dateParse (C.parser_Dmy Nothing) "01012016" (Date (Year 2016) (Month 0) (DayOfMonth 1))) + , PH.testCase + "Passes With Separator 1" + (dateParse (C.parser_Dmy (Just '-')) "01-01-2016" (Date (Year 2016) (Month 0) (DayOfMonth 1))) + , PH.testCase + "Passes With Separator 2" + (dateParse (C.parser_Dmy (Just '-')) "27-09-1876" (Date (Year 1876) (Month 8) (DayOfMonth 27))) + ] + , testGroup "Ymd Lenient Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + (dateParse C.parser_Ymd_lenient "20160101" (Date (Year 2016) (Month 0) (DayOfMonth 1))) + , PH.testCase + "Passes With Separator 1" + (dateParse C.parser_Ymd_lenient "2016!01@01" (Date (Year 2016) (Month 0) (DayOfMonth 1))) + , PH.testCase + "Passes With Separator 2" + (dateParse C.parser_Ymd_lenient "1876z09+27" (Date (Year 1876) (Month 8) (DayOfMonth 27))) + ] + , testGroup "Dmy Lenient Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + (dateParse C.parser_Dmy_lenient "01012016" (Date (Year 2016) (Month 0) (DayOfMonth 1))) + , PH.testCase + "Passes With Separator 1" + (dateParse C.parser_Dmy_lenient "01!01@2016" (Date (Year 2016) (Month 0) (DayOfMonth 1))) + , PH.testCase + "Passes With Separator 2" + (dateParse C.parser_Dmy_lenient "27z09+1876" (Date (Year 1876) (Month 8) (DayOfMonth 27))) + ] + , testGroup "Mdy Lenient Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + (dateParse C.parser_Mdy_lenient "01022016" (Date (Year 2016) (Month 0) (DayOfMonth 2))) + , PH.testCase + "Passes With Separator 1" + (dateParse C.parser_Mdy_lenient "01!02@2016" (Date (Year 2016) (Month 0) (DayOfMonth 2))) + , PH.testCase + "Passes With Separator 2" + (dateParse C.parser_Mdy_lenient "09+27z1876" (Date (Year 1876) (Month 8) (DayOfMonth 27))) + ] + , testGroup "Builder Spec Tests" $ + [ PH.testCase + "No Separator" + (dateBuilder Nothing "20160101" (Date (Year 2016) (Month 0) (DayOfMonth 1))) + , PH.testCase + "Separator 1" + (dateBuilder (Just '-') "2016-01-01" (Date (Year 2016) (Month 0) (DayOfMonth 1))) + , PH.testCase + "Separator 2" + (dateBuilder (Just '-') "1876-09-27" (Date (Year 1876) (Month 8) (DayOfMonth 27))) + , PH.testCase + "zero-pad year" + (dateBuilder (Just '-') "0001-01-01" (Date (Year 1) (Month 0) (DayOfMonth 1))) + ] + , testProperty "Builder Parser Isomorphism (Y-m-d)" $ + propEncodeDecodeIso + (LText.toStrict . Builder.toLazyText . C.builder_Ymd (Just '-')) + (either (const Nothing) Just . Atto.parseOnly (C.parser_Ymd (Just '-'))) + ] + , testGroup + "Datetime" + [ testGroup "DmyHMS Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + ( datetimeParse (C.parser_DmyHMS (DatetimeFormat Nothing Nothing Nothing)) "01022016010223" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator" + ( datetimeParse (C.parser_DmyHMS (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "01-02-2016 01:02:23" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + ] + , testGroup "YmdHMS Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + ( datetimeParse (C.parser_YmdHMS (DatetimeFormat Nothing Nothing Nothing)) "20160101010223" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator" + ( datetimeParse (C.parser_YmdHMS (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "2016-01-01 01:02:23" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + ] + , testGroup "MdyHMS Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + ( datetimeParse (C.parser_MdyHMS (DatetimeFormat Nothing Nothing Nothing)) "01012016010223" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator" + ( datetimeParse (C.parser_MdyHMS (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "01-01-2016 01:02:23" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + ] + , testGroup "DmyHMS Lenient Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + ( datetimeParse C.parser_DmyHMS_lenient "01022016010223" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator" + ( datetimeParse C.parser_DmyHMS_lenient "01z02x2016$01;02:23" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Fails with extra seperators" + (datetimeParseFail C.parser_DmyHMS_lenient "01-02-2016 01:02:23" "Failed reading: input does not start with a digit") + , PH.testCase + "Fails with some nonuniform empty Separators" + (datetimeParseFail C.parser_DmyHMS_lenient "01-02-201601:02:23" "Failed reading: satisfy") + ] + , testGroup "YmdHMS Lenient Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + ( datetimeParse C.parser_YmdHMS_lenient "20160101010223" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator" + ( datetimeParse C.parser_YmdHMS_lenient "2016!01z01^01a02c23" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Fails with extra seperators" + (datetimeParseFail C.parser_YmdHMS_lenient "2016-01-02 01:02:03" "Failed reading: input does not start with a digit") + ] + , testGroup "MdyHMS Lenient Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator" + ( datetimeParse C.parser_MdyHMS_lenient "01012016010223" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator" + ( datetimeParse C.parser_MdyHMS_lenient "01z01%2016^01a02c23" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Fails with extra seperators" + (datetimeParseFail C.parser_MdyHMS_lenient "01-02-2016 01:02:03" "Failed reading: input does not start with a digit") + ] + , testGroup "DmyHMS Optional Seconds Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator With Seconds" + ( datetimeParse (C.parser_DmyHMS_opt_S (DatetimeFormat Nothing Nothing Nothing)) "01022016010223" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With No Separator Without Seconds" + ( datetimeParse (C.parser_DmyHMS_opt_S (DatetimeFormat Nothing Nothing Nothing)) "010220160102" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Passes With With Separator With Seconds" + ( datetimeParse (C.parser_DmyHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "01-02-2016 01:02:23" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator Without Seconds" + ( datetimeParse (C.parser_DmyHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "01-02-2016 01:02" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Fails with trailing seperator" + (datetimeParseFail (C.parser_DmyHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "01-02-2016 01:02:" "not enough input") + , PH.testCase + "Fails with extra seperators" + (datetimeParseFail (C.parser_DmyHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "01-02-2016 01:02" "Failed reading: input does not start with a digit") + ] + , testGroup "YmdHMS Optional Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator With Seconds" + ( datetimeParse (C.parser_YmdHMS_opt_S (DatetimeFormat Nothing Nothing Nothing)) "20160101010223" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With No Separator Without Seconds" + ( datetimeParse (C.parser_YmdHMS_opt_S (DatetimeFormat Nothing Nothing Nothing)) "201601010102" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Passes With With Separator With Seconds" + ( datetimeParse (C.parser_YmdHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "2016-01-01 01:02:23" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator Without Seconds" + ( datetimeParse (C.parser_YmdHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "2016-01-01 01:02" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Fails with trailing seperator" + (datetimeParseFail (C.parser_YmdHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "2016-01-02 01:02:" "not enough input") + , PH.testCase + "Fails with extra seperators" + (datetimeParseFail (C.parser_YmdHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "2016-01-02 01:02" "Failed reading: input does not start with a digit") + ] + , testGroup "MdyHMS Optional Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator With Seconds" + ( datetimeParse (C.parser_MdyHMS_opt_S (DatetimeFormat Nothing Nothing Nothing)) "01012016010223" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With No Separator Without Seconds" + ( datetimeParse (C.parser_MdyHMS_opt_S (DatetimeFormat Nothing Nothing Nothing)) "010120160102" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Passes With With Separator With Seconds" + ( datetimeParse (C.parser_MdyHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "01-01-2016 01:02:23" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator Without Seconds" + ( datetimeParse (C.parser_MdyHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "01-01-2016 01:02" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Fails with trailing seperator" + (datetimeParseFail (C.parser_MdyHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "01-02-2016 01:02:" "not enough input") + , PH.testCase + "Fails with extra seperators" + (datetimeParseFail (C.parser_MdyHMS_opt_S (DatetimeFormat (Just '-') (Just ' ') (Just ':'))) "01-02-2016 01:02" "Failed reading: input does not start with a digit") + ] + , testGroup "DmyHMS Optional Seconds Lenient Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator with seconds" + ( datetimeParse C.parser_DmyHMS_opt_S_lenient "01022016010223" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With No Separator without seconds" + ( datetimeParse C.parser_DmyHMS_opt_S_lenient "010220160102" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Passes With With Separator with seconds" + ( datetimeParse C.parser_DmyHMS_opt_S_lenient "01z02x2016$01;02:23" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator without seconds" + ( datetimeParse C.parser_DmyHMS_opt_S_lenient "01z02x2016$01;02" $ + Datetime (Date (Year 2016) (Month 1) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Fails with trailing seperator" + (datetimeParseFail C.parser_DmyHMS_opt_S_lenient "01z02x2016$01;02^" "not enough input") + , PH.testCase + "Fails with extra seperators" + (datetimeParseFail C.parser_DmyHMS_opt_S_lenient "01-02-2016 01:02" "Failed reading: input does not start with a digit") + ] + , testGroup "YmdHMS Optional Seconds Lenient Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator With Seconds" + ( datetimeParse C.parser_YmdHMS_opt_S_lenient "20160101010223" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With No Separator Without Seconds" + ( datetimeParse C.parser_YmdHMS_opt_S_lenient "201601010102" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Passes With With Separator With Seconds" + ( datetimeParse C.parser_YmdHMS_opt_S_lenient "2016!01z01^01a02c23" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator Without Seconds" + ( datetimeParse C.parser_YmdHMS_opt_S_lenient "2016!01z01^01a02" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Fails with trailing seperator" + (datetimeParseFail C.parser_YmdHMS_opt_S_lenient "2016!01z01^01a02^" "not enough input") + , PH.testCase + "Fails with extra seperators" + (datetimeParseFail C.parser_YmdHMS_opt_S_lenient "2016-01-02 01:02" "Failed reading: input does not start with a digit") + ] + , testGroup "MdyHMS Optional Seconds Lenient Parser Spec Tests" $ + [ PH.testCase + "Passes With No Separator With Seconds" + ( datetimeParse C.parser_MdyHMS_opt_S_lenient "01012016010223" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With No Separator Without Seconds" + ( datetimeParse C.parser_MdyHMS_opt_S_lenient "010120160102" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Passes With With Separator With Seconds" + ( datetimeParse C.parser_MdyHMS_opt_S_lenient "01z01!2016^01a02c23" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 23000000000) + ) + , PH.testCase + "Passes With With Separator Without Seconds" + ( datetimeParse C.parser_MdyHMS_opt_S_lenient "01z01(2016^01a02" $ + Datetime (Date (Year 2016) (Month 0) (DayOfMonth 1)) (TimeOfDay 01 02 0) + ) + , PH.testCase + "Fails with trailing seperator" + (datetimeParseFail C.parser_MdyHMS_opt_S_lenient "01z01!2016^01a02^" "not enough input") + , PH.testCase + "Fails with extra seperators" + (datetimeParseFail C.parser_MdyHMS_opt_S_lenient "01-02-2016 01:02" "Failed reading: input does not start with a digit") + ] + , testGroup "Builder Parser Isomorphism" $ + [ testProperty "(Y-m-dTH:M:S)" $ + propEncodeDecodeIsoSettings + (\format -> LText.toStrict . Builder.toLazyText . C.builder_YmdHMS (SubsecondPrecisionFixed 9) format) + (\format -> either (const Nothing) Just . Atto.parseOnly (C.parser_YmdHMS format)) + , testProperty "Builder Parser Isomorphism (YmdHMS)" $ + propEncodeDecodeIso + (LText.toStrict . Builder.toLazyText . C.builder_YmdHMS (SubsecondPrecisionFixed 9) (DatetimeFormat Nothing Nothing Nothing)) + (either (const Nothing) Just . Atto.parseOnly (C.parser_YmdHMS (DatetimeFormat Nothing Nothing Nothing))) + ] + , testProperty "ISO-8601 Roundtrip" $ + propEncodeDecodeIso + C.encodeShortTextIso8601Zulu + ( \input -> case C.decodeShortTextIso8601 input of + Just (OffsetDatetime dt (Offset 0)) -> Just dt + _ -> Nothing + ) + , testProperty "ISO-8601 Zoneless Roundtrip" $ + propEncodeDecodeIso + C.encodeShortTextIso8601Zoneless + ( \input -> case C.decodeShortTextIso8601Zoneless input of + Just dt -> Just dt + _ -> Nothing + ) + ] + , testGroup + "Offset Datetime" + [ testGroup "Builder Spec Tests" $ + [ PH.testCase "W3C" $ + matchBuilder "1997-07-16T19:20:30.450+01:00" $ + C.builderW3Cz $ + OffsetDatetime + ( Datetime + (Date (Year 1997) C.july (DayOfMonth 16)) + (TimeOfDay 19 20 30450000000) + ) + (Offset 60) + ] + , testProperty "Builder Parser Isomorphism (YmdHMSz)" $ + propEncodeDecodeIsoSettings + ( \(offsetFormat, datetimeFormat) offsetDatetime -> + LText.toStrict $ + Builder.toLazyText $ + C.builder_YmdHMSz offsetFormat (SubsecondPrecisionFixed 9) datetimeFormat offsetDatetime + ) + ( \(offsetFormat, datetimeFormat) input -> + either (const Nothing) Just $ + flip Atto.parseOnly input $ + C.parser_YmdHMSz offsetFormat datetimeFormat + ) + ] + , testGroup + "Posix Time" + [ PH.testCase "Get now" $ do + now <- C.now + assertBool "Current time is the beginning of the epoch." (now /= C.epoch) + ] + , testGroup + "Conversion" + [ testGroup + "POSIX to Datetime" + [ PH.testCase "Epoch" $ + C.timeToDatetime (Time 0) + @?= Datetime + (Date (Year 1970) C.january (DayOfMonth 1)) + (TimeOfDay 0 0 0) + , PH.testCase "Billion Seconds" $ + C.timeToDatetime (Time $ 10 ^ (18 :: Integer)) + @?= Datetime + (Date (Year 2001) C.september (DayOfMonth 9)) + (TimeOfDay 1 46 (40 * 10 ^ (9 :: Integer))) + , testProperty "Isomorphism" $ propEncodeDecodeFullIso C.timeToDatetime C.datetimeToTime + ] + ] + , testGroup + "TimeInterval" + [ testGroup + "within" + [ testProperty "Verify that Time bounds are inside TimeInterval" propWithinInsideInterval + , testProperty + "Verify that the sum of Time and the span of TimeInterval is outside the interval" + propWithinOutsideInterval + ] + , testGroup + "timeIntervalToTimespan" + [ PH.testCase + "Verify Timespan correctness with TimeInterval" + (C.timeIntervalToTimespan (TimeInterval (Time 13) (Time 25)) @?= Timespan 12) + , PH.testCase + "Verify Timespan correctness with equal TimeInterval bounds" + (C.timeIntervalToTimespan (TimeInterval (Time 13) (Time 13)) @?= Timespan 0) + , testProperty "Almost isomorphism" propEncodeDecodeTimeInterval + ] + , testGroup + "whole" + [ PH.testCase + "Verify TimeInterval's bound correctness" + (C.whole @?= TimeInterval (Time (minBound :: Int64)) (Time (maxBound :: Int64))) + ] + , testGroup + "singleton" + [ testProperty "Verify that upper and lower bound are always equals" propSingletonBoundsEquals + ] + , testGroup + "width" + [ testProperty "Verify Time bounds correctness with TimeSpan" propWidthVerifyBounds + ] + , testGroup + "timeIntervalBuilder" + [ testProperty "Verify TimeInterval construction correctness" propTimeIntervalBuilder + ] + ] + , testGroup + "Datetime Conversions" + [ testGroup + "datetimeToDayOfWeek" + [ PH.testCase + "February 2nd 2020" + (C.datetimeToDayOfWeek (Datetime (Date (Year 2020) (Month 1) (DayOfMonth 2)) (TimeOfDay 0 0 0)) @?= DayOfWeek 0) + , PH.testCase + "July 10th 2019" + (C.datetimeToDayOfWeek (Datetime (Date (Year 2019) (Month 6) (DayOfMonth 10)) (TimeOfDay 0 0 0)) @?= DayOfWeek 3) + , PH.testCase + "November 16th 1946" + (C.datetimeToDayOfWeek (Datetime (Date (Year 1946) (Month 10) (DayOfMonth 16)) (TimeOfDay 0 0 0)) @?= DayOfWeek 6) + , PH.testCase + "February 29th 2024 (Leap Year)" + (C.datetimeToDayOfWeek (Datetime (Date (Year 2024) (Month 1) (DayOfMonth 29)) (TimeOfDay 0 0 0)) @?= DayOfWeek 4) + ] + ] + , testGroup + "timeToDayOfWeek Conversions" + [ PH.testCase + "Sunday, February 9, 2020 4:00:00 PM" + (C.timeToDayOfWeek (Time 1581264000000000000) @?= DayOfWeek 0) + , PH.testCase + "Monday, April 9, 2001 4:00:00 PM" + (C.timeToDayOfWeek (Time 986832000000000000) @?= DayOfWeek 1) + , PH.testCase + "Tuesday, March 7, 1995 4:00:00 PM" + (C.timeToDayOfWeek (Time 794592000000000000) @?= DayOfWeek 2) + , PH.testCase + "Wednesday, June 17, 1987 4:00:00 PM" + (C.timeToDayOfWeek (Time 550944000000000000) @?= DayOfWeek 3) + , PH.testCase + "Thursday, December 18, 1980 4:00:00 PM" + (C.timeToDayOfWeek (Time 346003200000000000) @?= DayOfWeek 4) + , PH.testCase + "Friday, October 10, 1975 4:00:00 PM" + (C.timeToDayOfWeek (Time 182188800000000000) @?= DayOfWeek 5) + , PH.testCase + "Saturday, August 11, 1973 4:00:00 PM" + (C.timeToDayOfWeek (Time 113932800000000000) @?= DayOfWeek 6) + , PH.testCase + "Thursday, January 1, 1970 12:00:00 AM" + (C.timeToDayOfWeek (Time 0) @?= DayOfWeek 4) + , PH.testCase + "Saturday, June 14, 1969 4:00:00 PM" + (C.timeToDayOfWeek (Time (-17308800000000000)) @?= DayOfWeek 6) + , PH.testCase + "Tuesday, June 6, 1944 4:00:00 PM" + (C.timeToDayOfWeek (Time (-806918400000000000)) @?= DayOfWeek 2) + ] + , testGroup + "timeToOffsetDatetime" + [ PH.testCase + "EpochNeg4h" + ( C.timeToOffsetDatetime (Offset (-240)) (Time 0) + @?= OffsetDatetime + ( Datetime + (Date (Year 1969) C.december (DayOfMonth 31)) + (TimeOfDay 20 0 0) + ) + (Offset (-240)) + ) + ] + , testGroup + "json" + [ PH.testCase "Datetime" $ + let dt = Datetime (Date (Year 3000) (Month 11) (DayOfMonth 31)) (TimeOfDay 0 0 0) + in AE.eitherDecode (AE.encode dt) @?= Right dt + ] + ] + +failure :: String -> Result +failure msg = + failed + { reason = msg + , theException = Nothing + } + +propEncodeDecodeFullIso :: (Eq a, Show a, Show b) => (a -> b) -> (b -> a) -> a -> Result +propEncodeDecodeFullIso f g a = + let fa = f a + gfa = g fa + in if gfa == a + then succeeded + else + failure $ + concat + [ "x: " + , show a + , "\n" + , "f(x): " + , show fa + , "\n" + , "g(f(x)): " + , show gfa + , "\n" + ] + +propEncodeDecodeIso :: (Eq a) => (a -> b) -> (b -> Maybe a) -> a -> Bool +propEncodeDecodeIso f g a = g (f a) == Just a + +propEncodeDecodeIsoSettings :: + (Eq a, Show a, Show b, Show e) => + (e -> a -> b) -> + (e -> b -> Maybe a) -> + e -> + a -> + Result +propEncodeDecodeIsoSettings f g e a = + let fa = f e a + gfa = g e fa + in if gfa == Just a + then succeeded + else + failure $ + concat + [ "env: " + , show e + , "\n" + , "x: " + , show a + , "\n" + , "f(x): " + , show fa + , "\n" + , "g(f(x)): " + , show gfa + , "\n" + ] + +parseMatch :: (Eq a, Show a) => Atto.Parser a -> Text -> a -> Assertion +parseMatch p t expected = + do + Atto.parseOnly (p <* Atto.endOfInput) t + @?= Right expected + +bsParseMatch :: (Eq a, Show a) => AttoBS.Parser a -> ByteString -> a -> Assertion +bsParseMatch p t expected = + do + AttoBS.parseOnly (p <* AttoBS.endOfInput) t + @?= Right expected + +timeOfDayParse :: Maybe Char -> Text -> TimeOfDay -> Assertion +timeOfDayParse m t expected = + Atto.parseOnly (C.parser_HMS m <* Atto.endOfInput) t + @?= Right expected + +bsTimeOfDayParse :: Maybe Char -> ByteString -> TimeOfDay -> Assertion +bsTimeOfDayParse m t expected = + AttoBS.parseOnly (C.parserUtf8_HMS m <* AttoBS.endOfInput) t + @?= Right expected + +timeOfDayBuilder :: SubsecondPrecision -> Maybe Char -> Text -> TimeOfDay -> Assertion +timeOfDayBuilder sp m expected tod = + LText.toStrict (Builder.toLazyText (C.builder_HMS sp m tod)) + @?= expected + +bsTimeOfDayBuilder :: SubsecondPrecision -> Maybe Char -> Text -> TimeOfDay -> Assertion +bsTimeOfDayBuilder sp m expected tod = + LText.toStrict (Builder.toLazyText (C.builder_HMS sp m tod)) + @?= expected + +dateParse :: Atto.Parser Date -> Text -> Date -> Assertion +dateParse p t expected = + Atto.parseOnly (p <* Atto.endOfInput) t + @?= Right expected + +-- dateParseFail :: Atto.Parser Date -> Text -> String -> Assertion +-- dateParseFail p t expected = +-- Atto.parseOnly (p <* Atto.endOfInput) t +-- @?= Left expected + +datetimeParse :: Atto.Parser Datetime -> Text -> Datetime -> Assertion +datetimeParse p t expected = + Atto.parseOnly (p <* Atto.endOfInput) t + @?= Right expected + +datetimeParseFail :: Atto.Parser Datetime -> Text -> String -> Assertion +datetimeParseFail p t expected = + Atto.parseOnly (p <* Atto.endOfInput) t + @?= Left expected + +dateBuilder :: Maybe Char -> Text -> Date -> Assertion +dateBuilder m expected tod = + LText.toStrict (Builder.toLazyText (C.builder_Ymd m tod)) + @?= expected + +matchBuilder :: Text -> Builder -> Assertion +matchBuilder a b = LText.toStrict (Builder.toLazyText b) @?= a + +propWithinInsideInterval :: TimeInterval -> Bool +propWithinInsideInterval ti@(TimeInterval t0 t1) = C.within t1 ti && C.within t0 ti + +propWithinOutsideInterval :: RelatedTimes -> Bool +propWithinOutsideInterval (RelatedTimes t ti@(TimeInterval t0 t1)) + | t == t0 = discard + | t == t1 = discard + | t1 <= t0 = discard + | t0 < (Time 0) = discard + | t < (Time 0) = discard + | otherwise = + let + span' = C.timeIntervalToTimespan ti + tm = T.add span' t + in + not $ C.within tm ti + +propEncodeDecodeTimeInterval :: TimeInterval -> Bool +propEncodeDecodeTimeInterval ti@(TimeInterval t0 t1) + | t0 < (Time 0) = discard + | t0 >= t1 = discard + | otherwise = + let + span' = C.timeIntervalToTimespan ti + tm = T.add span' t0 + in + t1 == tm + +propSingletonBoundsEquals :: Time -> Bool +propSingletonBoundsEquals tm = + let + (TimeInterval (Time ti) (Time te)) = C.singleton tm + in + ti == te + +propWidthVerifyBounds :: TimeInterval -> Bool +propWidthVerifyBounds ti@(TimeInterval (Time lower) (Time upper)) = + let + tiWidth = (getTimespan . C.width) ti + in + T.add lower tiWidth == upper && T.difference upper tiWidth == lower + +propTimeIntervalBuilder :: Time -> Time -> Bool +propTimeIntervalBuilder t0 t1 = + let + (TimeInterval ti te) = (C.timeIntervalBuilder t0 t1) + in + (getTime te) >= (getTime ti) + +instance Arbitrary TimeOfDay where + arbitrary = + TimeOfDay + <$> choose (0, 23) + <*> choose (0, 59) + -- never use leap seconds for property-based tests + <*> ( 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 + <$> fmap Year (choose (1800, 2100)) + <*> fmap Month (choose (0, 11)) + <*> fmap DayOfMonth (choose (1, 28)) + +instance Arbitrary Datetime where + arbitrary = Datetime <$> arbitrary <*> arbitrary + +-- instance Arbitrary UtcTime where +-- arbitrary = UtcTime +-- <$> fmap Day (choose (-100000,100000)) +-- <*> choose (0,24 * 60 * 60 * 1000000000 - 1) + +instance Arbitrary OffsetDatetime where + arbitrary = + OffsetDatetime + <$> arbitrary + <*> arbitrary + +instance Arbitrary DatetimeFormat where + arbitrary = + DatetimeFormat + <$> 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 + shrink = genericShrink + +deriving instance Arbitrary Time + +instance Arbitrary TimeInterval where + arbitrary = do + t0 <- arbitrary + t1 <- suchThat arbitrary (>= t0) + pure (TimeInterval t0 t1) + +data RelatedTimes = RelatedTimes Time TimeInterval + deriving (Show) + +instance Arbitrary RelatedTimes where + arbitrary = do + ti@(TimeInterval t0 t1) <- arbitrary + tm <- fmap Time (choose (getTime t0, getTime t1)) + pure $ RelatedTimes tm ti instance Arbitrary Offset where arbitrary = fmap Offset (choose ((-24) * 60, 24 * 60))