diff --git a/chronos.cabal b/chronos.cabal --- a/chronos.cabal +++ b/chronos.cabal @@ -1,6 +1,6 @@ -name: chronos -version: 0.4 -synopsis: A performant time library +name: chronos +version: 1.0 +synopsis: A performant time library description: Performance-oriented time library for haskell. The main differences between this and "time" are that this library: @@ -24,41 +24,24 @@ * Only provides nanosecond resolution instead of picosecond resolution. -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 +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 library hs-source-dirs: src exposed-modules: - Chronos.Types - , Chronos.Calendar - , Chronos.Match - , Chronos.Nanoseconds - , Chronos.Day - , Chronos.Date.Text - , Chronos.Date.ByteString.Char7 - , Chronos.Datetime - , Chronos.Datetime.Text - , Chronos.Datetime.ByteString.Char7 - , Chronos.OffsetDatetime.Text - , Chronos.OffsetDatetime.ByteString.Char7 - , Chronos.TimeOfDay.Text - , Chronos.TimeOfDay.ByteString.Char7 - , Chronos.Internal - , Chronos.Internal.Format - , Chronos.Internal.Conversion - , Chronos.Internal.CTimespec - , Chronos.Tai - , Chronos.Posix - , Chronos.Month - , Chronos.Locale.English.Text + Chronos + , Chronos.Types + , Chronos.Locale.English + other-modules: + Chronos.Internal.CTimespec build-depends: base >= 4.8 && < 5 , vector >= 0.11 && < 0.13 @@ -68,10 +51,12 @@ -- Remove support for aeson < 1.0 after the newer -- aeson lands in stackage. Currently, ToJSONKey -- and FromJSONKey instances cannot be added. - , aeson >= 0.11 && < 1.1 + , aeson >= 0.11 && < 1.3 , hashable >= 1.2 && < 1.3 , primitive >= 0.6 && < 0.7 + , torsor >= 0.1 && < 0.2 default-language: Haskell2010 + c-sources: src/cbits/hs-time.c test-suite chronos-test type: exitcode-stdio-1.0 @@ -92,5 +77,5 @@ default-language: Haskell2010 source-repository head - type: git + type: git location: https://github.com/andrewthad/chronos diff --git a/src/Chronos.hs b/src/Chronos.hs new file mode 100644 --- /dev/null +++ b/src/Chronos.hs @@ -0,0 +1,1560 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wall #-} + +module Chronos + ( -- * Functions + -- ** Current + now + , today + , tomorrow + , yesterday + , epoch + -- ** Construction + , datetimeFromYmdhms + , timeFromYmdhms + -- ** Conversion + , timeToDatetime + , datetimeToTime + , timeToOffsetDatetime + , offsetDatetimeToTime + , timeToDayTruncate + , dayToTimeMidnight + , dayToDate + , dateToDay + -- ** Build Timespan + , second + , minute + , hour + , day + , week + -- ** Matching + , buildDayOfWeekMatch + , buildMonthMatch + , caseMonth + -- ** Format + -- $format + , w3c + , slash + , hyphen + , compact + -- ** Months + , january + , february + , march + , april + , may + , june + , july + , august + , september + , october + , november + , december + -- ** Days of Week + , sunday + , monday + , tuesday + , wednesday + , thursday + , friday + , saturday + -- * 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 + -- ** 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 + -- ** 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 + ) where + +import Chronos.Types +import Data.Text (Text) +import Data.Vector (Vector) +import Data.Monoid +import Data.Attoparsec.Text (Parser) +import Control.Monad +import Data.Foldable +import Control.Applicative +import Data.Int (Int64) +import Data.Char (isDigit) +import Data.ByteString (ByteString) +import Torsor (add,difference,scale,plus) +import Chronos.Internal.CTimespec (getPosixNanoseconds) +import Data.Word (Word64) +import qualified Data.Text as Text +import qualified Data.Text.Read as Text +import qualified Data.Attoparsec.Text as AT +import qualified Data.Attoparsec.ByteString.Char8 as AB +import qualified Data.Vector as Vector +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Lazy.Builder.Int as TB +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as BC +import qualified Data.Text.Lazy as LT +import qualified Data.ByteString.Lazy as LB +import qualified Data.Vector.Unboxed as UVector + +second :: Timespan +second = Timespan 1000000000 + +minute :: Timespan +minute = Timespan 60000000000 + +hour :: Timespan +hour = Timespan 3600000000000 + +day :: Timespan +day = Timespan 86400000000000 + +week :: Timespan +week = Timespan 604800000000000 + +-- | Convert 'Time' to 'Datetime'. +timeToDatetime :: Time -> Datetime +timeToDatetime = utcTimeToDatetime . toUtc + +-- | Convert 'Datetime' to 'Time'. +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) + +-- | 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 +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 + +timeFromYmdhms :: Int -> Int -> Int -> Int -> Int -> 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 + +tomorrow :: IO Day +tomorrow = fmap (add 1 . timeToDayTruncate) now + +yesterday :: IO Day +yesterday = fmap (add (-1) . timeToDayTruncate) now + +now :: IO Time +now = fmap Time getPosixNanoseconds + +epoch :: Time +epoch = Time 0 + +data UtcTime = UtcTime + {-# UNPACK #-} !Day -- day + {-# UNPACK #-} !Int64 -- nanoseconds + +toUtc :: Time -> UtcTime +toUtc (Time i) = let (d,t) = divMod i (getTimespan dayLength) + 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) + where ns = Timespan ns' + +intToInt64 :: Int -> Int64 +intToInt64 = fromIntegral + +epochDay :: Day +epochDay = Day 40587 + +dayLength :: Timespan +dayLength = Timespan 86400000000000 + +dayLengthInt64 :: Int64 +dayLengthInt64 = 86400000000000 + +nanosecondsInMinute :: Int64 +nanosecondsInMinute = 60000000000 + +-- | 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 + +-- | Convert 'Day' to a 'Date'. +dayToDate :: Day -> Date +dayToDate theDay = Date year month dayOfMonth + where + OrdinalDate year yd = dayToOrdinalDate theDay + MonthDate month dayOfMonth = dayOfYearToMonthAndDay (isLeapYear year) yd + +-- 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 '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 +monthDateToDayOfYear isLeap (MonthDate month@(Month m) (DayOfMonth dayOfMonth)) = + DayOfYear ((div (367 * (fromIntegral m + 1) - 362) 12) + k + day') + where + day' = fromIntegral $ clip 1 (monthLength isLeap month) dayOfMonth + k = if month < Month 2 then 0 else if isLeap then -1 else -2 + +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 + +isLeapYear :: Year -> Bool +isLeapYear (Year year) = (mod year 4 == 0) && ((mod year 400 == 0) || not (mod year 100 == 0)) + +dayOfYearToMonthAndDay :: Bool -> DayOfYear -> MonthDate +dayOfYearToMonthAndDay isLeap dayOfYear = + let (!upperBound,!monthTable,!dayTable) = + if isLeap + then (DayOfYear 366, leapYearDayOfYearMonthTable, leapYearDayOfYearDayOfMonthTable) + else (DayOfYear 365, normalYearDayOfYearMonthTable, normalYearDayOfYearDayOfMonthTable) + DayOfYear clippedDay = clip (DayOfYear 1) upperBound dayOfYear + clippedDayInt = fromIntegral clippedDay :: Int + month = UVector.unsafeIndex monthTable clippedDayInt + theDay = UVector.unsafeIndex dayTable clippedDayInt + in MonthDate month theDay + +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. + +-} + +w3c :: DatetimeFormat +w3c = DatetimeFormat (Just '-') (Just 'T') (Just ':') + +slash :: DatetimeFormat +slash = DatetimeFormat (Just '/') (Just ' ') (Just ':') + +hyphen :: DatetimeFormat +hyphen = DatetimeFormat (Just '-') (Just ' ') (Just ':') + +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) + +monthLength :: Bool -> Month -> Int +monthLength isLeap m = if isLeap + then internalMatchMonth leapYearMonthLength m + else internalMatchMonth normalYearMonthLength m + +leapYearMonthLength :: MonthMatch Int +leapYearMonthLength = internalBuildMonthMatch 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 + +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 #-} + +buildMonthMatch :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> MonthMatch a +buildMonthMatch = internalBuildMonthMatch + +caseMonth :: MonthMatch a -> Month -> a +caseMonth = internalMatchMonth + +-- | This could be written much more efficiently since we know the +-- exact size the resulting 'Text' will be. +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 + +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 + +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") + return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +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 + return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +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 + return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + +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 + +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") + return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) + + +builder_HMS :: SubsecondPrecision -> Maybe Char -> TimeOfDay -> TB.Builder +builder_HMS sp msep (TimeOfDay h m ns) = + indexTwoDigitTextBuilder h + <> internalBuilder_NS sp msep m ns + +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 + +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 + +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 + +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 + return (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 -> return (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) + -- 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 + return (TimeOfDay h m ns) + else return (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)) + return (fromIntegral result) + ) <|> return 0 + return (s * 1000000000 + nanoseconds) + +countZeroes :: AT.Parser Int +countZeroes = go 0 where + go !i = do + m <- AT.peekChar + case m of + Nothing -> return i + Just c -> if c == '0' + then AT.anyChar *> go (i + 1) + else return 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 + +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 + + + + +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 + +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 + +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 + + +encode_DmyHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> Text +encode_DmyHMS sp format = + LT.toStrict . TB.toLazyText . builder_DmyHMS sp format + +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 + +encode_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> Text +encode_YmdHMS sp format = + LT.toStrict . TB.toLazyText . builder_YmdHMS sp format + +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. +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 + +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 + +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 + + +builderW3C :: Datetime -> TB.Builder +builderW3C = builder_YmdHMS SubsecondPrecisionAuto (DatetimeFormat (Just '-') (Just 'T') (Just ':')) + +decode_YmdHMS :: DatetimeFormat -> Text -> Maybe Datetime +decode_YmdHMS format = + either (const Nothing) Just . AT.parseOnly (parser_YmdHMS format) + +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) + +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) + +decode_DmyHMS :: DatetimeFormat -> Text -> Maybe Datetime +decode_DmyHMS format = + either (const Nothing) Just . AT.parseOnly (parser_DmyHMS format) + +decode_DmyHMS_opt_S :: DatetimeFormat -> Text -> Maybe Datetime +decode_DmyHMS_opt_S format = + either (const Nothing) Just . AT.parseOnly (parser_DmyHMS_opt_S format) + +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) + +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) + +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 +--------------- + +builderUtf8_HMS :: SubsecondPrecision -> Maybe Char -> TimeOfDay -> BB.Builder +builderUtf8_HMS sp msep (TimeOfDay h m ns) = + indexTwoDigitByteStringBuilder h + <> internalBuilderUtf8_NS sp msep m ns + +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 + +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 + +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 + return (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 -> return (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) + -- 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 + return (TimeOfDay h m ns) + else return (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)) + return (fromIntegral result) + ) <|> return 0 + return (s * 1000000000 + nanoseconds) + +countZeroesUtf8 :: AB.Parser Int +countZeroesUtf8 = go 0 where + go !i = do + m <- AB.peekChar + case m of + Nothing -> return i + Just c -> if c == '0' + then AB.anyChar *> go (i + 1) + else return 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.byteString (BC.replicate (d - countDigits newSubsecondPart) '0') + <> int64Builder newSubsecondPart + where + (milli,milliRem) = quotRem nano 1000000 + (micro,microRem) = quotRem nano 1000 + +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 + +encodeUtf8_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> ByteString +encodeUtf8_YmdHMS sp format = + LB.toStrict . BB.toLazyByteString . builderUtf8_YmdHMS sp format + +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 + +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 + +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 + +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 + + +builderUtf8W3C :: Datetime -> BB.Builder +builderUtf8W3C = builderUtf8_YmdHMS SubsecondPrecisionAuto (DatetimeFormat (Just '-') (Just 'T') (Just ':')) + +decodeUtf8_YmdHMS :: DatetimeFormat -> ByteString -> Maybe Datetime +decodeUtf8_YmdHMS format = + either (const Nothing) Just . AB.parseOnly (parserUtf8_YmdHMS format) + +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) + +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) + +decodeUtf8_YmdHMS_opt_S :: DatetimeFormat -> ByteString -> Maybe Datetime +decodeUtf8_YmdHMS_opt_S format = + either (const Nothing) Just . AB.parseOnly (parserUtf8_YmdHMS_opt_S format) + + +builder_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> TB.Builder +builder_YmdHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = + builder_YmdHMS sp datetimeFormat datetime + <> offsetBuilder offsetFormat offset + +parser_YmdHMSz :: OffsetFormat -> DatetimeFormat -> Parser OffsetDatetime +parser_YmdHMSz offsetFormat datetimeFormat = OffsetDatetime + <$> parser_YmdHMS datetimeFormat + <*> offsetParser offsetFormat + +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 + <> " " + <> offsetBuilder offsetFormat offset + +encode_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> Text +encode_YmdHMSz offsetFormat sp datetimeFormat = + LT.toStrict . TB.toLazyText . builder_YmdHMSz offsetFormat sp datetimeFormat + +builder_DmyHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> TB.Builder +builder_DmyHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = + builder_DmyHMS sp datetimeFormat datetime + <> offsetBuilder offsetFormat offset + +parser_DmyHMSz :: OffsetFormat -> DatetimeFormat -> AT.Parser OffsetDatetime +parser_DmyHMSz offsetFormat datetimeFormat = OffsetDatetime + <$> parser_DmyHMS datetimeFormat + <*> offsetParser offsetFormat + +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 + <> " " + <> offsetBuilder offsetFormat offset + +encode_DmyHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> Text +encode_DmyHMSz offsetFormat sp datetimeFormat = + LT.toStrict . TB.toLazyText . builder_DmyHMSz offsetFormat sp datetimeFormat + +builderW3Cz :: OffsetDatetime -> TB.Builder +builderW3Cz = builder_YmdHMSz + OffsetFormatColonOn + SubsecondPrecisionAuto + (DatetimeFormat (Just '-') (Just 'T') (Just ':')) + +offsetBuilder :: OffsetFormat -> Offset -> TB.Builder +offsetBuilder x = case x of + OffsetFormatColonOff -> buildOffset_z + OffsetFormatColonOn -> buildOffset_z1 + OffsetFormatSecondsPrecision -> buildOffset_z2 + OffsetFormatColonAuto -> buildOffset_z3 + +offsetParser :: OffsetFormat -> Parser Offset +offsetParser x = case x of + OffsetFormatColonOff -> parseOffset_z + OffsetFormatColonOn -> parseOffset_z1 + OffsetFormatSecondsPrecision -> parseOffset_z2 + OffsetFormatColonAuto -> parseOffset_z3 + +-- | True means positive, false means negative +parseSignedness :: Parser Bool +parseSignedness = do + c <- AT.anyChar + if c == '-' + then return False + else if c == '+' + then return True + else fail "while parsing offset, expected [+] or [-]" + +parseOffset_z :: Parser Offset +parseOffset_z = do + pos <- parseSignedness + h <- parseFixedDigits 2 + m <- parseFixedDigits 2 + let !res = h * 60 + m + return . Offset $ if pos + then res + else negate res + +parseOffset_z1 :: Parser Offset +parseOffset_z1 = do + pos <- parseSignedness + h <- parseFixedDigits 2 + _ <- AT.char ':' + m <- parseFixedDigits 2 + let !res = h * 60 + m + return . Offset $ if pos + then res + else negate res + +parseOffset_z2 :: AT.Parser Offset +parseOffset_z2 = do + pos <- parseSignedness + h <- parseFixedDigits 2 + _ <- AT.char ':' + m <- parseFixedDigits 2 + _ <- AT.string ":00" + let !res = h * 60 + m + return . 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. +parseOffset_z3 :: AT.Parser Offset +parseOffset_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 + return . Offset $ if pos + then res + else negate res + _ -> return . Offset $ if pos + then h * 60 + else h * (-60) + +buildOffset_z :: Offset -> TB.Builder +buildOffset_z (Offset i) = + let (!a,!b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitTextBuilder a + <> indexTwoDigitTextBuilder b + +buildOffset_z1 :: Offset -> TB.Builder +buildOffset_z1 (Offset i) = + let (!a,!b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitTextBuilder a + <> ":" + <> indexTwoDigitTextBuilder b + +buildOffset_z2 :: Offset -> TB.Builder +buildOffset_z2 (Offset i) = + let (!a,!b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitTextBuilder a + <> ":" + <> indexTwoDigitTextBuilder b + <> ":00" + +buildOffset_z3 :: Offset -> TB.Builder +buildOffset_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 + +builderUtf8_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> BB.Builder +builderUtf8_YmdHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = + builderUtf8_YmdHMS sp datetimeFormat datetime + <> offsetBuilderUtf8 offsetFormat offset + +parserUtf8_YmdHMSz :: OffsetFormat -> DatetimeFormat -> AB.Parser OffsetDatetime +parserUtf8_YmdHMSz offsetFormat datetimeFormat = OffsetDatetime + <$> parserUtf8_YmdHMS datetimeFormat + <*> offsetParserUtf8 offsetFormat + +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 + <> " " + <> offsetBuilderUtf8 offsetFormat offset + +builderUtf8W3Cz :: OffsetDatetime -> BB.Builder +builderUtf8W3Cz = builderUtf8_YmdHMSz + OffsetFormatColonOn + SubsecondPrecisionAuto + (DatetimeFormat (Just '-') (Just 'T') (Just ':')) + +offsetBuilderUtf8 :: OffsetFormat -> Offset -> BB.Builder +offsetBuilderUtf8 x = case x of + OffsetFormatColonOff -> buildOffsetUtf8_z + OffsetFormatColonOn -> buildOffsetUtf8_z1 + OffsetFormatSecondsPrecision -> buildOffsetUtf8_z2 + OffsetFormatColonAuto -> buildOffsetUtf8_z3 + +offsetParserUtf8 :: OffsetFormat -> AB.Parser Offset +offsetParserUtf8 x = case x of + OffsetFormatColonOff -> parseOffsetUtf8_z + OffsetFormatColonOn -> parseOffsetUtf8_z1 + OffsetFormatSecondsPrecision -> parseOffsetUtf8_z2 + OffsetFormatColonAuto -> parseOffsetUtf8_z3 + +-- | True means positive, false means negative +parseSignednessUtf8 :: AB.Parser Bool +parseSignednessUtf8 = do + c <- AB.anyChar + if c == '-' + then return False + else if c == '+' + then return True + else fail "while parsing offset, expected [+] or [-]" + +parseOffsetUtf8_z :: AB.Parser Offset +parseOffsetUtf8_z = do + pos <- parseSignednessUtf8 + h <- parseFixedDigitsIntBS 2 + m <- parseFixedDigitsIntBS 2 + let !res = h * 60 + m + return . Offset $ if pos + then res + else negate res + +parseOffsetUtf8_z1 :: AB.Parser Offset +parseOffsetUtf8_z1 = do + pos <- parseSignednessUtf8 + h <- parseFixedDigitsIntBS 2 + _ <- AB.char ':' + m <- parseFixedDigitsIntBS 2 + let !res = h * 60 + m + return . Offset $ if pos + then res + else negate res + +parseOffsetUtf8_z2 :: AB.Parser Offset +parseOffsetUtf8_z2 = do + pos <- parseSignednessUtf8 + h <- parseFixedDigitsIntBS 2 + _ <- AB.char ':' + m <- parseFixedDigitsIntBS 2 + _ <- AB.string ":00" + let !res = h * 60 + m + return . 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. +parseOffsetUtf8_z3 :: AB.Parser Offset +parseOffsetUtf8_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 + return . Offset $ if pos + then res + else negate res + _ -> return . Offset $ if pos + then h * 60 + else h * (-60) + +buildOffsetUtf8_z :: Offset -> BB.Builder +buildOffsetUtf8_z (Offset i) = + let (!a,!b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitByteStringBuilder a + <> indexTwoDigitByteStringBuilder b + +buildOffsetUtf8_z1 :: Offset -> BB.Builder +buildOffsetUtf8_z1 (Offset i) = + let (!a,!b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitByteStringBuilder a + <> ":" + <> indexTwoDigitByteStringBuilder b + +buildOffsetUtf8_z2 :: Offset -> BB.Builder +buildOffsetUtf8_z2 (Offset i) = + let (!a,!b) = divMod (abs i) 60 + !prefix = if signum i == (-1) then "-" else "+" + in prefix + <> indexTwoDigitByteStringBuilder a + <> ":" + <> indexTwoDigitByteStringBuilder b + <> ":00" + +buildOffsetUtf8_z3 :: Offset -> BB.Builder +buildOffsetUtf8_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 + +january :: Month +january = Month 0 + +february :: Month +february = Month 1 + +march :: Month +march = Month 2 + +april :: Month +april = Month 3 + +may :: Month +may = Month 4 + +june :: Month +june = Month 5 + +july :: Month +july = Month 6 + +august :: Month +august = Month 7 + +september :: Month +september = Month 8 + +october :: Month +october = Month 9 + +november :: Month +november = Month 10 + +december :: Month +december = Month 11 + +sunday :: DayOfWeek +sunday = DayOfWeek 0 + +monday :: DayOfWeek +monday = DayOfWeek 1 + +tuesday :: DayOfWeek +tuesday = DayOfWeek 2 + +wednesday :: DayOfWeek +wednesday = DayOfWeek 3 + +thursday :: DayOfWeek +thursday = DayOfWeek 4 + +friday :: DayOfWeek +friday = DayOfWeek 5 + +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 return 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 return 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 + diff --git a/src/Chronos/Calendar.hs b/src/Chronos/Calendar.hs deleted file mode 100644 --- a/src/Chronos/Calendar.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Chronos.Calendar - ( -- * Enumerations - months - , weekdays - -- * Pattern Matching - , month - , dayOfWeek - -- * Days of Week - , sunday - , monday - , tuesday - , wednesday - , thursday - , friday - , saturday - -- * Months - , january - , february - , march - , april - , may - , june - , july - , august - , september - , october - , november - , december - ) where - -import Chronos.Types -import qualified Data.Vector as Vector - -month :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> Month -> a -month a b c d e f g h i j k l = - let v = Vector.fromList [a,b,c,d,e,f,g,h,i,j,k,l] - in \(Month ix) -> Vector.unsafeIndex v (fromIntegral ix) - -dayOfWeek :: a -> a -> a -> a -> a -> a -> a -> DayOfWeek -> a -dayOfWeek a b c d e f g = - let v = Vector.fromList [a,b,c,d,e,f,g] - in \(DayOfWeek ix) -> Vector.unsafeIndex v (fromIntegral ix) - -months :: [Month] -months = map Month [0..11] - -weekdays :: [DayOfWeek] -weekdays = map DayOfWeek [0..6] - -january :: Month -january = Month 0 - -february :: Month -february = Month 1 - -march :: Month -march = Month 2 - -april :: Month -april = Month 3 - -may :: Month -may = Month 4 - -june :: Month -june = Month 5 - -july :: Month -july = Month 6 - -august :: Month -august = Month 7 - -september :: Month -september = Month 8 - -october :: Month -october = Month 9 - -november :: Month -november = Month 10 - -december :: Month -december = Month 11 - -sunday :: DayOfWeek -sunday = DayOfWeek 0 - -monday :: DayOfWeek -monday = DayOfWeek 1 - -tuesday :: DayOfWeek -tuesday = DayOfWeek 2 - -wednesday :: DayOfWeek -wednesday = DayOfWeek 3 - -thursday :: DayOfWeek -thursday = DayOfWeek 4 - -friday :: DayOfWeek -friday = DayOfWeek 5 - -saturday :: DayOfWeek -saturday = DayOfWeek 6 - diff --git a/src/Chronos/Date/ByteString/Char7.hs b/src/Chronos/Date/ByteString/Char7.hs deleted file mode 100644 --- a/src/Chronos/Date/ByteString/Char7.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Chronos.Date.ByteString.Char7 where - -import Chronos.Types -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder) -import Data.Vector (Vector) -import Data.Monoid -import Data.Attoparsec.ByteString.Char8 (Parser) -import Control.Monad -import Data.Foldable -import qualified Chronos.Internal.Format as Format -import qualified Chronos.Internal as I -import qualified Data.ByteString.Char8 as ByteString -import qualified Data.Attoparsec.ByteString.Char8 as Atto -import qualified Data.Vector as Vector -import qualified Data.ByteString.Builder as Builder - --- | This could be written much more efficiently since we know the --- exact size the resulting 'ByteString' will be. -builder_Ymd :: Maybe Char -> Date -> Builder -builder_Ymd msep (Date (Year y) m d) = case msep of - Nothing -> - Builder.intDec y - <> Format.monthToZeroPaddedDigitBS m - <> Format.zeroPadDayOfMonthBS d - Just sep -> let sepBuilder = Builder.char7 sep in - Builder.intDec y - <> sepBuilder - <> Format.monthToZeroPaddedDigitBS m - <> sepBuilder - <> Format.zeroPadDayOfMonthBS d - -parser_Ymd :: Maybe Char -> Parser Date -parser_Ymd msep = do - y <- I.parseFixedDigitsIntBS 4 - traverse_ Atto.char msep - m <- I.parseFixedDigitsIntBS 2 - when (m < 1 || m > 12) (fail "month must be between 1 and 12") - traverse_ Atto.char msep - d <- I.parseFixedDigitsIntBS 2 - when (d < 1 || d > 31) (fail "day must be between 1 and 31") - return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) - - - diff --git a/src/Chronos/Date/Text.hs b/src/Chronos/Date/Text.hs deleted file mode 100644 --- a/src/Chronos/Date/Text.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Chronos.Date.Text where - -import Chronos.Types -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) -import Data.Vector (Vector) -import Data.Monoid -import Data.Attoparsec.Text (Parser) -import Control.Monad -import Data.Foldable -import qualified Chronos.Internal.Format as Format -import qualified Chronos.Internal as I -import qualified Data.Text as Text -import qualified Data.Text.Read as Text -import qualified Data.Attoparsec.Text as Atto -import qualified Data.Vector as Vector -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Lazy.Builder.Int as Builder - --- | This could be written much more efficiently since we know the --- exact size the resulting 'Text' will be. -builder_Ymd :: Maybe Char -> Date -> Builder -builder_Ymd msep (Date (Year y) m d) = case msep of - Nothing -> - Builder.decimal y - <> Format.monthToZeroPaddedDigit m - <> Format.zeroPadDayOfMonth d - Just sep -> let sepBuilder = Builder.singleton sep in - Builder.decimal y - <> sepBuilder - <> Format.monthToZeroPaddedDigit m - <> sepBuilder - <> Format.zeroPadDayOfMonth d - -parser_Ymd :: Maybe Char -> Parser Date -parser_Ymd msep = do - y <- I.parseFixedDigits 4 - traverse_ Atto.char msep - m <- I.parseFixedDigits 2 - when (m < 1 || m > 12) (fail "month must be between 1 and 12") - traverse_ Atto.char msep - d <- I.parseFixedDigits 2 - when (d < 1 || d > 31) (fail "day must be between 1 and 31") - return (Date (Year y) (Month $ m - 1) (DayOfMonth d)) - - diff --git a/src/Chronos/Datetime.hs b/src/Chronos/Datetime.hs deleted file mode 100644 --- a/src/Chronos/Datetime.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Chronos.Datetime where - -import Chronos.Types -import qualified Chronos.Internal.Conversion as Conv - -fromYmdhms :: Int -> Int -> Int -> Int -> Int -> Int -> Datetime -fromYmdhms 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 error "fromYmdhms: month must be between 1 and 12" - - --- toOffsetDatetime :: Offset -> Datetime -> OffsetDatetime --- toOffsetDatetime = diff --git a/src/Chronos/Datetime/ByteString/Char7.hs b/src/Chronos/Datetime/ByteString/Char7.hs deleted file mode 100644 --- a/src/Chronos/Datetime/ByteString/Char7.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Chronos.Datetime.ByteString.Char7 where - -import Chronos.Types -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder) -import Data.Vector (Vector) -import Data.Monoid -import Data.Attoparsec.ByteString (Parser) -import Control.Monad -import Data.Foldable -import qualified Chronos.Date.ByteString.Char7 as Date -import qualified Chronos.TimeOfDay.ByteString.Char7 as TimeOfDay -import qualified Data.ByteString.Char8 as ByteString -import qualified Data.ByteString.Lazy.Char8 as LByteString -import qualified Data.Attoparsec.ByteString.Char8 as Atto -import qualified Data.Vector as Vector -import qualified Data.ByteString.Lazy.Builder as Builder - -encode_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> ByteString -encode_YmdHMS sp format = - LByteString.toStrict . Builder.toLazyByteString . builder_YmdHMS sp format - -encode_YmdIMS_p :: MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> Datetime -> ByteString -encode_YmdIMS_p a sp b = LByteString.toStrict . Builder.toLazyByteString . builder_YmdIMS_p a sp b - --- | This could be written much more efficiently since we know the --- exact size the resulting 'ByteString' will be. -builder_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> Builder -builder_YmdHMS sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - case msep of - Nothing -> Date.builder_Ymd mdateSep date - <> TimeOfDay.builder_HMS sp mtimeSep time - Just sep -> Date.builder_Ymd mdateSep date - <> Builder.char7 sep - <> TimeOfDay.builder_HMS sp mtimeSep time - -builder_YmdIMS_p :: MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> Datetime -> Builder -builder_YmdIMS_p locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - Date.builder_Ymd mdateSep date - <> maybe mempty Builder.char7 msep - <> TimeOfDay.builder_IMS_p locale sp mtimeSep time - -builder_YmdIMSp :: MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> Datetime -> Builder -builder_YmdIMSp locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - Date.builder_Ymd mdateSep date - <> maybe mempty Builder.char7 msep - <> TimeOfDay.builder_IMS_p locale sp mtimeSep time - - -builderW3 :: Datetime -> Builder -builderW3 = builder_YmdHMS SubsecondPrecisionAuto (DatetimeFormat (Just '-') (Just 'T') (Just ':')) - -decode_YmdHMS :: DatetimeFormat -> ByteString -> Maybe Datetime -decode_YmdHMS format = - either (const Nothing) Just . Atto.parseOnly (parser_YmdHMS format) - -parser_YmdHMS :: DatetimeFormat -> Parser Datetime -parser_YmdHMS (DatetimeFormat mdateSep msep mtimeSep) = do - date <- Date.parser_Ymd mdateSep - traverse_ Atto.char msep - time <- TimeOfDay.parser_HMS mtimeSep - return (Datetime date time) - -parser_YmdHMS_opt_S :: DatetimeFormat -> Parser Datetime -parser_YmdHMS_opt_S (DatetimeFormat mdateSep msep mtimeSep) = do - date <- Date.parser_Ymd mdateSep - traverse_ Atto.char msep - time <- TimeOfDay.parser_HMS_opt_S mtimeSep - return (Datetime date time) - -decode_YmdHMS_opt_S :: DatetimeFormat -> ByteString -> Maybe Datetime -decode_YmdHMS_opt_S format = - either (const Nothing) Just . Atto.parseOnly (parser_YmdHMS_opt_S format) - - - - - diff --git a/src/Chronos/Datetime/Text.hs b/src/Chronos/Datetime/Text.hs deleted file mode 100644 --- a/src/Chronos/Datetime/Text.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Chronos.Datetime.Text where - -import Chronos.Types -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) -import Data.Vector (Vector) -import Data.Monoid -import Data.Attoparsec.Text (Parser) -import Control.Monad -import Data.Foldable -import qualified Chronos.Date.Text as Date -import qualified Chronos.TimeOfDay.Text as TimeOfDay -import qualified Data.Text as Text -import qualified Data.Text.Read as Text -import qualified Data.Attoparsec.Text as Atto -import qualified Data.Vector as Vector -import qualified Data.Text.Lazy as LText -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Lazy.Builder.Int as Builder - -encode_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> Text -encode_YmdHMS sp format = - LText.toStrict . Builder.toLazyText . builder_YmdHMS sp format - -encode_YmdIMS_p :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> Text -encode_YmdIMS_p a sp b = LText.toStrict . Builder.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. -builder_YmdHMS :: SubsecondPrecision -> DatetimeFormat -> Datetime -> Builder -builder_YmdHMS sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - case msep of - Nothing -> Date.builder_Ymd mdateSep date - <> TimeOfDay.builder_HMS sp mtimeSep time - Just sep -> Date.builder_Ymd mdateSep date - <> Builder.singleton sep - <> TimeOfDay.builder_HMS sp mtimeSep time - -builder_YmdIMS_p :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> Builder -builder_YmdIMS_p locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - Date.builder_Ymd mdateSep date - <> maybe mempty Builder.singleton msep - <> TimeOfDay.builder_IMS_p locale sp mtimeSep time - -builder_YmdIMSp :: MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> Datetime -> Builder -builder_YmdIMSp locale sp (DatetimeFormat mdateSep msep mtimeSep) (Datetime date time) = - Date.builder_Ymd mdateSep date - <> maybe mempty Builder.singleton msep - <> TimeOfDay.builder_IMS_p locale sp mtimeSep time - - -builderW3 :: Datetime -> Builder -builderW3 = builder_YmdHMS SubsecondPrecisionAuto (DatetimeFormat (Just '-') (Just 'T') (Just ':')) - -decode_YmdHMS :: DatetimeFormat -> Text -> Maybe Datetime -decode_YmdHMS format = - either (const Nothing) Just . Atto.parseOnly (parser_YmdHMS format) - -parser_YmdHMS :: DatetimeFormat -> Parser Datetime -parser_YmdHMS (DatetimeFormat mdateSep msep mtimeSep) = do - date <- Date.parser_Ymd mdateSep - traverse_ Atto.char msep - time <- TimeOfDay.parser_HMS mtimeSep - return (Datetime date time) - -parser_YmdHMS_opt_S :: DatetimeFormat -> Parser Datetime -parser_YmdHMS_opt_S (DatetimeFormat mdateSep msep mtimeSep) = do - date <- Date.parser_Ymd mdateSep - traverse_ Atto.char msep - time <- TimeOfDay.parser_HMS_opt_S mtimeSep - return (Datetime date time) - -decode_YmdHMS_opt_S :: DatetimeFormat -> Text -> Maybe Datetime -decode_YmdHMS_opt_S format = - either (const Nothing) Just . Atto.parseOnly (parser_YmdHMS_opt_S format) - - - - diff --git a/src/Chronos/Day.hs b/src/Chronos/Day.hs deleted file mode 100644 --- a/src/Chronos/Day.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Chronos.Day - ( add - , diff - , today - , tomorrow - , yesterday - , toDate - , fromDate - ) where - -import Chronos.Types -import Data.Int -import Chronos.Internal.Conversion as Conv -import qualified Chronos.Posix as Posix - --- | Offset by the given number of days. To accomplish --- subtraction, provide a negative number. -add :: Int -> Day -> Day -add = Conv.addDay - --- | Take the difference between two days. -diff :: Day -> Day -> Int -diff = Conv.diffDay - --- | Gets the current POSIX day. This does not take the user\'s --- time zone into account. -today :: IO Day -today = fmap Posix.truncateToDay Posix.now - -tomorrow :: IO Day -tomorrow = fmap (add 1 . Posix.truncateToDay) Posix.now - -yesterday :: IO Day -yesterday = fmap (add (-1) . Posix.truncateToDay) Posix.now - -fromDate :: Date -> Day -fromDate = Conv.dateToDay - -toDate :: Day -> Date -toDate = Conv.dayToDate - diff --git a/src/Chronos/Internal.hs b/src/Chronos/Internal.hs deleted file mode 100644 --- a/src/Chronos/Internal.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Chronos.Internal where - -import Data.Attoparsec.Text (Parser) -import Data.Vector (Vector) -import Data.Text.Lazy.Builder (Builder) -import Data.Word -import Data.Int -import qualified Data.ByteString.Builder as BBuilder -import qualified Data.ByteString.Char8 as BC8 -import qualified Data.Attoparsec.ByteString.Char8 as AB -import qualified Data.Vector.Unboxed as UVector -import qualified Data.Attoparsec.Text as Atto -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Lazy.Builder.Int as Builder -import qualified Data.Text.Read as Text -import qualified Data.Text as Text -import qualified Data.Vector as Vector - -parseFixedDigits :: Int -> Parser Int -parseFixedDigits n = do - t <- Atto.take n - case Text.decimal t of - Left err -> fail err - Right (i,r) -> if Text.null r - then return i - else fail "datetime decoding could not parse integral text" -{-# INLINE parseFixedDigits #-} - -parseFixedDigitsIntBS :: Int -> AB.Parser Int -parseFixedDigitsIntBS n = do - t <- AB.take n - case BC8.readInt t of - Nothing -> fail "datetime decoding could not parse integral bytestring (a)" - Just (i,r) -> if BC8.null r - then return i - else fail "datetime decoding could not parse integral bytestring (b)" -{-# INLINE parseFixedDigitsIntBS #-} - -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] - --- | Only provide positive numbers to this function. -indexTwoDigitTextBuilder :: Int -> Builder -indexTwoDigitTextBuilder i = if i < 100 - then Vector.unsafeIndex twoDigitTextBuilder (fromIntegral i) - else Builder.decimal i -{-# INLINE indexTwoDigitTextBuilder #-} - --- | Only provide positive numbers to this function. -indexTwoDigitByteStringBuilder :: Int -> BBuilder.Builder -indexTwoDigitByteStringBuilder i = if i < 100 - then Vector.unsafeIndex twoDigitByteStringBuilder (fromIntegral i) - else BBuilder.intDec i -{-# INLINE indexTwoDigitByteStringBuilder #-} - -twoDigitByteStringBuilder :: Vector BBuilder.Builder -twoDigitByteStringBuilder = Vector.fromList - $ map (BBuilder.byteString . BC8.pack) twoDigitStrings -{-# NOINLINE twoDigitByteStringBuilder #-} - -twoDigitTextBuilder :: Vector Builder -twoDigitTextBuilder = Vector.fromList - $ map (Builder.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" - ] - -countDigits :: (Integral a) => a -> Int -{-# INLINE countDigits #-} -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 -{-# INLINE clip #-} - 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,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE JavaScriptFFI #-} module Chronos.Internal.CTimespec ( getPosixNanoseconds @@ -9,7 +10,8 @@ #ifdef ghcjs_HOST_OS --- Fix this at some point. +-- foreign import javascript unsafe "Date.now()" currentSeconds :: IO Int64 + getPosixNanoseconds :: IO Int64 getPosixNanoseconds = return 0 @@ -31,8 +33,13 @@ (\hsc_ptr -> pokeByteOff hsc_ptr 0) p s (\hsc_ptr -> pokeByteOff hsc_ptr 8) p ns +#ifdef darwin_HOST_OS +foreign import ccall unsafe "cbits/hs-time.c clock_gettime" + clock_gettime :: Int32 -> Ptr CTimespec -> IO CInt +#else foreign import ccall unsafe "time.h clock_gettime" clock_gettime :: Int32 -> Ptr CTimespec -> IO CInt +#endif -- | Get the current POSIX time from the system clock. getPosixNanoseconds :: IO Int64 diff --git a/src/Chronos/Internal/Conversion.hs b/src/Chronos/Internal/Conversion.hs deleted file mode 100644 --- a/src/Chronos/Internal/Conversion.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module Chronos.Internal.Conversion where - -import Chronos.Types -import Data.Word -import Data.Int -import qualified Chronos.Internal as I -import qualified Data.Vector as Vector -import qualified Data.Vector.Unboxed as UVector - -dayLengthInt64 :: Int64 -dayLengthInt64 = 86400000000000 - -nanosecondsInMinute :: Int64 -nanosecondsInMinute = 60000000000 - --- | 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 - -dayToDate :: Day -> Date -dayToDate day = Date year month dayOfMonth - where - OrdinalDate year yd = dayToOrdinalDate day - MonthDate month dayOfMonth = dayOfYearToMonthAndDay (isLeapYear year) yd - --- 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 !day) = dateToDay date - in UtcTime - (Day (day + dayAdjustment)) - (timeOfDayToNanosecondsSinceMidnight tod) - -dateToDay :: Date -> Day -dateToDay (Date y m d) = ordinalDateToDay $ OrdinalDate y - (monthDateToDayOfYear (isLeapYear y) (MonthDate m d)) - -monthDateToDayOfYear :: Bool -> MonthDate -> DayOfYear -monthDateToDayOfYear isLeap (MonthDate month@(Month m) (DayOfMonth dayOfMonth)) = - DayOfYear ((div (367 * (fromIntegral m + 1) - 362) 12) + k + day') - where - day' = fromIntegral $ I.clip 1 (monthLength isLeap month) dayOfMonth - k = if month < Month 2 then 0 else if isLeap then -1 else -2 - -ordinalDateToDay :: OrdinalDate -> Day -ordinalDateToDay (OrdinalDate year@(Year y') day) = Day mjd where - y = y' - 1 - mjd = (fromIntegral . getDayOfYear $ - (I.clip (DayOfYear 1) (if isLeapYear year then DayOfYear 366 else DayOfYear 365) day) - ) - + (365 * y) - + (div y 4) - (div y 100) - + (div y 400) - 678576 - -isLeapYear :: Year -> Bool -isLeapYear (Year year) = (mod year 4 == 0) && ((mod year 400 == 0) || not (mod year 100 == 0)) - -dayOfYearToMonthAndDay :: Bool -> DayOfYear -> MonthDate -dayOfYearToMonthAndDay isLeap dayOfYear = - let (!upperBound,!monthTable,!dayTable) = - if isLeap - then (DayOfYear 366, leapYearDayOfYearMonthTable, leapYearDayOfYearDayOfMonthTable) - else (DayOfYear 365, normalYearDayOfYearMonthTable, normalYearDayOfYearDayOfMonthTable) - DayOfYear clippedDay = I.clip (DayOfYear 1) upperBound dayOfYear - clippedDayInt = fromIntegral clippedDay :: Int - month = UVector.unsafeIndex monthTable clippedDayInt - day = UVector.unsafeIndex dayTable clippedDayInt - in MonthDate month day - -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 - -internalBuildDayOfWeekMatch :: a -> a -> a -> a -> a -> a -> a -> DayOfWeekMatch a -internalBuildDayOfWeekMatch 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) - -monthLength :: Bool -> Month -> Int -monthLength isLeap m = if isLeap - then internalMatchMonth leapYearMonthLength m - else internalMatchMonth leapYearMonthLength m - -leapYearMonthLength :: MonthMatch Int -leapYearMonthLength = internalBuildMonthMatch 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 - -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 #-} - -addDay :: Int -> Day -> Day -addDay a (Day b) = Day (a + b) -{-# INLINE addDay #-} - -diffDay :: Day -> Day -> Int -diffDay (Day a) (Day b) = a - b -{-# INLINE diffDay #-} - diff --git a/src/Chronos/Internal/Format.hs b/src/Chronos/Internal/Format.hs deleted file mode 100644 --- a/src/Chronos/Internal/Format.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Chronos.Internal.Format where - -import Chronos.Types -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) -import Data.Vector (Vector) -import Data.Monoid -import Data.Attoparsec.Text (Parser) -import Control.Monad -import Data.Foldable -import qualified Data.ByteString.Builder as BBuilder -import qualified Chronos.Internal as I -import qualified Data.Text as Text -import qualified Data.Text.Read as Text -import qualified Data.Attoparsec.Text as Atto -import qualified Data.Vector as Vector -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Lazy.Builder.Int as Builder - -monthToZeroPaddedDigit :: Month -> Builder -monthToZeroPaddedDigit (Month x) = - I.indexTwoDigitTextBuilder (x + 1) - -zeroPadDayOfMonth :: DayOfMonth -> Builder -zeroPadDayOfMonth (DayOfMonth d) = I.indexTwoDigitTextBuilder d - -monthToZeroPaddedDigitBS :: Month -> BBuilder.Builder -monthToZeroPaddedDigitBS (Month x) = - I.indexTwoDigitByteStringBuilder (x + 1) - -zeroPadDayOfMonthBS :: DayOfMonth -> BBuilder.Builder -zeroPadDayOfMonthBS (DayOfMonth d) = I.indexTwoDigitByteStringBuilder d - diff --git a/src/Chronos/Locale/English.hs b/src/Chronos/Locale/English.hs new file mode 100644 --- /dev/null +++ b/src/Chronos/Locale/English.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Chronos.Locale.English + ( lower + , upper + , lowerDots + , upperDots + , abbreviated + , unabbreviated + ) where + +import Chronos (buildMonthMatch) +import Chronos.Types +import Data.Text (Text) + +lower :: MeridiemLocale Text +lower = MeridiemLocale "am" "pm" + +upper :: MeridiemLocale Text +upper = MeridiemLocale "AM" "PM" + +lowerDots :: MeridiemLocale Text +lowerDots = MeridiemLocale "a.m." "p.m." + +upperDots :: MeridiemLocale Text +upperDots = MeridiemLocale "A.M." "P.M." + +unabbreviated :: MonthMatch Text +unabbreviated = buildMonthMatch + "January" "February" "March" "April" + "May" "June" "July" "August" + "September" "October" "November" "December" + +abbreviated :: MonthMatch Text +abbreviated = buildMonthMatch + "Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" + diff --git a/src/Chronos/Locale/English/Text.hs b/src/Chronos/Locale/English/Text.hs deleted file mode 100644 --- a/src/Chronos/Locale/English/Text.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Chronos.Locale.English.Text where - -import Chronos.Types -import qualified Chronos.Month as Month -import Data.Text (Text) - -datetimeW3 :: DatetimeFormat -datetimeW3 = DatetimeFormat (Just '-') (Just 'T') (Just ':') - -datetimeSlash :: DatetimeFormat -datetimeSlash = DatetimeFormat (Just '/') (Just ' ') (Just ':') - -datetimeHyphen :: DatetimeFormat -datetimeHyphen = DatetimeFormat (Just '-') (Just ' ') (Just ':') - -datetimeCompact :: DatetimeFormat -datetimeCompact = DatetimeFormat Nothing (Just 'T') Nothing - -meridiemLower :: MeridiemLocale Text -meridiemLower = MeridiemLocale "am" "pm" - -meridiemUpper :: MeridiemLocale Text -meridiemUpper = MeridiemLocale "AM" "PM" - -meridiemLowerDotted :: MeridiemLocale Text -meridiemLowerDotted = MeridiemLocale "a.m." "p.m." - -meridiemUpperDotted :: MeridiemLocale Text -meridiemUpperDotted = MeridiemLocale "A.M." "P.M." - -monthFull :: MonthMatch Text -monthFull = Month.match - "January" "February" "March" "April" - "May" "June" "July" "August" - "September" "October" "November" "December" - -monthAbbreviated :: MonthMatch Text -monthAbbreviated = Month.match - "Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" - diff --git a/src/Chronos/Match.hs b/src/Chronos/Match.hs deleted file mode 100644 --- a/src/Chronos/Match.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Chronos.Match where - -import Chronos.Types -import qualified Data.Vector as Vector - -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]) - -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.fromList [a,b,c,d,e,f,g,h,i,j,k,l]) - - - diff --git a/src/Chronos/Month.hs b/src/Chronos/Month.hs deleted file mode 100644 --- a/src/Chronos/Month.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Chronos.Month where - -import Chronos.Types -import qualified Chronos.Internal.Conversion as Conv - -month :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> Month -> a -month a b c d e f g h i j k l = - let theMatch = match a b c d e f g h i j k l - in \m -> deconstruct theMatch m - -match :: a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> MonthMatch a -match = Conv.internalBuildMonthMatch - -deconstruct :: MonthMatch a -> Month -> a -deconstruct = Conv.internalMatchMonth - diff --git a/src/Chronos/Nanoseconds.hs b/src/Chronos/Nanoseconds.hs deleted file mode 100644 --- a/src/Chronos/Nanoseconds.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-| Functions that operate on 'Nanoseconds'. All of these functions have - trivial implementations and are provided for convenience. This module - is intended to be imported qualified. --} - -module Chronos.Nanoseconds - ( -- * Arithmetic - add - , scale - , negate - -- * From Duration - -- $fromduration - , fromSeconds - , fromMinutes - , fromHours - , fromDays - , fromWeeks - ) where - -import Prelude hiding (negate) -import qualified Prelude as Prelude -import Data.Int -import Chronos.Types - -add :: Nanoseconds -> Nanoseconds -> Nanoseconds -add (Nanoseconds a) (Nanoseconds b) = Nanoseconds (a + b) - -negate :: Nanoseconds -> Nanoseconds -negate (Nanoseconds a) = Nanoseconds (Prelude.negate a) - -scale :: Int64 -> Nanoseconds -> Nanoseconds -scale i (Nanoseconds x) = Nanoseconds (i * x) - -{- $fromduration - -These functions are at times convenient, but on a fundamental level, -all of them except for 'fromSeconds' are incorrect. If we account for -leap seconds, we must acknowledge that not all minutes contain 60 seconds. -Some contain 61 seconds, and in the future some may contain 59 seconds. - --} - -fromSeconds :: Int64 -> Nanoseconds -fromSeconds = Nanoseconds . (1000000000 *) - -fromMinutes :: Int64 -> Nanoseconds -fromMinutes = Nanoseconds . (60000000000 *) - -fromHours :: Int64 -> Nanoseconds -fromHours = Nanoseconds . (3600000000000 *) - -fromDays :: Int64 -> Nanoseconds -fromDays = Nanoseconds . (86400000000000 *) - -fromWeeks :: Int64 -> Nanoseconds -fromWeeks = Nanoseconds . (604800000000000 *) - diff --git a/src/Chronos/OffsetDatetime/ByteString/Char7.hs b/src/Chronos/OffsetDatetime/ByteString/Char7.hs deleted file mode 100644 --- a/src/Chronos/OffsetDatetime/ByteString/Char7.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} - --- | The naming conventions for offsets that are used in --- function names are as follows: --- --- * @%z@ - @z@ +hhmm numeric time zone (e.g., -0400) --- * @%:z@ - @z1@ +hh:mm numeric time zone (e.g., -04:00) --- * @%::z@ - @z2@ +hh:mm:ss numeric time zone (e.g., -04:00:00) --- * @%:::z@ - @z3@ numeric time zone with : to necessary precision (e.g., -04, +05:30) - -module Chronos.OffsetDatetime.ByteString.Char7 where - -import Chronos.Types -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder) -import Data.Vector (Vector) -import Data.Monoid -import Data.Attoparsec.ByteString (Parser) -import Control.Monad -import Data.Foldable -import Data.Int -import qualified Chronos.Internal as I -import qualified Chronos.Datetime.ByteString.Char7 as Datetime -import qualified Chronos.TimeOfDay.ByteString.Char7 as TimeOfDay -import qualified Data.ByteString.Char8 as ByteString -import qualified Data.Attoparsec.ByteString.Char8 as Atto -import qualified Data.Vector as Vector -import qualified Data.ByteString.Builder as Builder - -builder_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> Builder -builder_YmdHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = - Datetime.builder_YmdHMS sp datetimeFormat datetime - <> offsetBuilder offsetFormat offset - -parser_YmdHMSz :: OffsetFormat -> DatetimeFormat -> Parser OffsetDatetime -parser_YmdHMSz offsetFormat datetimeFormat = OffsetDatetime - <$> Datetime.parser_YmdHMS datetimeFormat - <*> offsetParser offsetFormat - -builder_YmdIMS_p_z :: OffsetFormat -> MeridiemLocale ByteString -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> Builder -builder_YmdIMS_p_z offsetFormat meridiemLocale sp datetimeFormat (OffsetDatetime datetime offset) = - Datetime.builder_YmdIMS_p meridiemLocale sp datetimeFormat datetime - <> " " - <> offsetBuilder offsetFormat offset - -builderW3 :: OffsetDatetime -> Builder -builderW3 = builder_YmdHMSz - OffsetFormatColonOn - SubsecondPrecisionAuto - (DatetimeFormat (Just '-') (Just 'T') (Just ':')) - -offsetBuilder :: OffsetFormat -> Offset -> Builder -offsetBuilder x = case x of - OffsetFormatColonOff -> buildOffset_z - OffsetFormatColonOn -> buildOffset_z1 - OffsetFormatSecondsPrecision -> buildOffset_z2 - OffsetFormatColonAuto -> buildOffset_z3 - -offsetParser :: OffsetFormat -> Parser Offset -offsetParser x = case x of - OffsetFormatColonOff -> parseOffset_z - OffsetFormatColonOn -> parseOffset_z1 - OffsetFormatSecondsPrecision -> parseOffset_z2 - OffsetFormatColonAuto -> parseOffset_z3 - --- | True means positive, false means negative -parseSignedness :: Parser Bool -parseSignedness = do - c <- Atto.anyChar - if c == '-' - then return False - else if c == '+' - then return True - else fail "while parsing offset, expected [+] or [-]" -{-# INLINE parseSignedness #-} - -parseOffset_z :: Parser Offset -parseOffset_z = do - pos <- parseSignedness - h <- I.parseFixedDigitsIntBS 2 - m <- I.parseFixedDigitsIntBS 2 - let !res = h * 60 + m - return . Offset $ if pos - then res - else negate res - -parseOffset_z1 :: Parser Offset -parseOffset_z1 = do - pos <- parseSignedness - h <- I.parseFixedDigitsIntBS 2 - _ <- Atto.char ':' - m <- I.parseFixedDigitsIntBS 2 - let !res = h * 60 + m - return . Offset $ if pos - then res - else negate res - -parseOffset_z2 :: Parser Offset -parseOffset_z2 = do - pos <- parseSignedness - h <- I.parseFixedDigitsIntBS 2 - _ <- Atto.char ':' - m <- I.parseFixedDigitsIntBS 2 - _ <- Atto.string ":00" - let !res = h * 60 + m - return . 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. -parseOffset_z3 :: Parser Offset -parseOffset_z3 = do - pos <- parseSignedness - h <- I.parseFixedDigitsIntBS 2 - mc <- Atto.peekChar - case mc of - Just ':' -> do - _ <- Atto.anyChar -- should be a colon - m <- I.parseFixedDigitsIntBS 2 - let !res = h * 60 + m - return . Offset $ if pos - then res - else negate res - _ -> return . Offset $ if pos - then h * 60 - else h * (-60) - -buildOffset_z :: Offset -> Builder -buildOffset_z (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> I.indexTwoDigitByteStringBuilder a - <> I.indexTwoDigitByteStringBuilder b - -buildOffset_z1 :: Offset -> Builder -buildOffset_z1 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> I.indexTwoDigitByteStringBuilder a - <> ":" - <> I.indexTwoDigitByteStringBuilder b - -buildOffset_z2 :: Offset -> Builder -buildOffset_z2 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> I.indexTwoDigitByteStringBuilder a - <> ":" - <> I.indexTwoDigitByteStringBuilder b - <> ":00" - -buildOffset_z3 :: Offset -> Builder -buildOffset_z3 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in if b == 0 - then prefix - <> I.indexTwoDigitByteStringBuilder a - else prefix - <> I.indexTwoDigitByteStringBuilder a - <> ":" - <> I.indexTwoDigitByteStringBuilder b - diff --git a/src/Chronos/OffsetDatetime/Text.hs b/src/Chronos/OffsetDatetime/Text.hs deleted file mode 100644 --- a/src/Chronos/OffsetDatetime/Text.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} - --- | The naming conventions for offsets that are used in --- function names are as follows: --- --- * @%z@ - @z@ +hhmm numeric time zone (e.g., -0400) --- * @%:z@ - @z1@ +hh:mm numeric time zone (e.g., -04:00) --- * @%::z@ - @z2@ +hh:mm:ss numeric time zone (e.g., -04:00:00) --- * @%:::z@ - @z3@ numeric time zone with : to necessary precision (e.g., -04, +05:30) - -module Chronos.OffsetDatetime.Text where - -import Chronos.Types -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) -import Data.Vector (Vector) -import Data.Monoid -import Data.Attoparsec.Text (Parser) -import Control.Monad -import Data.Foldable -import Data.Int -import qualified Chronos.Internal as I -import qualified Chronos.Datetime.Text as Datetime -import qualified Chronos.TimeOfDay.Text as TimeOfDay -import qualified Data.Text as Text -import qualified Data.Text.Read as Text -import qualified Data.Attoparsec.Text as Atto -import qualified Data.Vector as Vector -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Lazy.Builder.Int as Builder - -builder_YmdHMSz :: OffsetFormat -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> Builder -builder_YmdHMSz offsetFormat sp datetimeFormat (OffsetDatetime datetime offset) = - Datetime.builder_YmdHMS sp datetimeFormat datetime - <> offsetBuilder offsetFormat offset - -parser_YmdHMSz :: OffsetFormat -> DatetimeFormat -> Parser OffsetDatetime -parser_YmdHMSz offsetFormat datetimeFormat = OffsetDatetime - <$> Datetime.parser_YmdHMS datetimeFormat - <*> offsetParser offsetFormat - -builder_YmdIMS_p_z :: OffsetFormat -> MeridiemLocale Text -> SubsecondPrecision -> DatetimeFormat -> OffsetDatetime -> Builder -builder_YmdIMS_p_z offsetFormat meridiemLocale sp datetimeFormat (OffsetDatetime datetime offset) = - Datetime.builder_YmdIMS_p meridiemLocale sp datetimeFormat datetime - <> " " - <> offsetBuilder offsetFormat offset - -builderW3 :: OffsetDatetime -> Builder -builderW3 = builder_YmdHMSz - OffsetFormatColonOn - SubsecondPrecisionAuto - (DatetimeFormat (Just '-') (Just 'T') (Just ':')) - -offsetBuilder :: OffsetFormat -> Offset -> Builder -offsetBuilder x = case x of - OffsetFormatColonOff -> buildOffset_z - OffsetFormatColonOn -> buildOffset_z1 - OffsetFormatSecondsPrecision -> buildOffset_z2 - OffsetFormatColonAuto -> buildOffset_z3 - -offsetParser :: OffsetFormat -> Parser Offset -offsetParser x = case x of - OffsetFormatColonOff -> parseOffset_z - OffsetFormatColonOn -> parseOffset_z1 - OffsetFormatSecondsPrecision -> parseOffset_z2 - OffsetFormatColonAuto -> parseOffset_z3 - --- | True means positive, false means negative -parseSignedness :: Parser Bool -parseSignedness = do - c <- Atto.anyChar - if c == '-' - then return False - else if c == '+' - then return True - else fail "while parsing offset, expected [+] or [-]" -{-# INLINE parseSignedness #-} - -parseOffset_z :: Parser Offset -parseOffset_z = do - pos <- parseSignedness - h <- I.parseFixedDigits 2 - m <- I.parseFixedDigits 2 - let !res = h * 60 + m - return . Offset $ if pos - then res - else negate res - -parseOffset_z1 :: Parser Offset -parseOffset_z1 = do - pos <- parseSignedness - h <- I.parseFixedDigits 2 - _ <- Atto.char ':' - m <- I.parseFixedDigits 2 - let !res = h * 60 + m - return . Offset $ if pos - then res - else negate res - -parseOffset_z2 :: Parser Offset -parseOffset_z2 = do - pos <- parseSignedness - h <- I.parseFixedDigits 2 - _ <- Atto.char ':' - m <- I.parseFixedDigits 2 - _ <- Atto.string ":00" - let !res = h * 60 + m - return . 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. -parseOffset_z3 :: Parser Offset -parseOffset_z3 = do - pos <- parseSignedness - h <- I.parseFixedDigits 2 - mc <- Atto.peekChar - case mc of - Just ':' -> do - _ <- Atto.anyChar -- should be a colon - m <- I.parseFixedDigits 2 - let !res = h * 60 + m - return . Offset $ if pos - then res - else negate res - _ -> return . Offset $ if pos - then h * 60 - else h * (-60) - -buildOffset_z :: Offset -> Builder -buildOffset_z (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> I.indexTwoDigitTextBuilder a - <> I.indexTwoDigitTextBuilder b - -buildOffset_z1 :: Offset -> Builder -buildOffset_z1 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> I.indexTwoDigitTextBuilder a - <> ":" - <> I.indexTwoDigitTextBuilder b - -buildOffset_z2 :: Offset -> Builder -buildOffset_z2 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in prefix - <> I.indexTwoDigitTextBuilder a - <> ":" - <> I.indexTwoDigitTextBuilder b - <> ":00" - -buildOffset_z3 :: Offset -> Builder -buildOffset_z3 (Offset i) = - let (!a,!b) = divMod (abs i) 60 - !prefix = if signum i == (-1) then "-" else "+" - in if b == 0 - then prefix - <> I.indexTwoDigitTextBuilder a - else prefix - <> I.indexTwoDigitTextBuilder a - <> ":" - <> I.indexTwoDigitTextBuilder b diff --git a/src/Chronos/Posix.hs b/src/Chronos/Posix.hs deleted file mode 100644 --- a/src/Chronos/Posix.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module Chronos.Posix - ( epoch - , epochDay - , dayLength - , add - , diff - , now - , toUtc - , fromUtc - , toDatetime - , toOffsetDatetime - , fromDatetime - , fromOffsetDatetime - , truncateToDay - , fromDay - ) where - -import Chronos.Types -import Chronos.Internal.CTimespec -import Chronos.Internal.Conversion as Conv -import Foreign.C.Types (CLong(..),CTime(..)) -import Data.Word -import Data.Int -import qualified Chronos.Nanoseconds as Nanoseconds - -epoch :: PosixTime -epoch = PosixTime 0 - -epochDay :: Day -epochDay = Day 40587 - -dayLength :: Nanoseconds -dayLength = Nanoseconds 86400000000000 - -add :: Nanoseconds -> PosixTime -> PosixTime -add (Nanoseconds a) (PosixTime b) = PosixTime (a + b) - -diff :: PosixTime -> PosixTime -> Nanoseconds -diff (PosixTime a) (PosixTime b) = Nanoseconds (a - b) - --- | This probably needs to be wrapped in a bunch of CPP like --- the one in @time@ is. -now :: IO PosixTime -now = fmap PosixTime getPosixNanoseconds - --- | This may be wrong for dates before what we count as the --- first modified julian day. -toUtc :: PosixTime -> UtcTime -toUtc (PosixTime i) = let (d,t) = divMod i (getNanoseconds dayLength) - in UtcTime (Conv.addDay (fromIntegral d) epochDay) (fromIntegral t) - -fromUtc :: UtcTime -> PosixTime -fromUtc (UtcTime d ns') = PosixTime $ getNanoseconds $ Nanoseconds.add - (Nanoseconds.scale (fromIntegral (Conv.diffDay d epochDay)) dayLength) - (if ns > dayLength then dayLength else ns) - where ns = Nanoseconds (fromIntegral ns') - -toDatetime :: PosixTime -> Datetime -toDatetime = Conv.utcTimeToDatetime . toUtc - -toOffsetDatetime :: Offset -> PosixTime -> OffsetDatetime -toOffsetDatetime offset = Conv.utcTimeToOffsetDatetime offset . toUtc - -fromDatetime :: Datetime -> PosixTime -fromDatetime = fromUtc . Conv.datetimeToUtcTime - -fromOffsetDatetime :: OffsetDatetime -> PosixTime -fromOffsetDatetime = fromUtc . Conv.offsetDatetimeToUtcTime - -truncateToDay :: PosixTime -> Day -truncateToDay (PosixTime i) = Day (fromIntegral (div i 86400000000000) + 40587) - --- | The 'PosixTime' at midnight on the given day. -fromDay :: Day -> PosixTime -fromDay (Day d) = PosixTime (fromIntegral (d - 40587) * 86400000000000) - --- | Convert a 'PosixTime' to a UTC 'Datetime'. --- toDatetime :: PosixTime -> Datetime --- toDatetime (PosixTime i) = let (d,t) = divMod i (getNanoseconds dayLength) --- in UtcTime (Day.add (fromIntegral d) epochDay) (fromIntegral t) - --- ctimespecToPosixSeconds :: CTimespec -> PosixTime --- ctimespecToPosixSeconds (MkCTimespec (CTime s) (CLong ns)) = --- PosixTime ((s * 1000000000) + ns) - diff --git a/src/Chronos/Tai.hs b/src/Chronos/Tai.hs deleted file mode 100644 --- a/src/Chronos/Tai.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Chronos.Tai where - -import Chronos.Types - -epoch :: TaiTime -epoch = TaiTime 0 - -add :: Nanoseconds -> TaiTime -> TaiTime -add (Nanoseconds a) (TaiTime b) = TaiTime (a + b) - -diff :: TaiTime -> TaiTime -> Nanoseconds -diff (TaiTime a) (TaiTime b) = Nanoseconds (a - b) - diff --git a/src/Chronos/TimeOfDay/ByteString/Char7.hs b/src/Chronos/TimeOfDay/ByteString/Char7.hs deleted file mode 100644 --- a/src/Chronos/TimeOfDay/ByteString/Char7.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-| Functions for encoding 'TimeOfDay' to 'ByteString'. Any encoding - that is a superset of ASCII is compatible with the functions in - this module. This includes UTF-8 and ISO-8859-15 but does not - include UTF-16 or UTF-32. --} - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} - -module Chronos.TimeOfDay.ByteString.Char7 where - -import Chronos.Types -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder) -import Data.Vector (Vector) -import Data.Monoid -import Data.Attoparsec.ByteString.Char8 (Parser) -import Control.Monad -import Control.Applicative -import Data.Foldable -import Data.Word -import Data.Int -import Data.Char (isDigit) -import qualified Data.ByteString.Char8 as ByteString -import qualified Chronos.Internal as I -import qualified Data.Text as Text -import qualified Data.Text.Read as Text -import qualified Data.Attoparsec.ByteString.Char8 as Atto -import qualified Data.Vector as Vector -import qualified Data.ByteString.Builder as Builder - --- | This could be written much more efficiently since we know the --- exact size the resulting 'Text' will be. -builder_HMS :: SubsecondPrecision -> Maybe Char -> TimeOfDay -> Builder -builder_HMS sp msep (TimeOfDay h m ns) = - I.indexTwoDigitByteStringBuilder h - <> internalBuilder_NS sp msep m ns - -builder_IMS_p :: MeridiemLocale ByteString -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> Builder -builder_IMS_p meridiemLocale sp msep (TimeOfDay h m ns) = - internalBuilder_I h - <> internalBuilder_NS sp msep h ns - <> " " - <> internalBuilder_p meridiemLocale h - -internalBuilder_I :: Int -> Builder -internalBuilder_I h = - I.indexTwoDigitByteStringBuilder $ if h > 12 - then h - 12 - else if h == 0 - then 12 - else h - -internalBuilder_p :: MeridiemLocale ByteString -> Int -> Builder -internalBuilder_p (MeridiemLocale am pm) h = if h > 11 - then Builder.byteString pm - else Builder.byteString am - -builder_IMSp :: MeridiemLocale ByteString -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> Builder -builder_IMSp meridiemLocale sp msep (TimeOfDay h m ns) = - internalBuilder_I h - <> internalBuilder_NS sp msep h ns - <> internalBuilder_p meridiemLocale h - -parser_HMS :: Maybe Char -> Parser TimeOfDay -parser_HMS msep = do - h <- I.parseFixedDigitsIntBS 2 - when (h > 23) (fail "hour must be between 0 and 23") - traverse_ Atto.char msep - m <- I.parseFixedDigitsIntBS 2 - when (m > 59) (fail "minute must be between 0 and 59") - traverse_ Atto.char msep - ns <- parseSecondsAndNanoseconds - return (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 <- I.parseFixedDigitsIntBS 2 - when (h > 23) (fail "hour must be between 0 and 23") - traverse_ Atto.char msep - m <- I.parseFixedDigitsIntBS 2 - when (m > 59) (fail "minute must be between 0 and 59") - mc <- Atto.peekChar - case mc of - Nothing -> return (TimeOfDay h m 0) - Just c -> case msep of - Just sep -> if c == sep - then do - _ <- Atto.anyChar -- should be the separator - ns <- parseSecondsAndNanoseconds - return (TimeOfDay h m ns) - else return (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 - return (TimeOfDay h m ns) - else return (TimeOfDay h m 0) - -parseSecondsAndNanoseconds :: Parser Int64 -parseSecondsAndNanoseconds = do - s' <- I.parseFixedDigitsIntBS 2 - let !s = fromIntegral s' :: Int64 - when (s > 60) (fail "seconds must be between 0 and 60") - let nanoseconds = 1 - nanoseconds <- - ( do _ <- Atto.char '.' - numberOfZeroes <- countZeroes - x <- Atto.decimal - let totalDigits = I.countDigits x + numberOfZeroes - result = if totalDigits == 9 - then x - else if totalDigits < 9 - then x * I.raiseTenTo (9 - totalDigits) - else quot x (I.raiseTenTo (totalDigits - 9)) - return (fromIntegral result) - ) <|> return 0 - return (s * 1000000000 + nanoseconds) - -countZeroes :: Parser Int -countZeroes = go 0 where - go !i = do - m <- Atto.peekChar - case m of - Nothing -> return i - Just c -> if c == '0' - then Atto.anyChar *> go (i + 1) - else return i - -nanosecondsBuilder :: Int64 -> Builder -nanosecondsBuilder 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 - -microsecondsBuilder :: Int64 -> Builder -microsecondsBuilder 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 - -millisecondsBuilder :: Int64 -> Builder -millisecondsBuilder w - | w == 0 = mempty - | w > 99 = "." <> int64Builder w - | w > 9 = ".0" <> int64Builder w - | otherwise = ".00" <> int64Builder w - -prettyNanosecondsBuilder :: SubsecondPrecision -> Int64 -> 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 (I.raiseTenTo (9 - d)) - in "." - <> Builder.byteString (ByteString.replicate (d - I.countDigits newSubsecondPart) '0') - <> int64Builder newSubsecondPart - where - (milli,milliRem) = quotRem nano 1000000 - (micro,microRem) = quotRem nano 1000 - -int64Builder :: Int64 -> Builder -int64Builder = Builder.integerDec . fromIntegral - -internalBuilder_NS :: SubsecondPrecision -> Maybe Char -> Int -> Int64 -> Builder -internalBuilder_NS sp msep m ns = case msep of - Nothing -> I.indexTwoDigitByteStringBuilder m - <> I.indexTwoDigitByteStringBuilder s - <> prettyNanosecondsBuilder sp nsRemainder - Just sep -> let sepBuilder = Builder.char7 sep in - sepBuilder - <> I.indexTwoDigitByteStringBuilder m - <> sepBuilder - <> I.indexTwoDigitByteStringBuilder s - <> prettyNanosecondsBuilder sp nsRemainder - where - (!sInt64,!nsRemainder) = quotRem ns 1000000000 - !s = fromIntegral sInt64 - - diff --git a/src/Chronos/TimeOfDay/Text.hs b/src/Chronos/TimeOfDay/Text.hs deleted file mode 100644 --- a/src/Chronos/TimeOfDay/Text.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} - -module Chronos.TimeOfDay.Text where - -import Chronos.Types -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) -import Data.Vector (Vector) -import Data.Monoid -import Data.Attoparsec.Text (Parser) -import Control.Monad -import Control.Applicative -import Data.Foldable -import Data.Word -import Data.Int -import Data.Char (isDigit) -import qualified Chronos.Internal as I -import qualified Data.Text as Text -import qualified Data.Text.Read as Text -import qualified Data.Attoparsec.Text as Atto -import qualified Data.Vector as Vector -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Lazy.Builder.Int as Builder - --- | This could be written much more efficiently since we know the --- exact size the resulting 'Text' will be. -builder_HMS :: SubsecondPrecision -> Maybe Char -> TimeOfDay -> Builder -builder_HMS sp msep (TimeOfDay h m ns) = - I.indexTwoDigitTextBuilder h - <> internalBuilder_NS sp msep m ns - -builder_IMS_p :: MeridiemLocale Text -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> Builder -builder_IMS_p meridiemLocale sp msep (TimeOfDay h m ns) = - internalBuilder_I h - <> internalBuilder_NS sp msep h ns - <> " " - <> internalBuilder_p meridiemLocale h - -internalBuilder_I :: Int -> Builder -internalBuilder_I h = - I.indexTwoDigitTextBuilder $ if h > 12 - then h - 12 - else if h == 0 - then 12 - else h - -internalBuilder_p :: MeridiemLocale Text -> Int -> Builder -internalBuilder_p (MeridiemLocale am pm) h = if h > 11 - then Builder.fromText pm - else Builder.fromText am - -builder_IMSp :: MeridiemLocale Text -> SubsecondPrecision -> Maybe Char -> TimeOfDay -> Builder -builder_IMSp meridiemLocale sp msep (TimeOfDay h m ns) = - internalBuilder_I h - <> internalBuilder_NS sp msep h ns - <> internalBuilder_p meridiemLocale h - -parser_HMS :: Maybe Char -> Parser TimeOfDay -parser_HMS msep = do - h <- I.parseFixedDigits 2 - when (h > 23) (fail "hour must be between 0 and 23") - traverse_ Atto.char msep - m <- I.parseFixedDigits 2 - when (m > 59) (fail "minute must be between 0 and 59") - traverse_ Atto.char msep - ns <- parseSecondsAndNanoseconds - return (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 <- I.parseFixedDigits 2 - when (h > 23) (fail "hour must be between 0 and 23") - traverse_ Atto.char msep - m <- I.parseFixedDigits 2 - when (m > 59) (fail "minute must be between 0 and 59") - mc <- Atto.peekChar - case mc of - Nothing -> return (TimeOfDay h m 0) - Just c -> case msep of - Just sep -> if c == sep - then do - _ <- Atto.anyChar -- should be the separator - ns <- parseSecondsAndNanoseconds - return (TimeOfDay h m ns) - else return (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 - return (TimeOfDay h m ns) - else return (TimeOfDay h m 0) - -parseSecondsAndNanoseconds :: Parser Int64 -parseSecondsAndNanoseconds = do - s' <- I.parseFixedDigits 2 - let s = fromIntegral s' :: Int64 - when (s > 60) (fail "seconds must be between 0 and 60") - nanoseconds <- - ( do _ <- Atto.char '.' - numberOfZeroes <- countZeroes - x <- Atto.decimal - let totalDigits = I.countDigits x + numberOfZeroes - result = if totalDigits == 9 - then x - else if totalDigits < 9 - then x * I.raiseTenTo (9 - totalDigits) - else quot x (I.raiseTenTo (totalDigits - 9)) - return (fromIntegral result) - ) <|> return 0 - return (s * 1000000000 + nanoseconds) - -countZeroes :: Parser Int -countZeroes = go 0 where - go !i = do - m <- Atto.peekChar - case m of - Nothing -> return i - Just c -> if c == '0' - then Atto.anyChar *> go (i + 1) - else return i - -nanosecondsBuilder :: Int64 -> Builder -nanosecondsBuilder w - | w == 0 = mempty - | w > 99999999 = "." <> Builder.decimal w - | w > 9999999 = ".0" <> Builder.decimal w - | w > 999999 = ".00" <> Builder.decimal w - | w > 99999 = ".000" <> Builder.decimal w - | w > 9999 = ".0000" <> Builder.decimal w - | w > 999 = ".00000" <> Builder.decimal w - | w > 99 = ".000000" <> Builder.decimal w - | w > 9 = ".0000000" <> Builder.decimal w - | otherwise = ".00000000" <> Builder.decimal w - -microsecondsBuilder :: Int64 -> Builder -microsecondsBuilder w - | w == 0 = mempty - | w > 99999 = "." <> Builder.decimal w - | w > 9999 = ".0" <> Builder.decimal w - | w > 999 = ".00" <> Builder.decimal w - | w > 99 = ".000" <> Builder.decimal w - | w > 9 = ".0000" <> Builder.decimal w - | otherwise = ".00000" <> Builder.decimal w - -millisecondsBuilder :: Int64 -> Builder -millisecondsBuilder w - | w == 0 = mempty - | w > 99 = "." <> Builder.decimal w - | w > 9 = ".0" <> Builder.decimal w - | otherwise = ".00" <> Builder.decimal w - -prettyNanosecondsBuilder :: SubsecondPrecision -> Int64 -> 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 (I.raiseTenTo (9 - d)) - in "." - <> Builder.fromText (Text.replicate (d - I.countDigits newSubsecondPart) "0") - <> Builder.decimal newSubsecondPart - where - (milli,milliRem) = quotRem nano 1000000 - (micro,microRem) = quotRem nano 1000 - -internalBuilder_NS :: SubsecondPrecision -> Maybe Char -> Int -> Int64 -> Builder -internalBuilder_NS sp msep m ns = case msep of - Nothing -> I.indexTwoDigitTextBuilder m - <> I.indexTwoDigitTextBuilder s - <> prettyNanosecondsBuilder sp nsRemainder - Just sep -> let sepBuilder = Builder.singleton sep in - sepBuilder - <> I.indexTwoDigitTextBuilder m - <> sepBuilder - <> I.indexTwoDigitTextBuilder s - <> prettyNanosecondsBuilder sp nsRemainder - where - (!sInt64,!nsRemainder) = quotRem ns 1000000000 - !s = fromIntegral sInt64 - diff --git a/src/Chronos/Types.hs b/src/Chronos/Types.hs --- a/src/Chronos/Types.hs +++ b/src/Chronos/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -43,13 +44,11 @@ , Month(..) , Year(..) , Offset(..) - , TaiTime(..) - , PosixTime(..) - , UtcTime(..) + , Time(..) , DayOfWeekMatch(..) , MonthMatch(..) , UnboxedMonthMatch(..) - , Nanoseconds(..) + , Timespan(..) , SubsecondPrecision(..) , Date(..) , OrdinalDate(..) @@ -63,13 +62,16 @@ , MeridiemLocale(..) ) where +import Torsor import Data.Int import Data.Vector (Vector) import Data.Aeson (FromJSON,ToJSON) import Data.Hashable (Hashable) import Data.Primitive +import Foreign.Storable import Control.Monad import GHC.Generics (Generic) +import Data.Monoid (Monoid(..)) import qualified Data.Vector.Generic as GVector import qualified Data.Vector.Unboxed as UVector import qualified Data.Vector.Primitive as PVector @@ -78,8 +80,12 @@ -- | 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) + 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) @@ -108,16 +114,9 @@ newtype Offset = Offset { getOffset :: Int } deriving (Show,Read,Eq,Ord) --- This is a Modified Julian Day. --- newtype Date = Date { getDate :: Int32 } - --- | TAI time with nanosecond resolution. -newtype TaiTime = TaiTime { getTaiTime :: Int64 } - deriving (FromJSON,ToJSON,Hashable,Eq,Ord,Show,Read) - -- | POSIX time with nanosecond resolution. -newtype PosixTime = PosixTime { getPosixTime :: Int64 } - deriving (FromJSON,ToJSON,Hashable,Eq,Ord,Show,Read) +newtype Time = Time { getTime :: Int64 } + deriving (FromJSON,ToJSON,Hashable,Eq,Ord,Show,Read,Storable,Prim) newtype DayOfWeekMatch a = DayOfWeekMatch { getDayOfWeekMatch :: Vector a } @@ -125,10 +124,22 @@ newtype UnboxedMonthMatch a = UnboxedMonthMatch { getUnboxedMonthMatch :: UVector.Vector a } --- | A nanosecond duration. -newtype Nanoseconds = Nanoseconds { getNanoseconds :: Int64 } - deriving (Show,Read,Eq,Ord,ToJSON,FromJSON) +-- | 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 Monoid Timespan where + mempty = Timespan 0 + mappend (Timespan a) (Timespan b) = Timespan (a + b) + +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) + -- | The precision used when encoding seconds to a human-readable format. data SubsecondPrecision = SubsecondPrecisionAuto -- ^ Rounds to second, millisecond, microsecond, or nanosecond @@ -171,11 +182,6 @@ { timeOfDayHour :: {-# UNPACK #-} !Int , timeOfDayMinute :: {-# UNPACK #-} !Int , timeOfDayNanoseconds :: {-# UNPACK #-} !Int64 - } deriving (Show,Read,Eq,Ord) - -data UtcTime = UtcTime - { utcTimeDate :: {-# UNPACK #-} !Day - , utcTimeNanoseconds :: {-# UNPACK #-} !Int64 } deriving (Show,Read,Eq,Ord) data DatetimeFormat = DatetimeFormat diff --git a/src/cbits/hs-time.c b/src/cbits/hs-time.c new file mode 100644 --- /dev/null +++ b/src/cbits/hs-time.c @@ -0,0 +1,12 @@ +#ifdef __MACH__ +#include +//clock_gettime is not implemented on OSX +int clock_gettime(int clk_id, struct timespec* t) { + struct timeval now; + int rv = gettimeofday(&now, NULL); + if (rv) return rv; + t->tv_sec = now.tv_sec; + t->tv_nsec = now.tv_usec * 1000; + return 0; +} +#endif diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,15 +12,12 @@ import Test.Framework (defaultMain, defaultMainWithOpts, testGroup, Test) import qualified Test.Framework as TF import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion,(@?=),assertBool) +import qualified Test.Framework.Providers.HUnit as PH import Data.Text (Text) import Data.ByteString (ByteString) import Data.Text.Lazy.Builder (Builder) -import qualified Chronos.Internal.Conversion as Conv -import qualified Chronos.Calendar as Month -import qualified Chronos.Posix as Posix import qualified Data.Text as Text import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Builder as Builder @@ -28,11 +25,7 @@ import qualified Data.ByteString.Lazy as LByteString import qualified Data.Attoparsec.Text as Atto import qualified Data.Attoparsec.ByteString as AttoBS -import qualified Chronos.TimeOfDay.Text as TimeOfDayText -import qualified Chronos.TimeOfDay.ByteString.Char7 as TimeOfDayByteString -import qualified Chronos.Datetime.Text as DatetimeText -import qualified Chronos.OffsetDatetime.Text as OffsetDatetimeText -import qualified Chronos.Date.Text as DateText +import qualified Chronos as C -- We increase the default number of property-based tests (provided -- by quickcheck) to 1000. Some of the encoding and decoding functions @@ -53,151 +46,141 @@ [ testGroup "Time of Day" [ testGroup "Text" [ testGroup "Text Parsing Spec Tests" - [ testCase "No Separator + microseconds" + [ PH.testCase "No Separator + microseconds" (timeOfDayParse Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) - , testCase "Separator + microseconds" + , PH.testCase "Separator + microseconds" (timeOfDayParse (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) - , testCase "Separator + milliseconds" + , PH.testCase "Separator + milliseconds" (timeOfDayParse (Just ':') "05:00:58.675" (TimeOfDay 05 00 58675000000)) - , testCase "Separator + deciseconds" + , PH.testCase "Separator + deciseconds" (timeOfDayParse (Just ':') "05:00:58.9" (TimeOfDay 05 00 58900000000)) - , testCase "Separator + no subseconds" + , PH.testCase "Separator + no subseconds" (timeOfDayParse (Just ':') "23:08:01" (TimeOfDay 23 8 1000000000)) - , testCase "Separator + nanoseconds" + , PH.testCase "Separator + nanoseconds" (timeOfDayParse (Just ':') "05:00:58.111222999" (TimeOfDay 05 00 58111222999)) - , testCase "Separator + 10e-18 seconds (truncate)" + , PH.testCase "Separator + 10e-18 seconds (truncate)" (timeOfDayParse (Just ':') "05:00:58.111222333444555666" (TimeOfDay 05 00 58111222333)) - , testCase "Separator + opt seconds (absent)" - (parseMatch (TimeOfDayText.parser_HMS_opt_S (Just ':')) "00:01" (TimeOfDay 0 1 0)) - , testCase "Separator + opt seconds (present)" - (parseMatch (TimeOfDayText.parser_HMS_opt_S (Just ':')) "00:01:05" (TimeOfDay 0 1 5000000000)) - , testCase "No Separator + opt seconds (absent)" - (parseMatch (TimeOfDayText.parser_HMS_opt_S Nothing) "0001" (TimeOfDay 0 1 0)) - , testCase "No Separator + opt seconds (present)" - (parseMatch (TimeOfDayText.parser_HMS_opt_S Nothing) "000105" (TimeOfDay 0 1 5000000000)) + , 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" - [ testCase "No Separator + microseconds" + [ PH.testCase "No Separator + microseconds" (timeOfDayBuilder (SubsecondPrecisionFixed 6) Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) - , testCase "Separator + microseconds" + , PH.testCase "Separator + microseconds" (timeOfDayBuilder (SubsecondPrecisionFixed 6) (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) - , testCase "Separator + no subseconds" + , 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 . TimeOfDayText.builder_HMS (SubsecondPrecisionFixed 9) (Just ':')) - (either (const Nothing) Just . Atto.parseOnly (TimeOfDayText.parser_HMS (Just ':'))) + (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" - [ testCase "No Separator + microseconds" + [ PH.testCase "No Separator + microseconds" (bsTimeOfDayParse Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) - , testCase "Separator + microseconds" + , PH.testCase "Separator + microseconds" (bsTimeOfDayParse (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) - , testCase "Separator + milliseconds" + , PH.testCase "Separator + milliseconds" (bsTimeOfDayParse (Just ':') "05:00:58.675" (TimeOfDay 05 00 58675000000)) - , testCase "Separator + deciseconds" + , PH.testCase "Separator + deciseconds" (bsTimeOfDayParse (Just ':') "05:00:58.9" (TimeOfDay 05 00 58900000000)) - , testCase "Separator + no subseconds" + , PH.testCase "Separator + no subseconds" (bsTimeOfDayParse (Just ':') "23:08:01" (TimeOfDay 23 8 1000000000)) - , testCase "Separator + nanoseconds" + , PH.testCase "Separator + nanoseconds" (bsTimeOfDayParse (Just ':') "05:00:58.111222999" (TimeOfDay 05 00 58111222999)) - , testCase "Separator + 10e-18 seconds (truncate)" + , PH.testCase "Separator + 10e-18 seconds (truncate)" (bsTimeOfDayParse (Just ':') "05:00:58.111222333444555666" (TimeOfDay 05 00 58111222333)) - , testCase "Separator + opt seconds (absent)" - (bsParseMatch (TimeOfDayByteString.parser_HMS_opt_S (Just ':')) "00:01" (TimeOfDay 0 1 0)) - , testCase "Separator + opt seconds (present)" - (bsParseMatch (TimeOfDayByteString.parser_HMS_opt_S (Just ':')) "00:01:05" (TimeOfDay 0 1 5000000000)) - , testCase "No Separator + opt seconds (absent)" - (bsParseMatch (TimeOfDayByteString.parser_HMS_opt_S Nothing) "0001" (TimeOfDay 0 1 0)) - , testCase "No Separator + opt seconds (present)" - (bsParseMatch (TimeOfDayByteString.parser_HMS_opt_S Nothing) "000105" (TimeOfDay 0 1 5000000000)) + , 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" - [ testCase "No Separator + microseconds" + [ PH.testCase "No Separator + microseconds" (bsTimeOfDayBuilder (SubsecondPrecisionFixed 6) Nothing "165956.246052" (TimeOfDay 16 59 56246052000)) - , testCase "Separator + microseconds" + , PH.testCase "Separator + microseconds" (bsTimeOfDayBuilder (SubsecondPrecisionFixed 6) (Just ':') "16:59:56.246052" (TimeOfDay 16 59 56246052000)) - , testCase "Separator + no subseconds" + , 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 . TimeOfDayByteString.builder_HMS (SubsecondPrecisionFixed 9) (Just ':')) - (either (const Nothing) Just . AttoBS.parseOnly (TimeOfDayByteString.parser_HMS (Just ':'))) + (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" $ - [ testCase "No Separator" + [ PH.testCase "No Separator" (dateParse Nothing "20160101" (Date (Year 2016) (Month 0) (DayOfMonth 1))) - , testCase "Separator 1" + , PH.testCase "Separator 1" (dateParse (Just '-') "2016-01-01" (Date (Year 2016) (Month 0) (DayOfMonth 1))) - , testCase "Separator 2" + , PH.testCase "Separator 2" (dateParse (Just '-') "1876-09-27" (Date (Year 1876) (Month 8) (DayOfMonth 27))) ] , testGroup "Builder Spec Tests" $ - [ testCase "No Separator" + [ PH.testCase "No Separator" (dateBuilder Nothing "20160101" (Date (Year 2016) (Month 0) (DayOfMonth 1))) - , testCase "Separator 1" + , PH.testCase "Separator 1" (dateBuilder (Just '-') "2016-01-01" (Date (Year 2016) (Month 0) (DayOfMonth 1))) - , testCase "Separator 2" + , 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 . DateText.builder_Ymd (Just '-')) - (either (const Nothing) Just . Atto.parseOnly (DateText.parser_Ymd (Just '-'))) + (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 . DatetimeText.builder_YmdHMS (SubsecondPrecisionFixed 9) format) - (\format -> either (const Nothing) Just . Atto.parseOnly (DatetimeText.parser_YmdHMS format)) + (\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 . DatetimeText.builder_YmdHMS (SubsecondPrecisionFixed 9) (DatetimeFormat Nothing Nothing Nothing)) - (either (const Nothing) Just . Atto.parseOnly (DatetimeText.parser_YmdHMS (DatetimeFormat Nothing Nothing Nothing))) + (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" $ - [ testCase "W3C" $ matchBuilder "1997-07-16T19:20:30.450+01:00" $ - OffsetDatetimeText.builderW3 $ OffsetDatetime + [ PH.testCase "W3C" $ matchBuilder "1997-07-16T19:20:30.450+01:00" $ + C.builderW3Cz $ OffsetDatetime ( Datetime - ( Date (Year 1997) Month.july (DayOfMonth 16) ) + ( 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 $ - OffsetDatetimeText.builder_YmdHMSz offsetFormat (SubsecondPrecisionFixed 9) datetimeFormat offsetDatetime + C.builder_YmdHMSz offsetFormat (SubsecondPrecisionFixed 9) datetimeFormat offsetDatetime ) (\(offsetFormat,datetimeFormat) input -> either (const Nothing) Just $ flip Atto.parseOnly input $ - OffsetDatetimeText.parser_YmdHMSz offsetFormat datetimeFormat + C.parser_YmdHMSz offsetFormat datetimeFormat ) ] , testGroup "Posix Time" - [ testCase "Get now" $ do - now <- Posix.now - assertBool "Current time is the beginning of the epoch." (now /= Posix.epoch) + [ 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 UTC" - [ -- Technically, this should fail, but it is very unlikely that quickcheck - -- will pick a leapsecond. Actually, since we are going from posix to utc - -- first, I think that this cannot fail. - testProperty "Isomorphism" $ propEncodeDecodeFullIso Posix.toUtc Posix.fromUtc - ] - , testGroup "UTC to Datetime" - [ testProperty "Isomorphism" - $ propEncodeDecodeFullIso Conv.utcTimeToDatetime Conv.datetimeToUtcTime - ] - , testGroup "POSIX to Datetime" - [ testCase "Epoch" $ Posix.toDatetime (PosixTime 0) - @?= Datetime (Date (Year 1970) Month.january (DayOfMonth 1)) + [ testGroup "POSIX to Datetime" + [ PH.testCase "Epoch" $ C.timeToDatetime (Time 0) + @?= Datetime (Date (Year 1970) C.january (DayOfMonth 1)) (TimeOfDay 0 0 0) - , testCase "Billion Seconds" $ Posix.toDatetime (PosixTime $ 10 ^ 18) - @?= Datetime (Date (Year 2001) Month.september (DayOfMonth 9)) + , 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 Posix.toDatetime Posix.fromDatetime + , testProperty "Isomorphism" $ propEncodeDecodeFullIso C.timeToDatetime C.datetimeToTime ] ] ] @@ -249,33 +232,33 @@ timeOfDayParse :: Maybe Char -> Text -> TimeOfDay -> Assertion timeOfDayParse m t expected = - Atto.parseOnly (TimeOfDayText.parser_HMS m <* Atto.endOfInput) t + Atto.parseOnly (C.parser_HMS m <* Atto.endOfInput) t @?= Right expected bsTimeOfDayParse :: Maybe Char -> ByteString -> TimeOfDay -> Assertion bsTimeOfDayParse m t expected = - AttoBS.parseOnly (TimeOfDayByteString.parser_HMS m <* AttoBS.endOfInput) t + 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 (TimeOfDayText.builder_HMS sp m 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 (TimeOfDayText.builder_HMS sp m tod)) + LText.toStrict (Builder.toLazyText (C.builder_HMS sp m tod)) @?= expected dateParse :: Maybe Char -> Text -> Date -> Assertion dateParse m t expected = - Atto.parseOnly (DateText.parser_Ymd m <* Atto.endOfInput) t + 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 (DateText.builder_Ymd m tod)) + LText.toStrict (Builder.toLazyText (C.builder_Ymd m tod)) @?= expected matchBuilder :: Text -> Builder -> Assertion @@ -297,10 +280,10 @@ 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 UtcTime where +-- arbitrary = UtcTime +-- <$> fmap Day (choose (-100000,100000)) +-- <*> choose (0,24 * 60 * 60 * 1000000000 - 1) instance Arbitrary OffsetDatetime where arbitrary = OffsetDatetime @@ -317,7 +300,7 @@ arbitrary = arbitraryBoundedEnum shrink = genericShrink -deriving instance Arbitrary PosixTime +deriving instance Arbitrary Time instance Arbitrary Offset where arbitrary = fmap Offset (choose ((-24) * 60, 24 * 60))