diff --git a/chronos.cabal b/chronos.cabal --- a/chronos.cabal +++ b/chronos.cabal @@ -1,100 +1,146 @@ -name: chronos -version: 1.0.5 -synopsis: A performant time library +cabal-version: 2.2 +name: + chronos +version: + 1.0.6 +synopsis: + A performant time library description: - Performance-oriented time library for haskell. The main differences - between this and "time" are that this library: - . - * Uses machine integers where possible. This means that some time-related - arithmetic should be faster. It also means that the types are incapable - of representing times that are very far in the future or the past. - . - * Provides "ToJSON" and "FromJSON" instances for json serialization. - . - * Provides "Unbox" instances for working with unboxed vectors. - . - * Uses normal non-overloaded haskell functions for encoding and decoding time. It provides - "attoparsec" parsers for both "Text" and "ByteString". Additionally, it - provides functions for encoding time as "Text" or "ByteString". The "time" - library uses accomplishes these with the "Data.Time.Format" module, - which uses UNIX-style datetime format strings. It is expected that - the approach taken in this library is faster and catches more mistakes - at compile time at the cost of being less expressive. - . - * Only provides nanosecond resolution instead of picosecond resolution. - + Chronos is a performance-oriented time library for Haskell, with a + straightforward API. The main differences between this + and the library + are: -homepage: https://github.com/andrewthad/chronos#readme -license: BSD3 -license-file: LICENSE -author: Andrew Martin -maintainer: andrew.thaddeus@gmail.com -copyright: 2016 Andrew Martin -category: web -build-type: Simple -cabal-version: >=1.10 + * 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 library - hs-source-dirs: src + hs-source-dirs: + src exposed-modules: Chronos - , Chronos.Types - , Chronos.Locale.English - other-modules: + Chronos.Types + Chronos.Locale.English + -- only exposed for doctests + -- it is OPTIONS_HADDOCK-hidden Chronos.Internal.CTimespec build-depends: - base >= 4.9 && < 5 , 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.3 - , primitive >= 0.6 && < 0.7 + , primitive >= 0.7 && < 0.8 , semigroups >= 0.16 && < 0.19 , text >= 1.2 && < 1.3 , torsor >= 0.1 && < 0.2 , vector >= 0.11 && < 0.13 - default-language: Haskell2010 - c-sources: src/cbits/hs-time.c - ghc-options: -Wall -O2 + default-language: + Haskell2010 + c-sources: + src/cbits/hs-time.c + ghc-options: + -Wall + -O2 test-suite chronos-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + Spec.hs build-depends: - base - , chronos - , text - , bytestring + , HUnit + , QuickCheck , attoparsec + , base + , bytestring + , chronos , test-framework + , test-framework-hunit , 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 - , HUnit - , test-framework-hunit - ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 + , base + , chronos + , doctest >= 0.10 + default-language: + Haskell2010 benchmark bench - type: exitcode-stdio-1.0 - hs-source-dirs: bench - main-is: Bench.hs + type: + exitcode-stdio-1.0 + hs-source-dirs: + bench + main-is: + Bench.hs build-depends: - base + , QuickCheck , attoparsec + , base , bytestring , chronos , criterion , deepseq , old-locale - , QuickCheck + , text , thyme , time , vector - , text - default-language: Haskell2010 + default-language: + Haskell2010 source-repository head - type: git - location: https://github.com/andrewthad/chronos + type: + git + location: + https://github.com/andrewthad/chronos diff --git a/src/Chronos.hs b/src/Chronos.hs --- a/src/Chronos.hs +++ b/src/Chronos.hs @@ -1,17 +1,41 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UnboxedTuples #-} +{-# language + BangPatterns + , CPP + , DeriveGeneric + , GeneralizedNewtypeDeriving + , MagicHash + , MultiParamTypeClasses + , OverloadedStrings + , ScopedTypeVariables + , TypeFamilies + , TypeInType + , UnboxedTuples + #-} -{-# OPTIONS_GHC -Wall #-} +{-| 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 @@ -50,7 +74,10 @@ -- ** Matching , buildDayOfWeekMatch , buildMonthMatch + , buildUnboxedMonthMatch + , caseDayOfWeek , caseMonth + , caseUnboxedMonth -- ** Format -- $format , w3c @@ -174,6 +201,16 @@ -- *** UTF-8 ByteString , encodeTimespanUtf8 , builderTimespanUtf8 + -- ** TimeInterval + , within + , timeIntervalToTimespan + , whole + , singleton + , lowerBound + , upperBound + , width + , timeIntervalBuilder + , (...) -- * Types , Day(..) , DayOfWeek(..) @@ -198,6 +235,7 @@ , OffsetFormat(..) , DatetimeLocale(..) , MeridiemLocale(..) + , TimeInterval(..) ) where import Data.Text (Text) @@ -245,26 +283,84 @@ 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 @@ -285,11 +381,34 @@ 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 --- foobar -datetimeFromYmdhms :: Int -> Int -> Int -> Int -> Int -> Int -> Datetime +-- 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) @@ -306,7 +425,18 @@ then fromIntegral (m - 1) else 1 -timeFromYmdhms :: Int -> Int -> Int -> Int -> Int -> Int -> Time +-- | 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 @@ -350,7 +480,7 @@ start <- CLK.getTime c a <- action >>= evaluate end <- CLK.getTime c - return (timeSpecToTimespan (CLK.diffTimeSpec end start),a) + pure (timeSpecToTimespan (CLK.diffTimeSpec end start),a) -- | Variant of 'stopwatch_' that accepts a clock type. stopwatchWith_ :: CLK.Clock -> IO a -> IO Timespan @@ -358,23 +488,24 @@ start <- CLK.getTime c _ <- action end <- CLK.getTime c - return (timeSpecToTimespan (CLK.diffTimeSpec end start)) + 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 dayLength) +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)) dayLength) - (if ns > dayLength then dayLength else ns) + (scale (intToInt64 (difference d epochDay)) day) + (if ns > day then day else ns) where ns = Timespan ns' intToInt64 :: Int -> Int64 @@ -383,15 +514,13 @@ epochDay :: Day epochDay = Day 40587 -dayLength :: Timespan -dayLength = Timespan 86400000000000 - dayLengthInt64 :: Int64 -dayLengthInt64 = 86400000000000 +dayLengthInt64 = getTimespan day nanosecondsInMinute :: Int64 nanosecondsInMinute = 60000000000 +-- | All UTC time offsets. See . observedOffsets :: Vector Offset observedOffsets = Vector.fromList $ map Offset [ -1200 @@ -462,13 +591,6 @@ timeOfDayToNanosecondsSinceMidnight (TimeOfDay h m ns) = fromIntegral h * 3600000000000 + fromIntegral m * 60000000000 + ns --- | Convert 'Day' to a 'Date'. -dayToDate :: Day -> Date -dayToDate theDay = Date year month dayOfMonth - where - OrdinalDate year yd = dayToOrdinalDate theDay - MonthDate month dayOfMonth = dayOfYearToMonthDay (isLeapYear year) yd - -- datetimeToOffsetDatetime :: Offset -> Datetime -> OffsetDatetime -- datetimeToOffsetDatetime offset @@ -496,18 +618,18 @@ (Day (theDay + dayAdjustment)) (timeOfDayToNanosecondsSinceMidnight tod) --- | Convert 'Date' to a 'Day'. -dateToDay :: Date -> Day -dateToDay (Date y m d) = ordinalDateToDay $ OrdinalDate y - (monthDateToDayOfYear (isLeapYear y) (MonthDate m d)) - -monthDateToDayOfYear :: Bool -> MonthDate -> DayOfYear +-- | 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 @@ -518,21 +640,33 @@ + (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)) -dayOfYearToMonthDay :: Bool -> DayOfYear -> MonthDate +-- | Convert a 'DayOfYear' to a 'MonthDate'. +dayOfYearToMonthDay :: + Bool -- ^ Is it a leap year? + -> DayOfYear + -> MonthDate dayOfYearToMonthDay isLeap dayOfYear = - let (!upperBound,!monthTable,!dayTable) = + let (!doyUpperBound,!monthTable,!dayTable) = if isLeap then (DayOfYear 366, leapYearDayOfYearMonthTable, leapYearDayOfYearDayOfMonthTable) else (DayOfYear 365, normalYearDayOfYearMonthTable, normalYearDayOfYearDayOfMonthTable) - DayOfYear clippedDay = clip (DayOfYear 1) upperBound dayOfYear + 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 @@ -554,42 +688,59 @@ -} +-- | 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 -buildDayOfWeekMatch :: a -> a -> a -> a -> a -> a -> a -> DayOfWeekMatch a -buildDayOfWeekMatch a b c d e f g = - DayOfWeekMatch (Vector.fromList [a,b,c,d,e,f,g]) - -internalBuildMonthMatch :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> MonthMatch a -internalBuildMonthMatch a b c d e f g h i j k l = - MonthMatch (Vector.fromList [a,b,c,d,e,f,g,h,i,j,k,l]) - -internalMatchMonth :: MonthMatch a -> Month -> a -internalMatchMonth (MonthMatch v) (Month ix) = Vector.unsafeIndex v (fromIntegral ix) - +-- | 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 internalMatchMonth leapYearMonthLength m - else internalMatchMonth normalYearMonthLength m + then caseMonth leapYearMonthLength m + else caseMonth normalYearMonthLength m leapYearMonthLength :: MonthMatch Int -leapYearMonthLength = internalBuildMonthMatch 31 29 31 30 31 30 31 31 30 31 30 31 +leapYearMonthLength = buildMonthMatch 31 29 31 30 31 30 31 31 30 31 30 31 normalYearMonthLength :: MonthMatch Int -normalYearMonthLength = internalBuildMonthMatch 31 30 31 30 31 30 31 31 30 31 30 31 +normalYearMonthLength = buildMonthMatch 31 30 31 30 31 30 31 31 30 31 30 31 leapYearDayOfYearDayOfMonthTable :: UVector.Vector DayOfMonth leapYearDayOfYearDayOfMonthTable = UVector.fromList $ (DayOfMonth 1:) $ concat @@ -659,14 +810,34 @@ ] {-# 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 = internalBuildMonthMatch +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 = internalMatchMonth +caseMonth (MonthMatch v) (Month ix) = Vector.unsafeIndex v ix --- | This could be written much more efficiently since we know the --- exact size the resulting 'Text' will be. +-- | 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 -> @@ -680,6 +851,8 @@ <> 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 -> @@ -693,6 +866,8 @@ <> 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 @@ -702,8 +877,10 @@ traverse_ AT.char msep d <- parseFixedDigits 2 when (d < 1 || d > 31) (fail "day must be between 1 and 31") - return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + 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 @@ -713,8 +890,10 @@ when (d < 1 || d > 31) (fail "day must be between 1 and 31") traverse_ AT.char msep y <- parseFixedDigits 4 - return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + 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 @@ -724,8 +903,10 @@ when (m < 1 || m > 12) (fail "month must be between 1 and 12") traverse_ AT.char msep y <- parseFixedDigits 4 - return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + 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 -> @@ -739,6 +920,8 @@ <> 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 @@ -748,13 +931,21 @@ traverse_ AB.char msep d <- parseFixedDigitsIntBS 2 when (d < 1 || d > 31) (fail "day must be between 1 and 31") - return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) +-- | Given a 'SubsecondPrecision' and a separator, construct a +-- 'Text' 'TB.Builder' corresponding to a 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 @@ -762,6 +953,14 @@ <> " " <> 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 @@ -775,12 +974,8 @@ then TB.fromText pm else TB.fromText am -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 - +-- | 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 @@ -790,7 +985,7 @@ when (m > 59) (fail "minute must be between 0 and 59") traverse_ AT.char msep ns <- parseSecondsAndNanoseconds - return (TimeOfDay h m ns) + pure (TimeOfDay h m ns) -- | Parses text that is formatted as either of the following: -- @@ -809,14 +1004,14 @@ when (m > 59) (fail "minute must be between 0 and 59") mc <- AT.peekChar case mc of - Nothing -> return (TimeOfDay h m 0) + 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 - return (TimeOfDay h m ns) - else return (TimeOfDay h m 0) + 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 @@ -824,8 +1019,8 @@ Nothing -> if isDigit c then do ns <- parseSecondsAndNanoseconds - return (TimeOfDay h m ns) - else return (TimeOfDay h m 0) + pure (TimeOfDay h m ns) + else pure (TimeOfDay h m 0) parseSecondsAndNanoseconds :: Parser Int64 parseSecondsAndNanoseconds = do @@ -842,19 +1037,19 @@ else if totalDigits < 9 then x * raiseTenTo (9 - totalDigits) else quot x (raiseTenTo (totalDigits - 9)) - return (fromIntegral result) - ) <|> return 0 - return (s * 1000000000 + nanoseconds) + 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 -> return i + Nothing -> pure i Just c -> if c == '0' then AT.anyChar *> go (i + 1) - else return i + else pure i nanosecondsBuilder :: Int64 -> TB.Builder nanosecondsBuilder w @@ -903,11 +1098,13 @@ (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 @@ -929,9 +1126,9 @@ (!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 @@ -941,35 +1138,58 @@ <> 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 --- | This could be written much more efficiently since we know the --- exact size the resulting 'Text' will be. +-- | 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 @@ -979,76 +1199,126 @@ <> 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 (DatetimeFormat (Just '-') (Just 'T') (Just ':')) +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 - return (Datetime date time) + 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 - return (Datetime date time) + 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 - return (Datetime date time) + 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 - return (Datetime date time) + 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 @@ -1069,12 +1339,15 @@ 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 @@ -1084,7 +1357,7 @@ when (m > 59) (fail "minute must be between 0 and 59") traverse_ AB.char msep ns <- parseSecondsAndNanosecondsUtf8 - return (TimeOfDay h m ns) + pure (TimeOfDay h m ns) -- | Parses text that is formatted as either of the following: -- @@ -1103,14 +1376,14 @@ when (m > 59) (fail "minute must be between 0 and 59") mc <- AB.peekChar case mc of - Nothing -> return (TimeOfDay h m 0) + 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 - return (TimeOfDay h m ns) - else return (TimeOfDay h m 0) + 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 @@ -1118,8 +1391,8 @@ Nothing -> if isDigit c then do ns <- parseSecondsAndNanosecondsUtf8 - return (TimeOfDay h m ns) - else return (TimeOfDay h m 0) + pure (TimeOfDay h m ns) + else pure (TimeOfDay h m 0) parseSecondsAndNanosecondsUtf8 :: AB.Parser Int64 parseSecondsAndNanosecondsUtf8 = do @@ -1136,19 +1409,19 @@ else if totalDigits < 9 then x * raiseTenTo (9 - totalDigits) else quot x (raiseTenTo (totalDigits - 9)) - return (fromIntegral result) - ) <|> return 0 - return (s * 1000000000 + nanoseconds) + 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 -> return i + Nothing -> pure i Just c -> if c == '0' then AB.anyChar *> go (i + 1) - else return i + else pure i nanosecondsBuilderUtf8 :: Int64 -> BB.Builder nanosecondsBuilderUtf8 w @@ -1197,10 +1470,14 @@ (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 @@ -1225,13 +1502,24 @@ (!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 @@ -1241,94 +1529,156 @@ <> 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 - return (Datetime date time) + 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 - return (Datetime date time) + 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 @@ -1336,10 +1686,13 @@ 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 @@ -1352,9 +1705,9 @@ parseSignedness = do c <- AT.anyChar if c == '-' - then return False + then pure False else if c == '+' - then return True + then pure True else fail "while parsing offset, expected [+] or [-]" parserOffset_z :: Parser Offset @@ -1363,7 +1716,7 @@ h <- parseFixedDigits 2 m <- parseFixedDigits 2 let !res = h * 60 + m - return . Offset $ if pos + pure . Offset $ if pos then res else negate res @@ -1374,7 +1727,7 @@ _ <- AT.char ':' m <- parseFixedDigits 2 let !res = h * 60 + m - return . Offset $ if pos + pure . Offset $ if pos then res else negate res @@ -1386,7 +1739,7 @@ m <- parseFixedDigits 2 _ <- AT.string ":00" let !res = h * 60 + m - return . Offset $ if pos + pure . Offset $ if pos then res else negate res @@ -1403,10 +1756,10 @@ _ <- AT.anyChar -- should be a colon m <- parseFixedDigits 2 let !res = h * 60 + m - return . Offset $ if pos + pure . Offset $ if pos then res else negate res - _ -> return . Offset $ if pos + _ -> pure . Offset $ if pos then h * 60 else h * (-60) @@ -1449,35 +1802,52 @@ <> ":" <> 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 @@ -1485,6 +1855,8 @@ 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 @@ -1497,9 +1869,9 @@ parseSignednessUtf8 = do c <- AB.anyChar if c == '-' - then return False + then pure False else if c == '+' - then return True + then pure True else fail "while parsing offset, expected [+] or [-]" parserOffsetUtf8_z :: AB.Parser Offset @@ -1508,7 +1880,7 @@ h <- parseFixedDigitsIntBS 2 m <- parseFixedDigitsIntBS 2 let !res = h * 60 + m - return . Offset $ if pos + pure . Offset $ if pos then res else negate res @@ -1519,7 +1891,7 @@ _ <- AB.char ':' m <- parseFixedDigitsIntBS 2 let !res = h * 60 + m - return . Offset $ if pos + pure . Offset $ if pos then res else negate res @@ -1531,7 +1903,7 @@ m <- parseFixedDigitsIntBS 2 _ <- AB.string ":00" let !res = h * 60 + m - return . Offset $ if pos + pure . Offset $ if pos then res else negate res @@ -1548,10 +1920,10 @@ _ <- AB.anyChar -- should be a colon m <- parseFixedDigitsIntBS 2 let !res = h * 60 + m - return . Offset $ if pos + pure . Offset $ if pos then res else negate res - _ -> return . Offset $ if pos + _ -> pure . Offset $ if pos then h * 60 else h * (-60) @@ -1596,20 +1968,24 @@ -- 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 - return (Datetime date time) + pure (Datetime date time) zeptoCountZeroes :: Z.Parser Int zeptoCountZeroes = do bs <- Z.takeWhile (0x30 ==) pure $! BC.length bs -zeptoUtf8_Ymd :: Maybe Char -> Z.Parser Chronos.Date +-- | 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' @@ -1619,9 +1995,11 @@ traverse_ Z.string msep d <- zeptoFixedDigitsIntBS 2 when (d < 1 || d > 31) (fail "day must be between 1 and 31") - return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + pure (Date (Year y) (Month $ m - 1) (DayOfMonth d)) -zeptoUtf8_HMS :: Maybe Char -> Z.Parser Chronos.TimeOfDay +-- | 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") @@ -1631,7 +2009,7 @@ when (m > 59) (fail "minute must be between 0 and 59") traverse_ Z.string msep ns <- zeptoSecondsAndNanosecondsUtf8 - return (TimeOfDay h m ns) + pure (TimeOfDay h m ns) zeptoFixedDigitsIntBS :: Int -> Z.Parser Int zeptoFixedDigitsIntBS n = do @@ -1639,7 +2017,7 @@ case BC.readInt t of Nothing -> fail "datetime decoding could not parse integral bytestring (a)" Just (i,r) -> if BC.null r - then return i + then pure i else fail "datetime decoding could not parse integral bytestring (b)" zeptoSecondsAndNanosecondsUtf8 :: Z.Parser Int64 @@ -1657,9 +2035,9 @@ else if totalDigits < 9 then x * raiseTenTo (9 - totalDigits) else quot x (raiseTenTo (totalDigits - 9)) - return (fromIntegral result) - ) <|> return 0 - return (s * 1000000000 + nanoseconds) + pure (fromIntegral result) + ) <|> pure 0 + pure (s * 1000000000 + nanoseconds) zdecimal :: Z.Parser Int64 zdecimal = do @@ -1671,64 +2049,82 @@ 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 @@ -1766,7 +2162,7 @@ case Text.decimal t of Left err -> fail err Right (i,r) -> if Text.null r - then return i + then pure i else fail "datetime decoding could not parse integral text" parseFixedDigitsIntBS :: Int -> AB.Parser Int @@ -1775,7 +2171,7 @@ case BC.readInt t of Nothing -> fail "datetime decoding could not parse integral bytestring (a)" Just (i,r) -> if BC.null r - then return i + then pure i else fail "datetime decoding could not parse integral bytestring (b)" -- Only provide positive numbers to this function. @@ -1836,11 +2232,54 @@ 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 @@ -1872,6 +2311,7 @@ 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 @@ -1881,17 +2321,28 @@ 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) + 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 @@ -1921,6 +2372,7 @@ 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 @@ -1929,7 +2381,8 @@ , dateDay :: {-# UNPACK #-} !DayOfMonth } deriving (Show,Read,Eq,Ord) --- | The year and number of days elapsed since the beginning it began. +-- | An 'OrdinalDate' is a 'Year' and the number of days elapsed +-- since the 'Year' began. data OrdinalDate = OrdinalDate { ordinalDateYear :: {-# UNPACK #-} !Year , ordinalDateDayOfYear :: {-# UNPACK #-} !DayOfYear @@ -1942,13 +2395,14 @@ , monthDateDay :: {-# UNPACK #-} !DayOfMonth } deriving (Show,Read,Eq,Ord) --- | A date as represented by the Gregorian calendar --- and a time of day. +-- | 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 @@ -1961,6 +2415,9 @@ , 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 @@ -1992,6 +2449,16 @@ -- ^ 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 @@ -2165,4 +2632,4 @@ aesonParserOffset :: Text -> AET.Parser Offset aesonParserOffset t = case decodeOffset OffsetFormatColonOn t of Nothing -> fail "could not parse Offset" - Just x -> return x + Just x -> pure x 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,8 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE JavaScriptFFI #-} +{-# OPTIONS_HADDOCK hide #-} -- for doctests + module Chronos.Internal.CTimespec ( getPosixNanoseconds + , CTimespec(..) ) where import Foreign @@ -11,8 +14,8 @@ #ifdef ghcjs_HOST_OS foreign import javascript unsafe "Date.now()" currentSeconds :: IO Double getPosixNanoseconds :: IO Int64 -getPosixNanoseconds = do - x <- currentSeconds +getPosixNanoseconds = do + x <- currentSeconds pure $ fromIntegral $ 1000000 * (round x) #else 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,5 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} +{-| 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 + additions to this API. + -} + module Chronos.Locale.English ( lower , upper @@ -13,24 +19,47 @@ import Chronos.Types import Data.Text (Text) +-- $setup +-- +-- >>> :set -XOverloadedStrings +-- >>> import Chronos (january, august, december, october, caseMonth) + +-- | Lowercase "am"/"pm". lower :: MeridiemLocale Text lower = MeridiemLocale "am" "pm" +-- | Uppercase "AM"/"PM". upper :: MeridiemLocale Text upper = MeridiemLocale "AM" "PM" +-- | Lowercase "a.m."/"p.m." lowerDots :: MeridiemLocale Text lowerDots = MeridiemLocale "a.m." "p.m." +-- | Uppercase "A.M."/"P.M." upperDots :: MeridiemLocale Text upperDots = MeridiemLocale "A.M." "P.M." +-- | 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" +-- | 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" diff --git a/src/Chronos/Types.hs b/src/Chronos/Types.hs --- a/src/Chronos/Types.hs +++ b/src/Chronos/Types.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wall -Werror #-} - {- | Data types for representing different date and time-related information. @@ -19,7 +17,7 @@ 1680 and 2260. All other types in this library correctly represent time a million years before or after 1970. - The vector unbox instances, not yet available, will store + The vector unbox instances store data in a reasonably compact manner. For example, the instance for 'Day' has three unboxed vectors: 'Int' for the year, 'Int8' for the month, and 'Int8' for the day. This only causes @@ -53,6 +51,7 @@ , OffsetFormat(..) , DatetimeLocale(..) , MeridiemLocale(..) + , TimeInterval(..) ) where import Chronos diff --git a/test/Doctests.hs b/test/Doctests.hs new file mode 100644 --- /dev/null +++ b/test/Doctests.hs @@ -0,0 +1,8 @@ +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 @@ -6,26 +6,27 @@ module Main (main) where import Chronos.Types -import Data.List (intercalate) -import Test.QuickCheck (Gen, Arbitrary(..), choose, arbitraryBoundedEnum, genericShrink, elements) -import Test.QuickCheck.Property (failed,succeeded,Result(..)) -import Test.Framework (defaultMain, defaultMainWithOpts, testGroup, Test) -import qualified Test.Framework as TF -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion,(@?=),assertBool) -import qualified Test.Framework.Providers.HUnit as PH - -import Data.Text (Text) 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 Data.ByteString.Builder as BBuilder -import qualified Data.ByteString.Lazy as LByteString -import qualified Data.Attoparsec.Text as Atto -import qualified Data.Attoparsec.ByteString as AttoBS -import qualified Chronos as C +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 @@ -38,6 +39,7 @@ 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 } } @@ -183,6 +185,33 @@ , 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 @@ -240,7 +269,6 @@ 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)) @@ -264,6 +292,55 @@ 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) @@ -302,6 +379,20 @@ 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)) -