From 7cb9669de6e4495b03bc6ee742f14da95ce8ab36 Mon Sep 17 00:00:00 2001 From: Ashley Yakeley Date: Thu, 29 Feb 2024 00:39:11 -0800 Subject: [PATCH] format --- lib/Data/Format.hs | 31 +- lib/Data/Time/Calendar/Days.hs | 18 +- lib/Data/Time/Calendar/Gregorian.hs | 78 +-- lib/Data/Time/Calendar/Julian.hs | 78 +-- lib/Data/Time/Calendar/OrdinalDate.hs | 52 +- lib/Data/Time/Calendar/Private.hs | 22 +- lib/Data/Time/Calendar/WeekDate.hs | 74 ++- lib/Data/Time/Clock/Internal/DiffTime.hs | 8 +- lib/Data/Time/Clock/POSIX.hs | 8 +- lib/Data/Time/Clock/System.hs | 72 +-- lib/Data/Time/Clock/TAI.hs | 24 +- lib/Data/Time/Format/Format/Class.hs | 106 ++-- lib/Data/Time/Format/Format/Instances.hs | 59 +- lib/Data/Time/Format/ISO8601.hs | 159 ++--- lib/Data/Time/Format/Internal.hs | 4 +- lib/Data/Time/Format/Parse/Class.hs | 248 ++++---- lib/Data/Time/Format/Parse/Instances.hs | 553 +++++++++--------- lib/Data/Time/LocalTime/Internal/TimeOfDay.hs | 14 +- lib/Data/Time/LocalTime/Internal/TimeZone.hs | 26 +- test/ShowDST.hs | 21 +- test/main/Test/Arbitrary.hs | 80 +-- test/main/Test/Calendar/ClipDates.hs | 8 +- test/main/Test/Calendar/ConvertBack.hs | 30 +- test/main/Test/Calendar/DayPeriod.hs | 28 +- test/main/Test/Calendar/Duration.hs | 28 +- test/main/Test/Calendar/Easter.hs | 36 +- test/main/Test/Calendar/MonthDay.hs | 7 +- test/main/Test/Calendar/Valid.hs | 82 +-- test/main/Test/Calendar/Week.hs | 53 +- test/main/Test/Clock/Conversion.hs | 30 +- test/main/Test/Clock/TAI.hs | 30 +- test/main/Test/Format/Compile.hs | 3 +- test/main/Test/Format/Format.hs | 28 +- test/main/Test/Format/ISO8601.hs | 49 +- test/main/Test/Format/ParseTime.hs | 187 +++--- test/main/Test/LocalTime/Time.hs | 55 +- test/main/Test/LocalTime/TimeOfDay.hs | 20 +- test/unix/Test/Format/Format.hs | 50 +- test/unix/Test/LocalTime/TimeZone.hs | 3 +- test/unix/Test/TestUtil.hs | 2 +- 40 files changed, 1362 insertions(+), 1102 deletions(-) diff --git a/lib/Data/Format.hs b/lib/Data/Format.hs index 70f91c69..08045b57 100644 --- a/lib/Data/Format.hs +++ b/lib/Data/Format.hs @@ -52,7 +52,7 @@ class IsoVariant f => Summish f where pVoid :: f Void (<++>) :: f a -> f b -> f (Either a b) -parseReader :: (MonadFail m) => ReadP t -> String -> m t +parseReader :: MonadFail m => ReadP t -> String -> m t parseReader readp s = case [t | (t, "") <- readP_to_S readp s] of [t] -> return t @@ -75,7 +75,7 @@ formatShow fmt t = Nothing -> error "formatShow: bad value" -- | Parse a value in the format -formatParseM :: (MonadFail m) => Format t -> String -> m t +formatParseM :: MonadFail m => Format t -> String -> m t formatParseM format = parseReader $ formatReadP format instance IsoVariant Format where @@ -119,7 +119,8 @@ instance Productish Format where a <- ra b <- rb return (a, b) - in MkFormat sab rab + in + MkFormat sab rab (MkFormat sa ra) **> (MkFormat sb rb) = let s b = do @@ -129,7 +130,8 @@ instance Productish Format where r = do ra rb - in MkFormat s r + in + MkFormat s r (MkFormat sa ra) <** (MkFormat sb rb) = let s a = do @@ -140,7 +142,8 @@ instance Productish Format where a <- ra rb return a - in MkFormat s r + in + MkFormat s r instance Summish Format where pVoid = MkFormat absurd pfail @@ -149,7 +152,8 @@ instance Summish Format where sab (Left a) = sa a sab (Right b) = sb b rab = (fmap Left ra) +++ (fmap Right rb) - in MkFormat sab rab + in + MkFormat sab rab literalFormat :: String -> Format () literalFormat s = MkFormat{formatShowM = \_ -> Just s, formatReadP = string s >> return ()} @@ -160,7 +164,8 @@ specialCaseShowFormat (val, str) (MkFormat s r) = s' t | t == val = Just str s' t = s t - in MkFormat s' r + in + MkFormat s' r specialCaseFormat :: Eq a => (a, String) -> Format a -> Format a specialCaseFormat (val, str) (MkFormat s r) = @@ -169,7 +174,8 @@ specialCaseFormat (val, str) (MkFormat s r) = | t == val = Just str s' t = s t r' = (string str >> return val) +++ r - in MkFormat s' r' + in + MkFormat s' r' optionalFormat :: Eq a => a -> Format a -> Format a optionalFormat val = specialCaseFormat (val, "") @@ -180,7 +186,8 @@ casesFormat pairs = s t = lookup t pairs r [] = pfail r ((v, str) : pp) = (string str >> return v) <++ r pp - in MkFormat s $ r pairs + in + MkFormat s $ r pairs optionalSignFormat :: (Eq t, Num t) => Format t optionalSignFormat = casesFormat [(1, ""), (1, "+"), (0, ""), (-1, "-")] @@ -232,8 +239,10 @@ showNumber signOpt mdigitcount t = showIt str = let (intPart, decPart) = break ((==) '.') str - in (zeroPad mdigitcount intPart) ++ trimTrailing decPart - in case show t of + in + (zeroPad mdigitcount intPart) ++ trimTrailing decPart + in + case show t of ('-' : str) -> case signOpt of NoSign -> Nothing diff --git a/lib/Data/Time/Calendar/Days.hs b/lib/Data/Time/Calendar/Days.hs index e76d3330..98c8f522 100644 --- a/lib/Data/Time/Calendar/Days.hs +++ b/lib/Data/Time/Calendar/Days.hs @@ -83,10 +83,12 @@ periodLength p = succ $ fromInteger $ diffDays (periodLastDay p) (periodFirstDay -- -- @since 1.12.1 periodFromDay :: DayPeriod p => Day -> (p, Int) -periodFromDay d = let - p = dayPeriod d - dt = succ $ fromInteger $ diffDays d $ periodFirstDay p - in (p, dt) +periodFromDay d = + let + p = dayPeriod d + dt = succ $ fromInteger $ diffDays d $ periodFirstDay p + in + (p, dt) -- | Inverse of 'periodFromDay'. -- @@ -98,9 +100,11 @@ periodToDay p i = addDays (toInteger $ pred i) $ periodFirstDay p -- -- @since 1.12.1 periodToDayValid :: DayPeriod p => p -> Int -> Maybe Day -periodToDayValid p i = let - d = periodToDay p i - in if fst (periodFromDay d) == p then Just d else Nothing +periodToDayValid p i = + let + d = periodToDay p i + in + if fst (periodFromDay d) == p then Just d else Nothing instance DayPeriod Day where periodFirstDay = id diff --git a/lib/Data/Time/Calendar/Gregorian.hs b/lib/Data/Time/Calendar/Gregorian.hs index f21d0368..be5a8481 100644 --- a/lib/Data/Time/Calendar/Gregorian.hs +++ b/lib/Data/Time/Calendar/Gregorian.hs @@ -133,44 +133,52 @@ addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregori -- | Calendrical difference, with as many whole months as possible diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays -diffGregorianDurationClip day2 day1 = let - (y1, m1, d1) = toGregorian day1 - (y2, m2, d2) = toGregorian day2 - ym1 = y1 * 12 + toInteger m1 - ym2 = y2 * 12 + toInteger m2 - ymdiff = ym2 - ym1 - ymAllowed = - if day2 >= day1 - then - if d2 >= d1 - then ymdiff - else ymdiff - 1 - else - if d2 <= d1 - then ymdiff - else ymdiff + 1 - dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1 - in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed +diffGregorianDurationClip day2 day1 = + let + (y1, m1, d1) = toGregorian day1 + (y2, m2, d2) = toGregorian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + ymAllowed = + if day2 >= day1 + then + if d2 >= d1 + then ymdiff + else ymdiff - 1 + else + if d2 <= d1 + then ymdiff + else ymdiff + 1 + dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1 + in + CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed -- | Calendrical difference, with as many whole months as possible. diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays -diffGregorianDurationRollOver day2 day1 = let - (y1, m1, _) = toGregorian day1 - (y2, m2, _) = toGregorian day2 - ym1 = y1 * 12 + toInteger m1 - ym2 = y2 * 12 + toInteger m2 - ymdiff = ym2 - ym1 - findpos mdiff = let - dayAllowed = addGregorianDurationRollOver (CalendarDiffDays mdiff 0) day1 - dd = diffDays day2 dayAllowed - in if dd >= 0 then CalendarDiffDays mdiff dd else findpos (pred mdiff) - findneg mdiff = let - dayAllowed = addGregorianDurationRollOver (CalendarDiffDays mdiff 0) day1 - dd = diffDays day2 dayAllowed - in if dd <= 0 then CalendarDiffDays mdiff dd else findpos (succ mdiff) - in if day2 >= day1 - then findpos ymdiff - else findneg ymdiff +diffGregorianDurationRollOver day2 day1 = + let + (y1, m1, _) = toGregorian day1 + (y2, m2, _) = toGregorian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + findpos mdiff = + let + dayAllowed = addGregorianDurationRollOver (CalendarDiffDays mdiff 0) day1 + dd = diffDays day2 dayAllowed + in + if dd >= 0 then CalendarDiffDays mdiff dd else findpos (pred mdiff) + findneg mdiff = + let + dayAllowed = addGregorianDurationRollOver (CalendarDiffDays mdiff 0) day1 + dd = diffDays day2 dayAllowed + in + if dd <= 0 then CalendarDiffDays mdiff dd else findpos (succ mdiff) + in + if day2 >= day1 + then findpos ymdiff + else findneg ymdiff -- orphan instance instance Show Day where diff --git a/lib/Data/Time/Calendar/Julian.hs b/lib/Data/Time/Calendar/Julian.hs index 4be7dfd5..861c4b9e 100644 --- a/lib/Data/Time/Calendar/Julian.hs +++ b/lib/Data/Time/Calendar/Julian.hs @@ -125,41 +125,49 @@ addJulianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addJulianMont -- | Calendrical difference, with as many whole months as possible diffJulianDurationClip :: Day -> Day -> CalendarDiffDays -diffJulianDurationClip day2 day1 = let - (y1, m1, d1) = toJulian day1 - (y2, m2, d2) = toJulian day2 - ym1 = y1 * 12 + toInteger m1 - ym2 = y2 * 12 + toInteger m2 - ymdiff = ym2 - ym1 - ymAllowed = - if day2 >= day1 - then - if d2 >= d1 - then ymdiff - else ymdiff - 1 - else - if d2 <= d1 - then ymdiff - else ymdiff + 1 - dayAllowed = addJulianDurationClip (CalendarDiffDays ymAllowed 0) day1 - in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed +diffJulianDurationClip day2 day1 = + let + (y1, m1, d1) = toJulian day1 + (y2, m2, d2) = toJulian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + ymAllowed = + if day2 >= day1 + then + if d2 >= d1 + then ymdiff + else ymdiff - 1 + else + if d2 <= d1 + then ymdiff + else ymdiff + 1 + dayAllowed = addJulianDurationClip (CalendarDiffDays ymAllowed 0) day1 + in + CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed -- | Calendrical difference, with as many whole months as possible. diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays -diffJulianDurationRollOver day2 day1 = let - (y1, m1, _) = toJulian day1 - (y2, m2, _) = toJulian day2 - ym1 = y1 * 12 + toInteger m1 - ym2 = y2 * 12 + toInteger m2 - ymdiff = ym2 - ym1 - findpos mdiff = let - dayAllowed = addJulianDurationRollOver (CalendarDiffDays mdiff 0) day1 - dd = diffDays day2 dayAllowed - in if dd >= 0 then CalendarDiffDays mdiff dd else findpos (pred mdiff) - findneg mdiff = let - dayAllowed = addJulianDurationRollOver (CalendarDiffDays mdiff 0) day1 - dd = diffDays day2 dayAllowed - in if dd <= 0 then CalendarDiffDays mdiff dd else findpos (succ mdiff) - in if day2 >= day1 - then findpos ymdiff - else findneg ymdiff +diffJulianDurationRollOver day2 day1 = + let + (y1, m1, _) = toJulian day1 + (y2, m2, _) = toJulian day2 + ym1 = y1 * 12 + toInteger m1 + ym2 = y2 * 12 + toInteger m2 + ymdiff = ym2 - ym1 + findpos mdiff = + let + dayAllowed = addJulianDurationRollOver (CalendarDiffDays mdiff 0) day1 + dd = diffDays day2 dayAllowed + in + if dd >= 0 then CalendarDiffDays mdiff dd else findpos (pred mdiff) + findneg mdiff = + let + dayAllowed = addJulianDurationRollOver (CalendarDiffDays mdiff 0) day1 + dd = diffDays day2 dayAllowed + in + if dd <= 0 then CalendarDiffDays mdiff dd else findpos (succ mdiff) + in + if day2 >= day1 + then findpos ymdiff + else findneg ymdiff diff --git a/lib/Data/Time/Calendar/OrdinalDate.hs b/lib/Data/Time/Calendar/OrdinalDate.hs index 887504b6..31cb9ad6 100644 --- a/lib/Data/Time/Calendar/OrdinalDate.hs +++ b/lib/Data/Time/Calendar/OrdinalDate.hs @@ -115,18 +115,20 @@ fromMondayStartWeek :: -- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime'). Int -> Day -fromMondayStartWeek year w d = let - -- first day of the year - firstDay = fromOrdinalDate year 1 - -- 0-based year day of first monday of the year - zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7 - -- 0-based week of year - zbWeek = w - 1 - -- 0-based day of week - zbDay = d - 1 - -- 0-based day in year - zbYearDay = zbFirstMonday + 7 * toInteger zbWeek + toInteger zbDay - in addDays zbYearDay firstDay +fromMondayStartWeek year w d = + let + -- first day of the year + firstDay = fromOrdinalDate year 1 + -- 0-based year day of first monday of the year + zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7 + -- 0-based week of year + zbWeek = w - 1 + -- 0-based day of week + zbDay = d - 1 + -- 0-based day in year + zbYearDay = zbFirstMonday + 7 * toInteger zbWeek + toInteger zbDay + in + addDays zbYearDay firstDay fromMondayStartWeekValid :: -- | Year. @@ -173,18 +175,20 @@ fromSundayStartWeek :: -- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime'). Int -> Day -fromSundayStartWeek year w d = let - -- first day of the year - firstDay = fromOrdinalDate year 1 - -- 0-based year day of first monday of the year - zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7 - -- 0-based week of year - zbWeek = w - 1 - -- 0-based day of week - zbDay = d - -- 0-based day in year - zbYearDay = zbFirstSunday + 7 * toInteger zbWeek + toInteger zbDay - in addDays zbYearDay firstDay +fromSundayStartWeek year w d = + let + -- first day of the year + firstDay = fromOrdinalDate year 1 + -- 0-based year day of first monday of the year + zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7 + -- 0-based week of year + zbWeek = w - 1 + -- 0-based day of week + zbDay = d + -- 0-based day in year + zbYearDay = zbFirstSunday + 7 * toInteger zbWeek + toInteger zbDay + in + addDays zbYearDay firstDay fromSundayStartWeekValid :: -- | Year. diff --git a/lib/Data/Time/Calendar/Private.hs b/lib/Data/Time/Calendar/Private.hs index c8ced538..d1583676 100644 --- a/lib/Data/Time/Calendar/Private.hs +++ b/lib/Data/Time/Calendar/Private.hs @@ -36,29 +36,29 @@ show2Fixed x | x < 10 = '0' : (showFixed True x) show2Fixed x = showFixed True x -show2 :: (ShowPadded t) => t -> String +show2 :: ShowPadded t => t -> String show2 = showPaddedNum $ Pad 2 '0' -show3 :: (ShowPadded t) => t -> String +show3 :: ShowPadded t => t -> String show3 = showPaddedNum $ Pad 3 '0' -show4 :: (ShowPadded t) => t -> String +show4 :: ShowPadded t => t -> String show4 = showPaddedNum $ Pad 4 '0' -mod100 :: (Integral i) => i -> i +mod100 :: Integral i => i -> i mod100 x = mod x 100 -div100 :: (Integral i) => i -> i +div100 :: Integral i => i -> i div100 x = div x 100 -clip :: (Ord t) => t -> t -> t -> t +clip :: Ord t => t -> t -> t -> t clip a _ x | x < a = a clip _ b x | x > b = b clip _ _ x = x -clipValid :: (Ord t) => t -> t -> t -> Maybe t +clipValid :: Ord t => t -> t -> t -> Maybe t clipValid a _ x | x < a = Nothing clipValid _ b x @@ -74,6 +74,8 @@ remBy d n = n - (fromInteger f) * d f = quotBy d n quotRemBy :: (Real a, Integral b) => a -> a -> (b, a) -quotRemBy d n = let - f = quotBy d n - in (f, n - (fromIntegral f) * d) +quotRemBy d n = + let + f = quotBy d n + in + (f, n - (fromIntegral f) * d) diff --git a/lib/Data/Time/Calendar/WeekDate.hs b/lib/Data/Time/Calendar/WeekDate.hs index ffd7c13e..40717a80 100644 --- a/lib/Data/Time/Calendar/WeekDate.hs +++ b/lib/Data/Time/Calendar/WeekDate.hs @@ -33,11 +33,13 @@ data FirstWeekType deriving (Eq, TH.Lift) firstDayOfWeekCalendar :: FirstWeekType -> DayOfWeek -> Year -> Day -firstDayOfWeekCalendar wt dow year = let - jan1st = fromOrdinalDate year 1 - in case wt of - FirstWholeWeek -> firstDayOfWeekOnAfter dow jan1st - FirstMostWeek -> firstDayOfWeekOnAfter dow $ addDays (-3) jan1st +firstDayOfWeekCalendar wt dow year = + let + jan1st = fromOrdinalDate year 1 + in + case wt of + FirstWholeWeek -> firstDayOfWeekOnAfter dow jan1st + FirstMostWeek -> firstDayOfWeekOnAfter dow $ addDays (-3) jan1st -- | Convert to the given kind of "week calendar". -- Note that the year number matches the weeks, and so is not always the same as the Gregorian year number. @@ -48,18 +50,20 @@ toWeekCalendar :: DayOfWeek -> Day -> (Year, WeekOfYear, DayOfWeek) -toWeekCalendar wt ws d = let - dw = dayOfWeek d - (y0, _) = toOrdinalDate d - j1p = firstDayOfWeekCalendar wt ws $ pred y0 - j1 = firstDayOfWeekCalendar wt ws y0 - j1s = firstDayOfWeekCalendar wt ws $ succ y0 - in if d < j1 - then (pred y0, succ $ div (fromInteger $ diffDays d j1p) 7, dw) - else - if d < j1s - then (y0, succ $ div (fromInteger $ diffDays d j1) 7, dw) - else (succ y0, succ $ div (fromInteger $ diffDays d j1s) 7, dw) +toWeekCalendar wt ws d = + let + dw = dayOfWeek d + (y0, _) = toOrdinalDate d + j1p = firstDayOfWeekCalendar wt ws $ pred y0 + j1 = firstDayOfWeekCalendar wt ws y0 + j1s = firstDayOfWeekCalendar wt ws $ succ y0 + in + if d < j1 + then (pred y0, succ $ div (fromInteger $ diffDays d j1p) 7, dw) + else + if d < j1s + then (y0, succ $ div (fromInteger $ diffDays d j1) 7, dw) + else (succ y0, succ $ div (fromInteger $ diffDays d j1s) 7, dw) -- | Convert from the given kind of "week calendar". -- Invalid week and day values will be clipped to the correct range. @@ -72,15 +76,17 @@ fromWeekCalendar :: WeekOfYear -> DayOfWeek -> Day -fromWeekCalendar wt ws y wy dw = let - d1 :: Day - d1 = firstDayOfWeekCalendar wt ws y - wy' = clip 1 53 wy - getday :: WeekOfYear -> Day - getday wy'' = addDays (toInteger $ (pred wy'' * 7) + (dayOfWeekDiff dw ws)) d1 - d1s = firstDayOfWeekCalendar wt ws $ succ y - day = getday wy' - in if wy' == 53 then if day >= d1s then getday 52 else day else day +fromWeekCalendar wt ws y wy dw = + let + d1 :: Day + d1 = firstDayOfWeekCalendar wt ws y + wy' = clip 1 53 wy + getday :: WeekOfYear -> Day + getday wy'' = addDays (toInteger $ (pred wy'' * 7) + (dayOfWeekDiff dw ws)) d1 + d1s = firstDayOfWeekCalendar wt ws $ succ y + day = getday wy' + in + if wy' == 53 then if day >= d1s then getday 52 else day else day -- | Convert from the given kind of "week calendar". -- Invalid week and day values will return Nothing. @@ -93,17 +99,21 @@ fromWeekCalendarValid :: WeekOfYear -> DayOfWeek -> Maybe Day -fromWeekCalendarValid wt ws y wy dw = let - d = fromWeekCalendar wt ws y wy dw - in if toWeekCalendar wt ws d == (y, wy, dw) then Just d else Nothing +fromWeekCalendarValid wt ws y wy dw = + let + d = fromWeekCalendar wt ws y wy dw + in + if toWeekCalendar wt ws d == (y, wy, dw) then Just d else Nothing -- | Convert to ISO 8601 Week Date format. First element of result is year, second week number (1-53), third day of week (1 for Monday to 7 for Sunday). -- Note that \"Week\" years are not quite the same as Gregorian years, as the first day of the year is always a Monday. -- The first week of a year is the first week to contain at least four days in the corresponding Gregorian year. toWeekDate :: Day -> (Year, WeekOfYear, Int) -toWeekDate d = let - (y, wy, dw) = toWeekCalendar FirstMostWeek Monday d - in (y, wy, fromEnum dw) +toWeekDate d = + let + (y, wy, dw) = toWeekCalendar FirstMostWeek Monday d + in + (y, wy, fromEnum dw) -- | Convert from ISO 8601 Week Date format. First argument is year, second week number (1-52 or 53), third day of week (1 for Monday to 7 for Sunday). -- Invalid week and day values will be clipped to the correct range. diff --git a/lib/Data/Time/Clock/Internal/DiffTime.hs b/lib/Data/Time/Clock/Internal/DiffTime.hs index ae3594b6..cfbdd296 100644 --- a/lib/Data/Time/Clock/Internal/DiffTime.hs +++ b/lib/Data/Time/Clock/Internal/DiffTime.hs @@ -68,9 +68,11 @@ instance Fractional DiffTime where fromRational r = MkDiffTime (fromRational r) instance RealFrac DiffTime where - properFraction (MkDiffTime a) = let - (b', a') = properFraction a - in (b', MkDiffTime a') + properFraction (MkDiffTime a) = + let + (b', a') = properFraction a + in + (b', MkDiffTime a') truncate (MkDiffTime a) = truncate a round (MkDiffTime a) = round a ceiling (MkDiffTime a) = ceiling a diff --git a/lib/Data/Time/Clock/POSIX.hs b/lib/Data/Time/Clock/POSIX.hs index 8659dff6..8e499d64 100644 --- a/lib/Data/Time/Clock/POSIX.hs +++ b/lib/Data/Time/Clock/POSIX.hs @@ -34,9 +34,11 @@ import Data.Time.Clock.Internal.UTCTime import Data.Time.Clock.System posixSecondsToUTCTime :: POSIXTime -> UTCTime -posixSecondsToUTCTime i = let - (d, t) = divMod' i posixDayLength - in UTCTime (addDays d systemEpochDay) (realToFrac t) +posixSecondsToUTCTime i = + let + (d, t) = divMod' i posixDayLength + in + UTCTime (addDays d systemEpochDay) (realToFrac t) utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime utcTimeToPOSIXSeconds (UTCTime d t) = diff --git a/lib/Data/Time/Clock/System.hs b/lib/Data/Time/Clock/System.hs index e03bb4ed..c6a47f86 100644 --- a/lib/Data/Time/Clock/System.hs +++ b/lib/Data/Time/Clock/System.hs @@ -27,48 +27,54 @@ truncateSystemTimeLeapSecond t = t -- | Convert 'SystemTime' to 'UTCTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC. systemToUTCTime :: SystemTime -> UTCTime -systemToUTCTime (MkSystemTime seconds nanoseconds) = let - days :: Int64 - timeSeconds :: Int64 - (days, timeSeconds) = seconds `divMod` 86400 - day :: Day - day = addDays (fromIntegral days) systemEpochDay - timeNanoseconds :: Int64 - timeNanoseconds = timeSeconds * 1000000000 + (fromIntegral nanoseconds) - timePicoseconds :: Int64 - timePicoseconds = timeNanoseconds * 1000 - time :: DiffTime - time = picosecondsToDiffTime $ fromIntegral timePicoseconds - in UTCTime day time +systemToUTCTime (MkSystemTime seconds nanoseconds) = + let + days :: Int64 + timeSeconds :: Int64 + (days, timeSeconds) = seconds `divMod` 86400 + day :: Day + day = addDays (fromIntegral days) systemEpochDay + timeNanoseconds :: Int64 + timeNanoseconds = timeSeconds * 1000000000 + (fromIntegral nanoseconds) + timePicoseconds :: Int64 + timePicoseconds = timeNanoseconds * 1000 + time :: DiffTime + time = picosecondsToDiffTime $ fromIntegral timePicoseconds + in + UTCTime day time -- | Convert 'UTCTime' to 'SystemTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC. utcToSystemTime :: UTCTime -> SystemTime -utcToSystemTime (UTCTime day time) = let - days :: Int64 - days = fromIntegral $ diffDays day systemEpochDay - timePicoseconds :: Int64 - timePicoseconds = fromIntegral $ diffTimeToPicoseconds time - timeNanoseconds :: Int64 - timeNanoseconds = timePicoseconds `div` 1000 - timeSeconds :: Int64 - nanoseconds :: Int64 - (timeSeconds, nanoseconds) = - if timeNanoseconds >= 86400000000000 - then (86399, timeNanoseconds - 86399000000000) - else timeNanoseconds `divMod` 1000000000 - seconds :: Int64 - seconds = days * 86400 + timeSeconds - in MkSystemTime seconds $ fromIntegral nanoseconds +utcToSystemTime (UTCTime day time) = + let + days :: Int64 + days = fromIntegral $ diffDays day systemEpochDay + timePicoseconds :: Int64 + timePicoseconds = fromIntegral $ diffTimeToPicoseconds time + timeNanoseconds :: Int64 + timeNanoseconds = timePicoseconds `div` 1000 + timeSeconds :: Int64 + nanoseconds :: Int64 + (timeSeconds, nanoseconds) = + if timeNanoseconds >= 86400000000000 + then (86399, timeNanoseconds - 86399000000000) + else timeNanoseconds `divMod` 1000000000 + seconds :: Int64 + seconds = days * 86400 + timeSeconds + in + MkSystemTime seconds $ fromIntegral nanoseconds systemEpochAbsolute :: AbsoluteTime systemEpochAbsolute = taiNominalDayStart systemEpochDay -- | Convert 'SystemTime' to 'AbsoluteTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' TAI. systemToTAITime :: SystemTime -> AbsoluteTime -systemToTAITime (MkSystemTime s ns) = let - diff :: DiffTime - diff = (fromIntegral s) + (fromIntegral ns) * 1E-9 - in addAbsoluteTime diff systemEpochAbsolute +systemToTAITime (MkSystemTime s ns) = + let + diff :: DiffTime + diff = (fromIntegral s) + (fromIntegral ns) * 1E-9 + in + addAbsoluteTime diff systemEpochAbsolute -- | The day of the epoch of 'SystemTime', 1970-01-01 systemEpochDay :: Day diff --git a/lib/Data/Time/Clock/TAI.hs b/lib/Data/Time/Clock/TAI.hs index dd930fc6..829e1be7 100644 --- a/lib/Data/Time/Clock/TAI.hs +++ b/lib/Data/Time/Clock/TAI.hs @@ -49,17 +49,19 @@ utcToTAITime lsmap (UTCTime day dtime) = do return $ addAbsoluteTime dtime t taiToUTCTime :: LeapSecondMap -> AbsoluteTime -> Maybe UTCTime -taiToUTCTime lsmap abstime = let - stable day = do - dayt <- dayStart lsmap day - len <- utcDayLength lsmap day - let - dtime = diffAbsoluteTime abstime dayt - day' = addDays (div' dtime len) day - if day == day' - then return (UTCTime day dtime) - else stable day' - in stable $ ModifiedJulianDay $ div' (diffAbsoluteTime abstime taiEpoch) 86400 +taiToUTCTime lsmap abstime = + let + stable day = do + dayt <- dayStart lsmap day + len <- utcDayLength lsmap day + let + dtime = diffAbsoluteTime abstime dayt + day' = addDays (div' dtime len) day + if day == day' + then return (UTCTime day dtime) + else stable day' + in + stable $ ModifiedJulianDay $ div' (diffAbsoluteTime abstime taiEpoch) 86400 -- | TAI clock, if it exists. Note that it is unlikely to be set correctly, without due care and attention. taiClock :: Maybe (DiffTime, IO AbsoluteTime) diff --git a/lib/Data/Time/Format/Format/Class.hs b/lib/Data/Time/Format/Format/Class.hs index 696d602c..68330fdd 100644 --- a/lib/Data/Time/Format/Format/Class.hs +++ b/lib/Data/Time/Format/Format/Class.hs @@ -39,28 +39,30 @@ class FormatTime t where -- the weird UNIX logic is here getPadOption :: Bool -> Bool -> Int -> Char -> Maybe FormatNumericPadding -> Maybe Int -> PadOption -getPadOption trunc fdef idef cdef mnpad mi = let - c = case mnpad of - Just (Just c') -> c' - Just Nothing -> ' ' - _ -> cdef - i = case mi of - Just i' -> case mnpad of - Just Nothing -> i' - _ -> - if trunc - then i' - else max i' idef - Nothing -> idef - f = case mi of - Just _ -> True - Nothing -> case mnpad of - Nothing -> fdef - Just Nothing -> False - Just (Just _) -> True - in if f - then Pad i c - else NoPad +getPadOption trunc fdef idef cdef mnpad mi = + let + c = case mnpad of + Just (Just c') -> c' + Just Nothing -> ' ' + _ -> cdef + i = case mi of + Just i' -> case mnpad of + Just Nothing -> i' + _ -> + if trunc + then i' + else max i' idef + Nothing -> idef + f = case mi of + Just _ -> True + Nothing -> case mnpad of + Nothing -> fdef + Just Nothing -> False + Just (Just _) -> True + in + if f + then Pad i c + else NoPad formatGeneral :: Bool -> Bool -> Int -> Char -> (TimeLocale -> PadOption -> t -> String) -> (FormatOptions -> t -> String) @@ -70,7 +72,7 @@ formatGeneral trunc fdef idef cdef ff fo = formatString :: (TimeLocale -> t -> String) -> (FormatOptions -> t -> String) formatString ff = formatGeneral False False 1 ' ' $ \locale pado -> showPadded pado . ff locale -formatNumber :: (ShowPadded i) => Bool -> Int -> Char -> (t -> i) -> (FormatOptions -> t -> String) +formatNumber :: ShowPadded i => Bool -> Int -> Char -> (t -> i) -> (FormatOptions -> t -> String) formatNumber fdef idef cdef ff = formatGeneral False fdef idef cdef $ \_ pado -> showPaddedNum pado . ff formatNumberStd :: Int -> (t -> Integer) -> (FormatOptions -> t -> String) @@ -79,25 +81,29 @@ formatNumberStd n = formatNumber False n '0' showPaddedFixed :: HasResolution a => PadOption -> PadOption -> Fixed a -> String showPaddedFixed padn padf x | x < 0 = '-' : showPaddedFixed padn padf (negate x) -showPaddedFixed padn padf x = let - ns = showPaddedNum padn $ (floor x :: Integer) - fs = showPaddedFixedFraction padf x - ds = - if null fs - then "" - else "." - in ns ++ ds ++ fs +showPaddedFixed padn padf x = + let + ns = showPaddedNum padn $ (floor x :: Integer) + fs = showPaddedFixedFraction padf x + ds = + if null fs + then "" + else "." + in + ns ++ ds ++ fs showPaddedFixedFraction :: HasResolution a => PadOption -> Fixed a -> String -showPaddedFixedFraction pado x = let - digits = dropWhile (== '.') $ dropWhile (/= '.') $ showFixed True x - n = length digits - in case pado of - NoPad -> digits - Pad i c -> - if i < n - then take i digits - else digits ++ replicate (i - n) c +showPaddedFixedFraction pado x = + let + digits = dropWhile (== '.') $ dropWhile (/= '.') $ showFixed True x + n = length digits + in + case pado of + NoPad -> digits + Pad i c -> + if i < n + then take i digits + else digits ++ replicate (i - n) c -- | Substitute various time-related information for each %-code in the string, as per 'formatCharacter'. -- @@ -321,7 +327,7 @@ showPaddedFixedFraction pado x = let -- For a whole number of seconds, @%ES@ omits the decimal point unless padding is specified. -- -- [@%0ES@] seconds of minute as two digits, with decimal point and \ (default 12) decimal places. -formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String +formatTime :: FormatTime t => TimeLocale -> String -> t -> String formatTime _ [] _ = "" formatTime locale ('%' : cs) t = case formatTime1 locale cs t of @@ -329,7 +335,7 @@ formatTime locale ('%' : cs) t = Nothing -> '%' : (formatTime locale cs t) formatTime locale (c : cs) t = c : (formatTime locale cs t) -formatTime1 :: (FormatTime t) => TimeLocale -> String -> t -> Maybe String +formatTime1 :: FormatTime t => TimeLocale -> String -> t -> Maybe String formatTime1 locale ('_' : cs) t = formatTime2 locale id (Just (Just ' ')) cs t formatTime1 locale ('-' : cs) t = formatTime2 locale id (Just Nothing) cs t formatTime1 locale ('0' : cs) t = formatTime2 locale id (Just (Just '0')) cs t @@ -352,13 +358,15 @@ pullNumber mx s@(c : cs) = Nothing -> (mx, s) formatTime2 :: - (FormatTime t) => TimeLocale -> (String -> String) -> Maybe FormatNumericPadding -> String -> t -> Maybe String -formatTime2 locale recase mpad cs t = let - (mwidth, rest) = pullNumber Nothing cs - in formatTime3 locale recase mpad mwidth rest t + FormatTime t => TimeLocale -> (String -> String) -> Maybe FormatNumericPadding -> String -> t -> Maybe String +formatTime2 locale recase mpad cs t = + let + (mwidth, rest) = pullNumber Nothing cs + in + formatTime3 locale recase mpad mwidth rest t formatTime3 :: - (FormatTime t) => + FormatTime t => TimeLocale -> (String -> String) -> Maybe FormatNumericPadding -> @@ -369,11 +377,11 @@ formatTime3 :: formatTime3 locale recase mpad mwidth ('E' : cs) = formatTime4 True recase (MkFormatOptions locale mpad mwidth) cs formatTime3 locale recase mpad mwidth cs = formatTime4 False recase (MkFormatOptions locale mpad mwidth) cs -formatTime4 :: (FormatTime t) => Bool -> (String -> String) -> FormatOptions -> String -> t -> Maybe String +formatTime4 :: FormatTime t => Bool -> (String -> String) -> FormatOptions -> String -> t -> Maybe String formatTime4 alt recase fo (c : cs) t = Just $ (recase (formatChar alt c fo t)) ++ (formatTime (foLocale fo) cs t) formatTime4 _alt _recase _fo [] _t = Nothing -formatChar :: (FormatTime t) => Bool -> Char -> FormatOptions -> t -> String +formatChar :: FormatTime t => Bool -> Char -> FormatOptions -> t -> String formatChar _ '%' = formatString $ \_ _ -> "%" formatChar _ 't' = formatString $ \_ _ -> "\t" formatChar _ 'n' = formatString $ \_ _ -> "\n" diff --git a/lib/Data/Time/Format/Format/Instances.hs b/lib/Data/Time/Format/Format/Instances.hs index 27da199f..9e8cb662 100644 --- a/lib/Data/Time/Format/Format/Instances.hs +++ b/lib/Data/Time/Format/Format/Instances.hs @@ -3,7 +3,8 @@ {-# OPTIONS -fno-warn-orphans #-} module Data.Time.Format.Format.Instances ( - ) where + +) where import Control.Applicative ((<|>)) import Data.Char @@ -39,11 +40,13 @@ instance FormatTime LocalTime where <|> mapFormatCharacter localTimeOfDay (formatCharacter alt c) todAMPM :: TimeLocale -> TimeOfDay -> String -todAMPM locale day = let - (am, pm) = amPm locale - in if (todHour day) < 12 - then am - else pm +todAMPM locale day = + let + (am, pm) = amPm locale + in + if (todHour day) < 12 + then am + else pm tod12Hour :: TimeOfDay -> Int tod12Hour day = (mod (todHour day - 1) 12) + 1 @@ -87,15 +90,17 @@ instance FormatTime TimeZone where formatCharacter False 'z' = Just $ formatGeneral False True 4 '0' $ \_ -> timeZoneOffsetString'' False formatCharacter True 'z' = Just $ formatGeneral False True 5 '0' $ \_ -> timeZoneOffsetString'' True formatCharacter alt 'Z' = - Just $ \fo z -> let - n = timeZoneName z - idef = - if alt - then 5 - else 4 - in if null n - then formatGeneral False True idef '0' (\_ -> timeZoneOffsetString'' alt) fo z - else formatString (\_ -> timeZoneName) fo z + Just $ \fo z -> + let + n = timeZoneName z + idef = + if alt + then 5 + else 4 + in + if null n + then formatGeneral False True idef '0' (\_ -> timeZoneOffsetString'' alt) fo z + else formatString (\_ -> timeZoneName) fo z formatCharacter _ _ = Nothing instance FormatTime DayOfWeek where @@ -166,11 +171,13 @@ instance FormatTime NominalDiffTime where formatCharacter False 'S' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 1 formatCharacter True 'S' = Just $ - formatGeneral True False 12 '0' $ \_ padf t -> let - padn = case padf of - NoPad -> NoPad - Pad _ c -> Pad 2 c - in showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico) + formatGeneral True False 12 '0' $ \_ padf t -> + let + padn = case padf of + NoPad -> NoPad + Pad _ c -> Pad 2 c + in + showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico) formatCharacter _ _ = Nothing instance FormatTime DiffTime where @@ -187,11 +194,13 @@ instance FormatTime DiffTime where formatCharacter False 'S' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 1 formatCharacter True 'S' = Just $ - formatGeneral True False 12 '0' $ \_ padf t -> let - padn = case padf of - NoPad -> NoPad - Pad _ c -> Pad 2 c - in showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico) + formatGeneral True False 12 '0' $ \_ padf t -> + let + padn = case padf of + NoPad -> NoPad + Pad _ c -> Pad 2 c + in + showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico) formatCharacter _ _ = Nothing instance FormatTime CalendarDiffDays where diff --git a/lib/Data/Time/Format/ISO8601.hs b/lib/Data/Time/Format/ISO8601.hs index cf0a9537..b95440c9 100644 --- a/lib/Data/Time/Format/ISO8601.hs +++ b/lib/Data/Time/Format/ISO8601.hs @@ -88,7 +88,7 @@ formatReadPExtension :: (FormatExtension -> Format t) -> ReadP t formatReadPExtension ff = formatReadP (ff ExtendedFormat) +++ formatReadP (ff BasicFormat) -- | Parse a value in either extended or basic format -parseFormatExtension :: (MonadFail m) => (FormatExtension -> Format t) -> String -> m t +parseFormatExtension :: MonadFail m => (FormatExtension -> Format t) -> String -> m t parseFormatExtension ff = parseReader $ formatReadPExtension ff sepFormat :: String -> Format a -> Format b -> Format (a, b) @@ -243,26 +243,32 @@ fromRationalRound r = fromRational $ round (r * 1000000000000) % 1000000000000 -- | ISO 8601:2004(E) sec. 4.2.2.3(a), 4.2.2.4(b) hourMinuteFormat :: FormatExtension -> Format TimeOfDay -hourMinuteFormat fe = let - toTOD (h, m) = - case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ (fromIntegral h) * 3600 + m * 60 of - (0, tod) -> Just tod - (1, TimeOfDay 0 0 0) -> Just $ TimeOfDay 24 0 0 - _ -> Nothing - fromTOD tod = let - mm = (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 60 - in Just $ quotRemBy 60 mm - in mapMFormat toTOD fromTOD $ extColonFormat fe hourFormat' $ minuteDecimalFormat +hourMinuteFormat fe = + let + toTOD (h, m) = + case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ (fromIntegral h) * 3600 + m * 60 of + (0, tod) -> Just tod + (1, TimeOfDay 0 0 0) -> Just $ TimeOfDay 24 0 0 + _ -> Nothing + fromTOD tod = + let + mm = (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 60 + in + Just $ quotRemBy 60 mm + in + mapMFormat toTOD fromTOD $ extColonFormat fe hourFormat' $ minuteDecimalFormat -- | ISO 8601:2004(E) sec. 4.2.2.3(b), 4.2.2.4(c) hourFormat :: Format TimeOfDay -hourFormat = let - toTOD h = case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ h * 3600 of - (0, tod) -> Just tod - (1, TimeOfDay 0 0 0) -> Just $ TimeOfDay 24 0 0 - _ -> Nothing - fromTOD tod = Just $ (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 3600 - in mapMFormat toTOD fromTOD $ hourDecimalFormat +hourFormat = + let + toTOD h = case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ h * 3600 of + (0, tod) -> Just tod + (1, TimeOfDay 0 0 0) -> Just $ TimeOfDay 24 0 0 + _ -> Nothing + fromTOD tod = Just $ (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 3600 + in + mapMFormat toTOD fromTOD $ hourDecimalFormat -- | ISO 8601:2004(E) sec. 4.2.2.5 withTimeDesignator :: Format t -> Format t @@ -274,19 +280,23 @@ withUTCDesignator f = f <** literalFormat "Z" -- | ISO 8601:2004(E) sec. 4.2.5.1 timeOffsetFormat :: FormatExtension -> Format TimeZone -timeOffsetFormat fe = let - toTimeZone (sign, ehm) = - minutesToTimeZone $ - sign * case ehm of - Left h -> h * 60 - Right (h, m) -> h * 60 + m - fromTimeZone tz = let - mm = timeZoneMinutes tz - (h, m) = quotRem (abs mm) 60 - in (signum mm, Right (h, m)) - digits2 = integerFormat NoSign (Just 2) - in isoMap toTimeZone fromTimeZone $ - mandatorySignFormat <**> (digits2 <++> extColonFormat fe digits2 digits2) +timeOffsetFormat fe = + let + toTimeZone (sign, ehm) = + minutesToTimeZone $ + sign * case ehm of + Left h -> h * 60 + Right (h, m) -> h * 60 + m + fromTimeZone tz = + let + mm = timeZoneMinutes tz + (h, m) = quotRem (abs mm) 60 + in + (signum mm, Right (h, m)) + digits2 = integerFormat NoSign (Just 2) + in + isoMap toTimeZone fromTimeZone $ + mandatorySignFormat <**> (digits2 <++> extColonFormat fe digits2 digits2) -- | ISO 8601:2004(E) sec. 4.2.5.2 timeOfDayAndOffsetFormat :: FormatExtension -> Format (TimeOfDay, TimeZone) @@ -323,10 +333,12 @@ decDesignator :: (Eq t, Show t, Read t, Num t) => Char -> Format t decDesignator c = optionalFormat 0 $ decimalFormat NegSign Nothing <** literalFormat [c] daysDesigs :: Format CalendarDiffDays -daysDesigs = let - toCD (y, (m, (w, d))) = CalendarDiffDays (y * 12 + m) (w * 7 + d) - fromCD (CalendarDiffDays mm d) = (quot mm 12, (rem mm 12, (0, d))) - in isoMap toCD fromCD $ intDesignator 'Y' <**> intDesignator 'M' <**> intDesignator 'W' <**> intDesignator 'D' +daysDesigs = + let + toCD (y, (m, (w, d))) = CalendarDiffDays (y * 12 + m) (w * 7 + d) + fromCD (CalendarDiffDays mm d) = (quot mm 12, (rem mm 12, (0, d))) + in + isoMap toCD fromCD $ intDesignator 'Y' <**> intDesignator 'M' <**> intDesignator 'W' <**> intDesignator 'D' -- | ISO 8601:2004(E) sec. 4.4.3.2 durationDaysFormat :: Format CalendarDiffDays @@ -334,44 +346,54 @@ durationDaysFormat = (**>) (literalFormat "P") $ specialCaseShowFormat (mempty, -- | ISO 8601:2004(E) sec. 4.4.3.2 durationTimeFormat :: Format CalendarDiffTime -durationTimeFormat = let - toCT (cd, (h, (m, s))) = - mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s) - fromCT (CalendarDiffTime mm t) = let - (d, TimeOfDay h m s) = timeToDaysAndTimeOfDay t - in (CalendarDiffDays mm d, (h, (m, s))) - in (**>) (literalFormat "P") $ - specialCaseShowFormat (mempty, "0D") $ - isoMap toCT fromCT $ - (<**>) daysDesigs $ - optionalFormat (0, (0, 0)) $ - literalFormat "T" **> intDesignator 'H' <**> intDesignator 'M' <**> decDesignator 'S' +durationTimeFormat = + let + toCT (cd, (h, (m, s))) = + mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s) + fromCT (CalendarDiffTime mm t) = + let + (d, TimeOfDay h m s) = timeToDaysAndTimeOfDay t + in + (CalendarDiffDays mm d, (h, (m, s))) + in + (**>) (literalFormat "P") $ + specialCaseShowFormat (mempty, "0D") $ + isoMap toCT fromCT $ + (<**>) daysDesigs $ + optionalFormat (0, (0, 0)) $ + literalFormat "T" **> intDesignator 'H' <**> intDesignator 'M' <**> decDesignator 'S' -- | ISO 8601:2004(E) sec. 4.4.3.3 alternativeDurationDaysFormat :: FormatExtension -> Format CalendarDiffDays -alternativeDurationDaysFormat fe = let - toCD (y, (m, d)) = CalendarDiffDays (y * 12 + m) d - fromCD (CalendarDiffDays mm d) = (quot mm 12, (rem mm 12, d)) - in isoMap toCD fromCD $ - (**>) (literalFormat "P") $ - extDashFormat fe (clipFormat (0, 9999) $ integerFormat NegSign $ Just 4) $ - extDashFormat fe (clipFormat (0, 12) $ integerFormat NegSign $ Just 2) $ - (clipFormat (0, 30) $ integerFormat NegSign $ Just 2) +alternativeDurationDaysFormat fe = + let + toCD (y, (m, d)) = CalendarDiffDays (y * 12 + m) d + fromCD (CalendarDiffDays mm d) = (quot mm 12, (rem mm 12, d)) + in + isoMap toCD fromCD $ + (**>) (literalFormat "P") $ + extDashFormat fe (clipFormat (0, 9999) $ integerFormat NegSign $ Just 4) $ + extDashFormat fe (clipFormat (0, 12) $ integerFormat NegSign $ Just 2) $ + (clipFormat (0, 30) $ integerFormat NegSign $ Just 2) -- | ISO 8601:2004(E) sec. 4.4.3.3 alternativeDurationTimeFormat :: FormatExtension -> Format CalendarDiffTime -alternativeDurationTimeFormat fe = let - toCT (cd, (h, (m, s))) = - mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s) - fromCT (CalendarDiffTime mm t) = let - (d, TimeOfDay h m s) = timeToDaysAndTimeOfDay t - in (CalendarDiffDays mm d, (h, (m, s))) - in isoMap toCT fromCT $ - (<**>) (alternativeDurationDaysFormat fe) $ - withTimeDesignator $ - extColonFormat fe (clipFormat (0, 24) $ integerFormat NegSign (Just 2)) $ - extColonFormat fe (clipFormat (0, 60) $ integerFormat NegSign (Just 2)) $ - (clipFormat (0, 60) $ decimalFormat NegSign (Just 2)) +alternativeDurationTimeFormat fe = + let + toCT (cd, (h, (m, s))) = + mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s) + fromCT (CalendarDiffTime mm t) = + let + (d, TimeOfDay h m s) = timeToDaysAndTimeOfDay t + in + (CalendarDiffDays mm d, (h, (m, s))) + in + isoMap toCT fromCT $ + (<**>) (alternativeDurationDaysFormat fe) $ + withTimeDesignator $ + extColonFormat fe (clipFormat (0, 24) $ integerFormat NegSign (Just 2)) $ + extColonFormat fe (clipFormat (0, 60) $ integerFormat NegSign (Just 2)) $ + (clipFormat (0, 60) $ decimalFormat NegSign (Just 2)) -- | ISO 8601:2004(E) sec. 4.4.4.1 intervalFormat :: Format a -> Format b -> Format (a, b) @@ -381,7 +403,8 @@ intervalFormat = sepFormat "/" recurringIntervalFormat :: Format a -> Format b -> Format (Int, a, b) recurringIntervalFormat fa fb = isoMap (\(r, (a, b)) -> (r, a, b)) (\(r, a, b) -> (r, (a, b))) $ - sepFormat "/" (literalFormat "R" **> integerFormat NoSign Nothing) $ intervalFormat fa fb + sepFormat "/" (literalFormat "R" **> integerFormat NoSign Nothing) $ + intervalFormat fa fb class ISO8601 t where -- | The most commonly used ISO 8601 format for this type. diff --git a/lib/Data/Time/Format/Internal.hs b/lib/Data/Time/Format/Internal.hs index 511476bb..9ddfff4c 100644 --- a/lib/Data/Time/Format/Internal.hs +++ b/lib/Data/Time/Format/Internal.hs @@ -1,8 +1,8 @@ {-# LANGUAGE Safe #-} -- | ---The contents of this module is liable to change, or disappear entirely. ---Please if you depend on anything here. +-- The contents of this module is liable to change, or disappear entirely. +-- Please if you depend on anything here. module Data.Time.Format.Internal ( -- * ISO8601 formatting Format (..), diff --git a/lib/Data/Time/Format/Parse/Class.hs b/lib/Data/Time/Format/Parse/Class.hs index 7b08dc9d..918a6d82 100644 --- a/lib/Data/Time/Format/Parse/Class.hs +++ b/lib/Data/Time/Format/Parse/Class.hs @@ -66,38 +66,40 @@ stringCI this = do scan this s parseSpecifiers :: ParseTime t => Proxy t -> TimeLocale -> String -> ReadP [(Char, String)] -parseSpecifiers pt locale = let - parse :: String -> ReadP [(Char, String)] - parse [] = return [] - parse ('%' : cs) = parse1 cs - parse (c : cs) | isSpace c = do - _ <- satisfy isSpace - case cs of - (c' : _) | isSpace c' -> return () - _ -> skipSpaces - parse cs - parse (c : cs) = do - _ <- charCI c - parse cs - parse1 :: String -> ReadP [(Char, String)] - parse1 ('-' : cs) = parse2 (Just NoPadding) cs - parse1 ('_' : cs) = parse2 (Just SpacePadding) cs - parse1 ('0' : cs) = parse2 (Just ZeroPadding) cs - parse1 cs = parse2 Nothing cs - parse2 :: Maybe ParseNumericPadding -> String -> ReadP [(Char, String)] - parse2 mpad ('E' : cs) = parse3 mpad True cs - parse2 mpad cs = parse3 mpad False cs - parse3 :: Maybe ParseNumericPadding -> Bool -> String -> ReadP [(Char, String)] - parse3 _ _ ('%' : cs) = do - _ <- char '%' - parse cs - parse3 _ _ (c : cs) | Just s <- substituteTimeSpecifier pt locale c = parse $ s ++ cs - parse3 mpad _alt (c : cs) = do - str <- parseTimeSpecifier pt locale mpad c - specs <- parse cs - return $ (c, str) : specs - parse3 _ _ [] = return [] - in parse +parseSpecifiers pt locale = + let + parse :: String -> ReadP [(Char, String)] + parse [] = return [] + parse ('%' : cs) = parse1 cs + parse (c : cs) | isSpace c = do + _ <- satisfy isSpace + case cs of + (c' : _) | isSpace c' -> return () + _ -> skipSpaces + parse cs + parse (c : cs) = do + _ <- charCI c + parse cs + parse1 :: String -> ReadP [(Char, String)] + parse1 ('-' : cs) = parse2 (Just NoPadding) cs + parse1 ('_' : cs) = parse2 (Just SpacePadding) cs + parse1 ('0' : cs) = parse2 (Just ZeroPadding) cs + parse1 cs = parse2 Nothing cs + parse2 :: Maybe ParseNumericPadding -> String -> ReadP [(Char, String)] + parse2 mpad ('E' : cs) = parse3 mpad True cs + parse2 mpad cs = parse3 mpad False cs + parse3 :: Maybe ParseNumericPadding -> Bool -> String -> ReadP [(Char, String)] + parse3 _ _ ('%' : cs) = do + _ <- char '%' + parse cs + parse3 _ _ (c : cs) | Just s <- substituteTimeSpecifier pt locale c = parse $ s ++ cs + parse3 mpad _alt (c : cs) = do + str <- parseTimeSpecifier pt locale mpad c + specs <- parse cs + return $ (c, str) : specs + parse3 _ _ [] = return [] + in + parse data PaddingSide = PrePadding @@ -136,78 +138,82 @@ parseSignedDecimal = do return $ sign ++ digits ++ decimaldigits timeParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String -timeParseTimeSpecifier l mpad c = let - digits' ps pad = parsePaddedDigits ps (fromMaybe pad mpad) - digits pad = digits' PrePadding pad False - oneOf = choice . map stringCI - numericTZ = do - s <- choice [char '+', char '-'] - h <- parsePaddedDigits PrePadding ZeroPadding False 2 - optional (char ':') - m <- parsePaddedDigits PrePadding ZeroPadding False 2 - return (s : h ++ m) - allowNegative :: ReadP String -> ReadP String - allowNegative p = (char '-' >> fmap ('-' :) p) <++ p - in case c of - -- century - 'C' -> allowNegative $ digits SpacePadding 2 - 'f' -> allowNegative $ digits SpacePadding 2 - -- year - 'Y' -> allowNegative $ digits SpacePadding 4 - 'G' -> allowNegative $ digits SpacePadding 4 - -- year of century - 'y' -> digits ZeroPadding 2 - 'g' -> digits ZeroPadding 2 - -- month of year - 'B' -> oneOf (map fst (months l)) - 'b' -> oneOf (map snd (months l)) - 'm' -> digits ZeroPadding 2 - -- day of month - 'd' -> digits ZeroPadding 2 - 'e' -> digits SpacePadding 2 - -- week of year - 'V' -> digits ZeroPadding 2 - 'U' -> digits ZeroPadding 2 - 'W' -> digits ZeroPadding 2 - -- day of week - 'u' -> oneOf $ map (: []) ['1' .. '7'] - 'a' -> oneOf (map snd (wDays l)) - 'A' -> oneOf (map fst (wDays l)) - 'w' -> oneOf $ map (: []) ['0' .. '6'] - -- day of year - 'j' -> digits ZeroPadding 3 - -- dayhalf of day (i.e. AM or PM) - 'P' -> - oneOf - ( let - (am, pm) = amPm l - in [am, pm] - ) - 'p' -> - oneOf - ( let - (am, pm) = amPm l - in [am, pm] - ) - -- hour of day (i.e. 24h) - 'H' -> digits ZeroPadding 2 - 'k' -> digits SpacePadding 2 - -- hour of dayhalf (i.e. 12h) - 'I' -> digits ZeroPadding 2 - 'l' -> digits SpacePadding 2 - -- minute of hour - 'M' -> digits ZeroPadding 2 - -- second of minute - 'S' -> digits ZeroPadding 2 - -- picosecond of second - 'q' -> digits' PostPadding ZeroPadding True 12 - 'Q' -> (char '.' >> digits' PostPadding NoPadding True 12) <++ return "" - -- time zone - 'z' -> numericTZ - 'Z' -> munch1 isAlpha <++ numericTZ - -- seconds since epoch - 's' -> (char '-' >> fmap ('-' :) (munch1 isDigit)) <++ munch1 isDigit - _ -> fail $ "Unknown format character: " ++ show c +timeParseTimeSpecifier l mpad c = + let + digits' ps pad = parsePaddedDigits ps (fromMaybe pad mpad) + digits pad = digits' PrePadding pad False + oneOf = choice . map stringCI + numericTZ = do + s <- choice [char '+', char '-'] + h <- parsePaddedDigits PrePadding ZeroPadding False 2 + optional (char ':') + m <- parsePaddedDigits PrePadding ZeroPadding False 2 + return (s : h ++ m) + allowNegative :: ReadP String -> ReadP String + allowNegative p = (char '-' >> fmap ('-' :) p) <++ p + in + case c of + -- century + 'C' -> allowNegative $ digits SpacePadding 2 + 'f' -> allowNegative $ digits SpacePadding 2 + -- year + 'Y' -> allowNegative $ digits SpacePadding 4 + 'G' -> allowNegative $ digits SpacePadding 4 + -- year of century + 'y' -> digits ZeroPadding 2 + 'g' -> digits ZeroPadding 2 + -- month of year + 'B' -> oneOf (map fst (months l)) + 'b' -> oneOf (map snd (months l)) + 'm' -> digits ZeroPadding 2 + -- day of month + 'd' -> digits ZeroPadding 2 + 'e' -> digits SpacePadding 2 + -- week of year + 'V' -> digits ZeroPadding 2 + 'U' -> digits ZeroPadding 2 + 'W' -> digits ZeroPadding 2 + -- day of week + 'u' -> oneOf $ map (: []) ['1' .. '7'] + 'a' -> oneOf (map snd (wDays l)) + 'A' -> oneOf (map fst (wDays l)) + 'w' -> oneOf $ map (: []) ['0' .. '6'] + -- day of year + 'j' -> digits ZeroPadding 3 + -- dayhalf of day (i.e. AM or PM) + 'P' -> + oneOf + ( let + (am, pm) = amPm l + in + [am, pm] + ) + 'p' -> + oneOf + ( let + (am, pm) = amPm l + in + [am, pm] + ) + -- hour of day (i.e. 24h) + 'H' -> digits ZeroPadding 2 + 'k' -> digits SpacePadding 2 + -- hour of dayhalf (i.e. 12h) + 'I' -> digits ZeroPadding 2 + 'l' -> digits SpacePadding 2 + -- minute of hour + 'M' -> digits ZeroPadding 2 + -- second of minute + 'S' -> digits ZeroPadding 2 + -- picosecond of second + 'q' -> digits' PostPadding ZeroPadding True 12 + 'Q' -> (char '.' >> digits' PostPadding NoPadding True 12) <++ return "" + -- time zone + 'z' -> numericTZ + 'Z' -> munch1 isAlpha <++ numericTZ + -- seconds since epoch + 's' -> (char '-' >> fmap ('-' :) (munch1 isDigit)) <++ munch1 isDigit + _ -> fail $ "Unknown format character: " ++ show c timeSubstituteTimeSpecifier :: TimeLocale -> Char -> Maybe String timeSubstituteTimeSpecifier l 'c' = Just $ dateTimeFmt l @@ -222,19 +228,21 @@ timeSubstituteTimeSpecifier _ 'h' = Just "%b" timeSubstituteTimeSpecifier _ _ = Nothing durationParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String -durationParseTimeSpecifier _ mpad c = let - padopt = parsePaddedSignedDigits $ fromMaybe NoPadding mpad - in case c of - 'y' -> padopt 1 - 'b' -> padopt 1 - 'B' -> padopt 2 - 'w' -> padopt 1 - 'd' -> padopt 1 - 'D' -> padopt 1 - 'h' -> padopt 1 - 'H' -> padopt 2 - 'm' -> padopt 1 - 'M' -> padopt 2 - 's' -> parseSignedDecimal - 'S' -> parseSignedDecimal - _ -> fail $ "Unknown format character: " ++ show c +durationParseTimeSpecifier _ mpad c = + let + padopt = parsePaddedSignedDigits $ fromMaybe NoPadding mpad + in + case c of + 'y' -> padopt 1 + 'b' -> padopt 1 + 'B' -> padopt 2 + 'w' -> padopt 1 + 'd' -> padopt 1 + 'D' -> padopt 1 + 'h' -> padopt 1 + 'H' -> padopt 2 + 'm' -> padopt 1 + 'M' -> padopt 2 + 's' -> parseSignedDecimal + 'S' -> parseSignedDecimal + _ -> fail $ "Unknown format character: " ++ show c diff --git a/lib/Data/Time/Format/Parse/Instances.hs b/lib/Data/Time/Format/Parse/Instances.hs index ffe5b13a..708f9791 100644 --- a/lib/Data/Time/Format/Parse/Instances.hs +++ b/lib/Data/Time/Format/Parse/Instances.hs @@ -3,7 +3,8 @@ {-# OPTIONS -fno-warn-orphans #-} module Data.Time.Format.Parse.Instances ( - ) where + +) where import Control.Applicative ((<|>)) import Data.Char @@ -49,118 +50,120 @@ data WeekType | MondayWeek makeDayComponent :: TimeLocale -> Char -> String -> Maybe [DayComponent] -makeDayComponent l c x = let - ra :: (Read a) => Maybe a - ra = readMaybe x - zeroBasedListIndex :: [String] -> Maybe Int - zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss - oneBasedListIndex :: [String] -> Maybe Int - oneBasedListIndex ss = do - index <- zeroBasedListIndex ss - return $ 1 + index - in case c of - -- %C: century (all but the last two digits of the year), 00 - 99 - 'C' -> do - a <- ra - return [DCCentury a] - -- %f century (all but the last two digits of the year), 00 - 99 - 'f' -> do - a <- ra - return [DCCentury a] - -- %Y: year - 'Y' -> do - a <- ra - return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)] - -- %G: year for Week Date format - 'G' -> do - a <- ra - return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)] - -- %y: last two digits of year, 00 - 99 - 'y' -> do - a <- ra - return [DCCenturyYear a] - -- %g: last two digits of year for Week Date format, 00 - 99 - 'g' -> do - a <- ra - return [DCCenturyYear a] - -- %B: month name, long form (fst from months locale), January - December - 'B' -> do - a <- oneBasedListIndex $ fmap fst $ months l - return [DCYearMonth a] - -- %b: month name, short form (snd from months locale), Jan - Dec - 'b' -> do - a <- oneBasedListIndex $ fmap snd $ months l - return [DCYearMonth a] - -- %m: month of year, leading 0 as needed, 01 - 12 - 'm' -> do - raw <- ra - a <- clipValid 1 12 raw - return [DCYearMonth a] - -- %d: day of month, leading 0 as needed, 01 - 31 - 'd' -> do - raw <- ra - a <- clipValid 1 31 raw - return [DCMonthDay a] - -- %e: day of month, leading space as needed, 1 - 31 - 'e' -> do - raw <- ra - a <- clipValid 1 31 raw - return [DCMonthDay a] - -- %V: week for Week Date format, 01 - 53 - 'V' -> do - raw <- ra - a <- clipValid 1 53 raw - return [DCYearWeek ISOWeek a] - -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53 - 'U' -> do - raw <- ra - a <- clipValid 0 53 raw - return [DCYearWeek SundayWeek a] - -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53 - 'W' -> do - raw <- ra - a <- clipValid 0 53 raw - return [DCYearWeek MondayWeek a] - -- %u: day for Week Date format, 1 - 7 - 'u' -> do - raw <- ra - a <- clipValid 1 7 raw - return [DCWeekDay a] - -- %a: day of week, short form (snd from wDays locale), Sun - Sat - 'a' -> do - a' <- zeroBasedListIndex $ fmap snd $ wDays l - let - a = - if a' == 0 - then 7 - else a' - return [DCWeekDay a] - -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday - 'A' -> do - a' <- zeroBasedListIndex $ fmap fst $ wDays l - let - a = - if a' == 0 - then 7 - else a' - return [DCWeekDay a] - -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday) - 'w' -> do - raw <- ra - a' <- clipValid 0 6 raw - let - a = - if a' == 0 - then 7 - else a' - return [DCWeekDay a] - -- %j: day of year for Ordinal Date format, 001 - 366 - 'j' -> do - raw <- ra - a <- clipValid 1 366 raw - return [DCYearDay a] - -- unrecognised, pass on to other parsers - _ -> return [] +makeDayComponent l c x = + let + ra :: Read a => Maybe a + ra = readMaybe x + zeroBasedListIndex :: [String] -> Maybe Int + zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss + oneBasedListIndex :: [String] -> Maybe Int + oneBasedListIndex ss = do + index <- zeroBasedListIndex ss + return $ 1 + index + in + case c of + -- %C: century (all but the last two digits of the year), 00 - 99 + 'C' -> do + a <- ra + return [DCCentury a] + -- %f century (all but the last two digits of the year), 00 - 99 + 'f' -> do + a <- ra + return [DCCentury a] + -- %Y: year + 'Y' -> do + a <- ra + return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)] + -- %G: year for Week Date format + 'G' -> do + a <- ra + return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)] + -- %y: last two digits of year, 00 - 99 + 'y' -> do + a <- ra + return [DCCenturyYear a] + -- %g: last two digits of year for Week Date format, 00 - 99 + 'g' -> do + a <- ra + return [DCCenturyYear a] + -- %B: month name, long form (fst from months locale), January - December + 'B' -> do + a <- oneBasedListIndex $ fmap fst $ months l + return [DCYearMonth a] + -- %b: month name, short form (snd from months locale), Jan - Dec + 'b' -> do + a <- oneBasedListIndex $ fmap snd $ months l + return [DCYearMonth a] + -- %m: month of year, leading 0 as needed, 01 - 12 + 'm' -> do + raw <- ra + a <- clipValid 1 12 raw + return [DCYearMonth a] + -- %d: day of month, leading 0 as needed, 01 - 31 + 'd' -> do + raw <- ra + a <- clipValid 1 31 raw + return [DCMonthDay a] + -- %e: day of month, leading space as needed, 1 - 31 + 'e' -> do + raw <- ra + a <- clipValid 1 31 raw + return [DCMonthDay a] + -- %V: week for Week Date format, 01 - 53 + 'V' -> do + raw <- ra + a <- clipValid 1 53 raw + return [DCYearWeek ISOWeek a] + -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53 + 'U' -> do + raw <- ra + a <- clipValid 0 53 raw + return [DCYearWeek SundayWeek a] + -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53 + 'W' -> do + raw <- ra + a <- clipValid 0 53 raw + return [DCYearWeek MondayWeek a] + -- %u: day for Week Date format, 1 - 7 + 'u' -> do + raw <- ra + a <- clipValid 1 7 raw + return [DCWeekDay a] + -- %a: day of week, short form (snd from wDays locale), Sun - Sat + 'a' -> do + a' <- zeroBasedListIndex $ fmap snd $ wDays l + let + a = + if a' == 0 + then 7 + else a' + return [DCWeekDay a] + -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday + 'A' -> do + a' <- zeroBasedListIndex $ fmap fst $ wDays l + let + a = + if a' == 0 + then 7 + else a' + return [DCWeekDay a] + -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday) + 'w' -> do + raw <- ra + a' <- clipValid 0 6 raw + let + a = + if a' == 0 + then 7 + else a' + return [DCWeekDay a] + -- %j: day of year for Ordinal Date format, 001 - 366 + 'j' -> do + raw <- ra + a <- clipValid 1 366 raw + return [DCYearDay a] + -- unrecognised, pass on to other parsers + _ -> return [] makeDayComponents :: TimeLocale -> [(Char, String)] -> Maybe [DayComponent] makeDayComponents l pairs = do @@ -178,26 +181,32 @@ instance ParseTime Day where -- 'Nothing' indicates a parse failure, -- while 'Just []' means no information let - y = let - d = safeLast 70 [x | DCCenturyYear x <- cs] - c = - safeLast - ( if d >= 69 - then 19 - else 20 - ) - [x | DCCentury x <- cs] - in 100 * c + d - rest (DCYearMonth m : _) = let - d = safeLast 1 [x | DCMonthDay x <- cs] - in fromGregorianValid y m d + y = + let + d = safeLast 70 [x | DCCenturyYear x <- cs] + c = + safeLast + ( if d >= 69 + then 19 + else 20 + ) + [x | DCCentury x <- cs] + in + 100 * c + d + rest (DCYearMonth m : _) = + let + d = safeLast 1 [x | DCMonthDay x <- cs] + in + fromGregorianValid y m d rest (DCYearDay d : _) = fromOrdinalDateValid y d - rest (DCYearWeek wt w : _) = let - d = safeLast 4 [x | DCWeekDay x <- cs] - in case wt of - ISOWeek -> fromWeekDateValid y w d - SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7) - MondayWeek -> fromMondayStartWeekValid y w d + rest (DCYearWeek wt w : _) = + let + d = safeLast 4 [x | DCWeekDay x <- cs] + in + case wt of + ISOWeek -> fromWeekDateValid y w d + SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7) + MondayWeek -> fromMondayStartWeekValid y w d rest (_ : xs) = rest xs rest [] = rest [DCYearMonth 1] rest cs @@ -210,90 +219,100 @@ instance ParseTime Month where -- 'Nothing' indicates a parse failure, -- while 'Just []' means no information let - y = let - d = safeLast 70 [x | DCCenturyYear x <- cs] - c = - safeLast - ( if d >= 69 - then 19 - else 20 - ) - [x | DCCentury x <- cs] - in 100 * c + d + y = + let + d = safeLast 70 [x | DCCenturyYear x <- cs] + c = + safeLast + ( if d >= 69 + then 19 + else 20 + ) + [x | DCCentury x <- cs] + in + 100 * c + d rest (DCYearMonth m : _) = fromYearMonthValid y m rest (_ : xs) = rest xs rest [] = fromYearMonthValid y 1 rest cs -mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a -mfoldl f = let - mf ma b = do - a <- ma - f a b - in foldl mf +mfoldl :: Monad m => (a -> b -> m a) -> m a -> [b] -> m a +mfoldl f = + let + mf ma b = do + a <- ma + f a b + in + foldl mf instance ParseTime TimeOfDay where substituteTimeSpecifier _ = timeSubstituteTimeSpecifier parseTimeSpecifier _ = timeParseTimeSpecifier - buildTime l = let - f t@(TimeOfDay h m s) (c, x) = let - ra :: (Read a) => Maybe a - ra = readMaybe x - getAmPm = let - upx = map toUpper x - (amStr, pmStr) = amPm l - in if upx == amStr - then Just $ TimeOfDay (h `mod` 12) m s - else - if upx == pmStr - then - Just $ - TimeOfDay - ( if h < 12 - then h + 12 - else h - ) - m - s - else Nothing - in case c of - 'P' -> getAmPm - 'p' -> getAmPm - 'H' -> do - raw <- ra - a <- clipValid 0 23 raw - return $ TimeOfDay a m s - 'I' -> do - raw <- ra - a <- clipValid 1 12 raw - return $ TimeOfDay a m s - 'k' -> do - raw <- ra - a <- clipValid 0 23 raw - return $ TimeOfDay a m s - 'l' -> do - raw <- ra - a <- clipValid 1 12 raw - return $ TimeOfDay a m s - 'M' -> do - raw <- ra - a <- clipValid 0 59 raw - return $ TimeOfDay h a s - 'S' -> do - raw <- ra - a <- clipValid 0 60 raw - return $ TimeOfDay h m (fromInteger a) - 'q' -> do - ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0 - return $ TimeOfDay h m (mkPico (floor s) ps) - 'Q' -> - if null x - then Just t - else do + buildTime l = + let + f t@(TimeOfDay h m s) (c, x) = + let + ra :: Read a => Maybe a + ra = readMaybe x + getAmPm = + let + upx = map toUpper x + (amStr, pmStr) = amPm l + in + if upx == amStr + then Just $ TimeOfDay (h `mod` 12) m s + else + if upx == pmStr + then + Just $ + TimeOfDay + ( if h < 12 + then h + 12 + else h + ) + m + s + else Nothing + in + case c of + 'P' -> getAmPm + 'p' -> getAmPm + 'H' -> do + raw <- ra + a <- clipValid 0 23 raw + return $ TimeOfDay a m s + 'I' -> do + raw <- ra + a <- clipValid 1 12 raw + return $ TimeOfDay a m s + 'k' -> do + raw <- ra + a <- clipValid 0 23 raw + return $ TimeOfDay a m s + 'l' -> do + raw <- ra + a <- clipValid 1 12 raw + return $ TimeOfDay a m s + 'M' -> do + raw <- ra + a <- clipValid 0 59 raw + return $ TimeOfDay h a s + 'S' -> do + raw <- ra + a <- clipValid 0 60 raw + return $ TimeOfDay h m (fromInteger a) + 'q' -> do ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0 return $ TimeOfDay h m (mkPico (floor s) ps) - _ -> Just t - in mfoldl f (Just midnight) + 'Q' -> + if null x + then Just t + else do + ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0 + return $ TimeOfDay h m (mkPico (floor s) ps) + _ -> Just t + in + mfoldl f (Just midnight) rpad :: Int -> a -> [a] -> [a] rpad n c xs = xs ++ replicate (n - length xs) c @@ -306,7 +325,7 @@ instance ParseTime LocalTime where parseTimeSpecifier _ = timeParseTimeSpecifier buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs) -enumDiff :: (Enum a) => a -> a -> Int +enumDiff :: Enum a => a -> a -> Int enumDiff a b = (fromEnum a) - (fromEnum b) getMilZoneHours :: Char -> Maybe Int @@ -323,11 +342,13 @@ getMilZoneHours 'Z' = Just 0 getMilZoneHours _ = Nothing getMilZone :: Char -> Maybe TimeZone -getMilZone c = let - yc = toUpper c - in do - hours <- getMilZoneHours yc - return $ TimeZone (hours * 60) False [yc] +getMilZone c = + let + yc = toUpper c + in + do + hours <- getMilZoneHours yc + return $ TimeZone (hours * 60) False [yc] getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (knownTimeZones locale) @@ -335,50 +356,56 @@ getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (know instance ParseTime TimeZone where substituteTimeSpecifier _ = timeSubstituteTimeSpecifier parseTimeSpecifier _ = timeParseTimeSpecifier - buildTime l = let - f :: Char -> String -> TimeZone -> Maybe TimeZone - f 'z' str (TimeZone _ dst name) - | Just offset <- readTzOffset str = Just $ TimeZone offset dst name - f 'z' _ _ = Nothing - f 'Z' str _ - | Just offset <- readTzOffset str = Just $ TimeZone offset False "" - f 'Z' str _ - | Just zone <- getKnownTimeZone l str = Just zone - f 'Z' "UTC" _ = Just utc - f 'Z' [c] _ - | Just zone <- getMilZone c = Just zone - f 'Z' _ _ = Nothing - f _ _ tz = Just tz - in foldl (\mt (c, s) -> mt >>= f c s) (Just $ minutesToTimeZone 0) + buildTime l = + let + f :: Char -> String -> TimeZone -> Maybe TimeZone + f 'z' str (TimeZone _ dst name) + | Just offset <- readTzOffset str = Just $ TimeZone offset dst name + f 'z' _ _ = Nothing + f 'Z' str _ + | Just offset <- readTzOffset str = Just $ TimeZone offset False "" + f 'Z' str _ + | Just zone <- getKnownTimeZone l str = Just zone + f 'Z' "UTC" _ = Just utc + f 'Z' [c] _ + | Just zone <- getMilZone c = Just zone + f 'Z' _ _ = Nothing + f _ _ tz = Just tz + in + foldl (\mt (c, s) -> mt >>= f c s) (Just $ minutesToTimeZone 0) readTzOffset :: String -> Maybe Int -readTzOffset str = let - getSign '+' = Just 1 - getSign '-' = Just (-1) - getSign _ = Nothing - calc s h1 h2 m1 m2 = do - sign <- getSign s - h <- readMaybe [h1, h2] - m <- readMaybe [m1, m2] - return $ sign * (60 * h + m) - in case str of - (s : h1 : h2 : ':' : m1 : m2 : []) -> calc s h1 h2 m1 m2 - (s : h1 : h2 : m1 : m2 : []) -> calc s h1 h2 m1 m2 - _ -> Nothing +readTzOffset str = + let + getSign '+' = Just 1 + getSign '-' = Just (-1) + getSign _ = Nothing + calc s h1 h2 m1 m2 = do + sign <- getSign s + h <- readMaybe [h1, h2] + m <- readMaybe [m1, m2] + return $ sign * (60 * h + m) + in + case str of + (s : h1 : h2 : ':' : m1 : m2 : []) -> calc s h1 h2 m1 m2 + (s : h1 : h2 : m1 : m2 : []) -> calc s h1 h2 m1 m2 + _ -> Nothing instance ParseTime ZonedTime where substituteTimeSpecifier _ = timeSubstituteTimeSpecifier parseTimeSpecifier _ = timeParseTimeSpecifier - buildTime l xs = let - f (ZonedTime (LocalTime _ tod) z) ('s', x) = do - a <- readMaybe x - let - s = fromInteger a - (_, ps) = properFraction (todSec tod) :: (Integer, Pico) - s' = s + fromRational (toRational ps) - return $ utcToZonedTime z (posixSecondsToUTCTime s') - f t _ = Just t - in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs + buildTime l xs = + let + f (ZonedTime (LocalTime _ tod) z) ('s', x) = do + a <- readMaybe x + let + s = fromInteger a + (_, ps) = properFraction (todSec tod) :: (Integer, Pico) + s' = s + fromRational (toRational ps) + return $ utcToZonedTime z (posixSecondsToUTCTime s') + f t _ = Just t + in + mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs instance ParseTime UTCTime where substituteTimeSpecifier _ = timeSubstituteTimeSpecifier @@ -414,19 +441,21 @@ buildTimeDays xs = do buildTimeSeconds :: [(Char, String)] -> Maybe Pico buildTimeSeconds xs = do - tt <- for xs $ \(c, s) -> let - readInt :: Integer -> Maybe Pico - readInt t = do - i <- readMaybe s - return $ fromInteger $ i * t - in case c of - 'h' -> readInt 3600 - 'H' -> readInt 3600 - 'm' -> readInt 60 - 'M' -> readInt 60 - 's' -> readMaybe s - 'S' -> readMaybe s - _ -> return 0 + tt <- for xs $ \(c, s) -> + let + readInt :: Integer -> Maybe Pico + readInt t = do + i <- readMaybe s + return $ fromInteger $ i * t + in + case c of + 'h' -> readInt 3600 + 'H' -> readInt 3600 + 'm' -> readInt 60 + 'M' -> readInt 60 + 's' -> readMaybe s + 'S' -> readMaybe s + _ -> return 0 return $ sum tt instance ParseTime NominalDiffTime where diff --git a/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs b/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs index a0a0763f..b2a9d3ac 100644 --- a/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs +++ b/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs @@ -65,12 +65,14 @@ makeTimeOfDayValid h m s = do -- | Convert a period of time into a count of days and a time of day since midnight. -- The time of day will never have a leap second. timeToDaysAndTimeOfDay :: NominalDiffTime -> (Integer, TimeOfDay) -timeToDaysAndTimeOfDay dt = let - s = realToFrac dt - (m, ms) = divMod' s 60 - (h, hm) = divMod' m 60 - (d, dh) = divMod' h 24 - in (d, TimeOfDay dh hm ms) +timeToDaysAndTimeOfDay dt = + let + s = realToFrac dt + (m, ms) = divMod' s 60 + (h, hm) = divMod' m 60 + (d, dh) = divMod' h 24 + in + (d, TimeOfDay dh hm ms) -- | Convert a count of days and a time of day since midnight into a period of time. daysAndTimeOfDayToTime :: Integer -> TimeOfDay -> NominalDiffTime diff --git a/lib/Data/Time/LocalTime/Internal/TimeZone.hs b/lib/Data/Time/LocalTime/Internal/TimeZone.hs index f413f858..69746594 100644 --- a/lib/Data/Time/LocalTime/Internal/TimeZone.hs +++ b/lib/Data/Time/LocalTime/Internal/TimeZone.hs @@ -48,11 +48,13 @@ hoursToTimeZone i = minutesToTimeZone (60 * i) showT :: Bool -> PadOption -> Int -> String showT False opt t = showPaddedNum opt ((div t 60) * 100 + (mod t 60)) -showT True opt t = let - opt' = case opt of - NoPad -> NoPad - Pad i c -> Pad (max 0 $ i - 3) c - in showPaddedNum opt' (div t 60) ++ ":" ++ show2 (mod t 60) +showT True opt t = + let + opt' = case opt of + NoPad -> NoPad + Pad i c -> Pad (max 0 $ i - 3) c + in + showPaddedNum opt' (div t 60) ++ ":" ++ show2 (mod t 60) timeZoneOffsetString'' :: Bool -> PadOption -> TimeZone -> String timeZoneOffsetString'' colon opt (TimeZone t _ _) @@ -103,12 +105,14 @@ getTimeZoneCTime ctime = -- there's no instance Bounded CTime, so this is the easiest way to check for overflow toCTime :: Int64 -> IO CTime -toCTime t = let - tt = fromIntegral t - t' = fromIntegral tt - in if t' == t - then return $ CTime tt - else fail "Data.Time.LocalTime.Internal.TimeZone.toCTime: Overflow" +toCTime t = + let + tt = fromIntegral t + t' = fromIntegral tt + in + if t' == t + then return $ CTime tt + else fail "Data.Time.LocalTime.Internal.TimeZone.toCTime: Overflow" -- | Get the configured time-zone for a given time (varying as per summertime adjustments). getTimeZoneSystem :: SystemTime -> IO TimeZone diff --git a/test/ShowDST.hs b/test/ShowDST.hs index 7cabcfa8..ec3a4c96 100644 --- a/test/ShowDST.hs +++ b/test/ShowDST.hs @@ -12,7 +12,8 @@ findTransition a b = do if za == zb then return [] else do - let c = addUTCTime ((diffUTCTime b a) / 2) a + let + c = addUTCTime ((diffUTCTime b a) / 2) a if a == c then return [(b, za, zb)] else do @@ -30,13 +31,19 @@ main :: IO () main = do now <- getCurrentTime zone <- getTimeZone now - let (year, _, _) = toGregorian (localDay (utcToLocalTime zone now)) + let + (year, _, _) = toGregorian (localDay (utcToLocalTime zone now)) putStrLn ("DST adjustments for " ++ show year ++ ":") - let t0 = monthBeginning zone year 1 - let t1 = monthBeginning zone year 4 - let t2 = monthBeginning zone year 7 - let t3 = monthBeginning zone year 10 - let t4 = monthBeginning zone (year + 1) 1 + let + t0 = monthBeginning zone year 1 + let + t1 = monthBeginning zone year 4 + let + t2 = monthBeginning zone year 7 + let + t3 = monthBeginning zone year 10 + let + t4 = monthBeginning zone (year + 1) 1 tr1 <- findTransition t0 t1 tr2 <- findTransition t1 t2 tr3 <- findTransition t2 t3 diff --git a/test/main/Test/Arbitrary.hs b/test/main/Test/Arbitrary.hs index 62738915..1582ecaf 100644 --- a/test/main/Test/Arbitrary.hs +++ b/test/main/Test/Arbitrary.hs @@ -39,24 +39,26 @@ supportedDayRange = (fromGregorian (-9899) 1 1, fromGregorian 9999 12 31) instance Arbitrary Day where arbitrary = choose supportedDayRange - shrink day = let - (y, m, d) = toGregorian day - dayShrink = - if d > 1 - then [fromGregorian y m (d - 1)] - else [] - monthShrink = - if m > 1 - then [fromGregorian y (m - 1) d] - else [] - yearShrink = - if y > 2000 - then [fromGregorian (y - 1) m d] - else - if y < 2000 - then [fromGregorian (y + 1) m d] - else [] - in dayShrink ++ monthShrink ++ yearShrink + shrink day = + let + (y, m, d) = toGregorian day + dayShrink = + if d > 1 + then [fromGregorian y m (d - 1)] + else [] + monthShrink = + if m > 1 + then [fromGregorian y (m - 1) d] + else [] + yearShrink = + if y > 2000 + then [fromGregorian (y - 1) m d] + else + if y < 2000 + then [fromGregorian (y + 1) m d] + else [] + in + dayShrink ++ monthShrink ++ yearShrink instance CoArbitrary Day where coarbitrary (ModifiedJulianDay d) = coarbitrary d @@ -97,28 +99,32 @@ instance Arbitrary CalendarDiffTime where reduceDigits :: Int -> Pico -> Maybe Pico reduceDigits (-1) _ = Nothing -reduceDigits n x = let - d :: Pico - d = 10 ^^ (negate n) - r = mod' x d - in case r of - 0 -> reduceDigits (n - 1) x - _ -> Just $ x - r +reduceDigits n x = + let + d :: Pico + d = 10 ^^ (negate n) + r = mod' x d + in + case r of + 0 -> reduceDigits (n - 1) x + _ -> Just $ x - r instance Arbitrary TimeOfDay where arbitrary = liftM timeToTimeOfDay arbitrary - shrink (TimeOfDay h m s) = let - shrinkInt 0 = [] - shrinkInt 1 = [0] - shrinkInt _ = [0, 1] - shrinkPico 0 = [] - shrinkPico 1 = [0] - shrinkPico p = case reduceDigits 12 p of - Just p' -> [0, 1, p'] - Nothing -> [0, 1] - in [TimeOfDay h' m s | h' <- shrinkInt h] - ++ [TimeOfDay h m' s | m' <- shrinkInt m] - ++ [TimeOfDay h m s' | s' <- shrinkPico s] + shrink (TimeOfDay h m s) = + let + shrinkInt 0 = [] + shrinkInt 1 = [0] + shrinkInt _ = [0, 1] + shrinkPico 0 = [] + shrinkPico 1 = [0] + shrinkPico p = case reduceDigits 12 p of + Just p' -> [0, 1, p'] + Nothing -> [0, 1] + in + [TimeOfDay h' m s | h' <- shrinkInt h] + ++ [TimeOfDay h m' s | m' <- shrinkInt m] + ++ [TimeOfDay h m s' | s' <- shrinkPico s] instance CoArbitrary TimeOfDay where coarbitrary t = coarbitrary (timeOfDayToTime t) diff --git a/test/main/Test/Calendar/ClipDates.hs b/test/main/Test/Calendar/ClipDates.hs index 166e1ddb..5bbaba47 100644 --- a/test/main/Test/Calendar/ClipDates.hs +++ b/test/main/Test/Calendar/ClipDates.hs @@ -23,9 +23,11 @@ tupleUp2 :: [a] -> [b] -> [(a, b)] tupleUp2 l1 l2 = concatMap (\e -> map (e,) l2) l1 tupleUp3 :: [a] -> [b] -> [c] -> [(a, b, c)] -tupleUp3 l1 l2 l3 = let - ts = tupleUp2 l2 l3 - in concatMap (\e -> map (\(f, g) -> (e, f, g)) ts) l1 +tupleUp3 l1 l2 l3 = + let + ts = tupleUp2 l2 l3 + in + concatMap (\e -> map (\(f, g) -> (e, f, g)) ts) l1 testPairs :: String -> [String] -> [String] -> TestTree testPairs name expected found = testGroup name $ fmap (\(e, f) -> testCase e $ assertEqual "" e f) $ zip expected found diff --git a/test/main/Test/Calendar/ConvertBack.hs b/test/main/Test/Calendar/ConvertBack.hs index 73d6d466..60fab3e9 100644 --- a/test/main/Test/Calendar/ConvertBack.hs +++ b/test/main/Test/Calendar/ConvertBack.hs @@ -9,20 +9,22 @@ import Data.Time.Calendar.WeekDate import Test.Tasty import Test.Tasty.HUnit -checkDay :: (Show t) => (Day -> t) -> (t -> Day) -> (t -> Maybe Day) -> Day -> String -checkDay encodeDay decodeDay decodeDayValid day = let - st = encodeDay day - day' = decodeDay st - mday' = decodeDayValid st - a = - if day /= day' - then unwords [show day, "-> ", show st, "-> ", show day', "(diff", show (diffDays day' day) ++ ")"] - else "" - b = - if Just day /= mday' - then unwords [show day, "->", show st, "->", show mday'] - else "" - in a ++ b +checkDay :: Show t => (Day -> t) -> (t -> Day) -> (t -> Maybe Day) -> Day -> String +checkDay encodeDay decodeDay decodeDayValid day = + let + st = encodeDay day + day' = decodeDay st + mday' = decodeDayValid st + a = + if day /= day' + then unwords [show day, "-> ", show st, "-> ", show day', "(diff", show (diffDays day' day) ++ ")"] + else "" + b = + if Just day /= mday' + then unwords [show day, "->", show st, "->", show mday'] + else "" + in + a ++ b checkers :: [Day -> String] checkers = diff --git a/test/main/Test/Calendar/DayPeriod.hs b/test/main/Test/Calendar/DayPeriod.hs index d1b421ef..0a4f8e8d 100644 --- a/test/main/Test/Calendar/DayPeriod.hs +++ b/test/main/Test/Calendar/DayPeriod.hs @@ -161,15 +161,21 @@ testYear = testWeek :: [TestTree] testWeek = - [ testProperty "weekFirstDay/weekLastDay range" $ \dw (MkWDay d) -> let - f = weekFirstDay dw d - l = weekLastDay dw d - in f <= d && d <= l - , testProperty "weekFirstDay/weekLastDay range" $ \dw (MkWDay d) -> let - f = weekFirstDay dw d - l = weekLastDay dw d - in addDays 6 f == l - , testProperty "weekFirstDay dayOfWeek" $ \dw (MkWDay d) -> let - f = weekFirstDay dw d - in dayOfWeek f == dw + [ testProperty "weekFirstDay/weekLastDay range" $ \dw (MkWDay d) -> + let + f = weekFirstDay dw d + l = weekLastDay dw d + in + f <= d && d <= l + , testProperty "weekFirstDay/weekLastDay range" $ \dw (MkWDay d) -> + let + f = weekFirstDay dw d + l = weekLastDay dw d + in + addDays 6 f == l + , testProperty "weekFirstDay dayOfWeek" $ \dw (MkWDay d) -> + let + f = weekFirstDay dw d + in + dayOfWeek f == dw ] diff --git a/test/main/Test/Calendar/Duration.hs b/test/main/Test/Calendar/Duration.hs index 59e284e2..910ff7bb 100644 --- a/test/main/Test/Calendar/Duration.hs +++ b/test/main/Test/Calendar/Duration.hs @@ -57,10 +57,12 @@ instance Arbitrary Smallish where return $ MkSmallish n testPositiveDiff :: AddDiff -> TestTree -testPositiveDiff MkAddDiff{..} = testProperty adName $ \day1 (MkSmallish i) -> let - day2 = addDays i day1 - r = adDifference day2 day1 - in property $ cdMonths r >= 0 && cdDays r >= 0 +testPositiveDiff MkAddDiff{..} = testProperty adName $ \day1 (MkSmallish i) -> + let + day2 = addDays i day1 + r = adDifference day2 day1 + in + property $ cdMonths r >= 0 && cdDays r >= 0 testPositiveDiffs :: TestTree testPositiveDiffs = @@ -69,14 +71,16 @@ testPositiveDiffs = $ fmap testPositiveDiff addDiffs testSpecific :: AddDiff -> (Integer, Int, Int) -> (Integer, Int, Int) -> (Integer, Integer) -> TestTree -testSpecific MkAddDiff{..} (y2, m2, d2) (y1, m1, d1) (em, ed) = let - day1 = adFromYMD y1 m1 d1 - day2 = adFromYMD y2 m2 d2 - expected = CalendarDiffDays em ed - found = adDifference day2 day1 - in testCase (adName ++ ": " ++ show day2 ++ " - " ++ show day1) $ do - assertEqual "add" day2 $ adAdd found day1 - assertEqual "diff" expected found +testSpecific MkAddDiff{..} (y2, m2, d2) (y1, m1, d1) (em, ed) = + let + day1 = adFromYMD y1 m1 d1 + day2 = adFromYMD y2 m2 d2 + expected = CalendarDiffDays em ed + found = adDifference day2 day1 + in + testCase (adName ++ ": " ++ show day2 ++ " - " ++ show day1) $ do + assertEqual "add" day2 $ adAdd found day1 + assertEqual "diff" expected found testSpecificPair :: (Integer, Int, Int) -> (Integer, Int, Int) -> (Integer, Integer) -> (Integer, Integer) -> TestTree testSpecificPair day2 day1 clipD rollD = diff --git a/test/main/Test/Calendar/Easter.hs b/test/main/Test/Calendar/Easter.hs index 8449cf2e..06020a1f 100644 --- a/test/main/Test/Calendar/Easter.hs +++ b/test/main/Test/Calendar/Easter.hs @@ -18,20 +18,22 @@ showWithWDay = formatTime defaultTimeLocale "%F %A" testEaster :: TestTree testEaster = - testCase "testEaster" $ let - ds = unlines $ map (\day -> unwords [showWithWDay day, "->", showWithWDay (sundayAfter day)]) days - f y = - unwords - [ show y ++ ", Gregorian: moon," - , show (gregorianPaschalMoon y) ++ ": Easter," - , showWithWDay (gregorianEaster y) - ] - ++ "\n" - g y = - unwords - [ show y ++ ", Orthodox : moon," - , show (orthodoxPaschalMoon y) ++ ": Easter," - , showWithWDay (orthodoxEaster y) - ] - ++ "\n" - in assertEqual "" testEasterRef $ ds ++ concatMap (\y -> f y ++ g y) [2000 .. 2020] + testCase "testEaster" $ + let + ds = unlines $ map (\day -> unwords [showWithWDay day, "->", showWithWDay (sundayAfter day)]) days + f y = + unwords + [ show y ++ ", Gregorian: moon," + , show (gregorianPaschalMoon y) ++ ": Easter," + , showWithWDay (gregorianEaster y) + ] + ++ "\n" + g y = + unwords + [ show y ++ ", Orthodox : moon," + , show (orthodoxPaschalMoon y) ++ ": Easter," + , showWithWDay (orthodoxEaster y) + ] + ++ "\n" + in + assertEqual "" testEasterRef $ ds ++ concatMap (\y -> f y ++ g y) [2000 .. 2020] diff --git a/test/main/Test/Calendar/MonthDay.hs b/test/main/Test/Calendar/MonthDay.hs index 80e51e81..efc9c765 100644 --- a/test/main/Test/Calendar/MonthDay.hs +++ b/test/main/Test/Calendar/MonthDay.hs @@ -15,7 +15,9 @@ showCompare a1 b a2 = "DIFF: " ++ (show a1) ++ " -> " ++ b ++ " -> " ++ (show a2 testMonthDay :: TestTree testMonthDay = testCase "testMonthDay" $ - assertEqual "" testMonthDayRef $ concat $ map (\isL -> unlines (leap isL : yearDays isL)) [False, True] + assertEqual "" testMonthDayRef $ + concat $ + map (\isL -> unlines (leap isL : yearDays isL)) [False, True] where leap isLeap = if isLeap @@ -28,6 +30,7 @@ testMonthDay = (m, d) = dayOfYearToMonthAndDay isLeap yd yd' = monthAndDayToDayOfYear isLeap m d mdtext = show m ++ "-" ++ show d - in showCompare yd mdtext yd' + in + showCompare yd mdtext yd' ) [-2 .. 369] diff --git a/test/main/Test/Calendar/Valid.hs b/test/main/Test/Calendar/Valid.hs index 482e1711..e7ffb3c5 100644 --- a/test/main/Test/Calendar/Valid.hs +++ b/test/main/Test/Calendar/Valid.hs @@ -11,36 +11,38 @@ import Test.Tasty import Test.Tasty.QuickCheck hiding (reason) validResult :: (Eq c, Show c, Eq t, Show t) => (s -> c) -> Bool -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> s -> Result -validResult sc valid toComponents fromComponents fromComponentsValid s = let - c = sc s - mt = fromComponentsValid c - t' = fromComponents c - c' = toComponents t' - in if valid - then case mt of - Nothing -> rejected - Just t -> - if t' /= t - then failed{reason = "'fromValid' gives " ++ show t ++ ", but 'from' gives " ++ show t'} - else - if c' /= c - then - failed - { reason = - "found valid, but converts " - ++ show c - ++ " -> " - ++ show t' - ++ " -> " - ++ show c' - } - else succeeded - else case mt of - Nothing -> - if c' /= c - then succeeded - else failed{reason = show c ++ " found invalid, but converts with " ++ show t'} - Just _ -> rejected +validResult sc valid toComponents fromComponents fromComponentsValid s = + let + c = sc s + mt = fromComponentsValid c + t' = fromComponents c + c' = toComponents t' + in + if valid + then case mt of + Nothing -> rejected + Just t -> + if t' /= t + then failed{reason = "'fromValid' gives " ++ show t ++ ", but 'from' gives " ++ show t'} + else + if c' /= c + then + failed + { reason = + "found valid, but converts " + ++ show c + ++ " -> " + ++ show t' + ++ " -> " + ++ show c' + } + else succeeded + else case mt of + Nothing -> + if c' /= c + then succeeded + else failed{reason = show c ++ " found invalid, but converts with " ++ show t'} + Just _ -> rejected validTest :: (Arbitrary s, Show s, Eq c, Show c, Eq t, Show t) => @@ -58,16 +60,20 @@ validTest name sc toComponents fromComponents fromComponentsValid = ] toSundayStartWeek :: Day -> (Integer, Int, Int) -toSundayStartWeek day = let - (y, _) = toOrdinalDate day - (w, d) = sundayStartWeek day - in (y, w, d) +toSundayStartWeek day = + let + (y, _) = toOrdinalDate day + (w, d) = sundayStartWeek day + in + (y, w, d) toMondayStartWeek :: Day -> (Integer, Int, Int) -toMondayStartWeek day = let - (y, _) = toOrdinalDate day - (w, d) = mondayStartWeek day - in (y, w, d) +toMondayStartWeek day = + let + (y, _) = toOrdinalDate day + (w, d) = mondayStartWeek day + in + (y, w, d) newtype WYear = MkWYear Year diff --git a/test/main/Test/Calendar/Week.hs b/test/main/Test/Calendar/Week.hs index 44f4b001..99a0a8da 100644 --- a/test/main/Test/Calendar/Week.hs +++ b/test/main/Test/Calendar/Week.hs @@ -13,7 +13,8 @@ import Test.TestUtil testDay :: TestTree testDay = nameTest "day" $ do - let day = fromGregorian 2018 1 9 + let + day = fromGregorian 2018 1 9 assertEqual "" (ModifiedJulianDay 58127) day assertEqual "" (2018, 2, 2) $ toWeekDate day assertEqual "" Tuesday $ dayOfWeek day @@ -40,8 +41,8 @@ testSequences = assertEqual "" [Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday] [Sunday .. Saturday] , nameTest "[Thursday .. Wednesday]" $ assertEqual "" [Thursday, Friday, Saturday, Sunday, Monday, Tuesday, Wednesday] [Thursday .. Wednesday] - , nameTest "[Tuesday ..]" $ - assertEqual + , nameTest "[Tuesday ..]" + $ assertEqual "" [ Tuesday , Wednesday @@ -59,9 +60,9 @@ testSequences = , Monday , Tuesday ] - $ take 15 [Tuesday ..] - , nameTest "[Wednesday, Tuesday ..]" $ - assertEqual + $ take 15 [Tuesday ..] + , nameTest "[Wednesday, Tuesday ..]" + $ assertEqual "" [ Wednesday , Tuesday @@ -79,7 +80,7 @@ testSequences = , Thursday , Wednesday ] - $ take 15 [Wednesday, Tuesday ..] + $ take 15 [Wednesday, Tuesday ..] , nameTest "[Sunday, Friday ..]" $ assertEqual "" [Sunday, Friday, Wednesday, Monday, Saturday, Thursday, Tuesday, Sunday] $ take 8 [Sunday, Friday ..] @@ -99,27 +100,35 @@ prop_firstDayOfWeekOnAfter_Day :: DayOfWeek -> Day -> Bool prop_firstDayOfWeekOnAfter_Day dw d = dayOfWeek (firstDayOfWeekOnAfter dw d) == dw prop_toFromWeekCalendar :: FirstWeekType -> DayOfWeek -> Day -> Bool -prop_toFromWeekCalendar wt ws d = let - (y, wy, dw) = toWeekCalendar wt ws d - in fromWeekCalendar wt ws y wy dw == d +prop_toFromWeekCalendar wt ws d = + let + (y, wy, dw) = toWeekCalendar wt ws d + in + fromWeekCalendar wt ws y wy dw == d prop_weekChanges :: FirstWeekType -> DayOfWeek -> Day -> Bool -prop_weekChanges wt ws d = let - (_, wy0, _) = toWeekCalendar wt ws d - (_, wy1, dw) = toWeekCalendar wt ws $ succ d - in if dw == ws then wy0 /= wy1 else wy0 == wy1 +prop_weekChanges wt ws d = + let + (_, wy0, _) = toWeekCalendar wt ws d + (_, wy1, dw) = toWeekCalendar wt ws $ succ d + in + if dw == ws then wy0 /= wy1 else wy0 == wy1 prop_weekYearWholeStart :: DayOfWeek -> Year -> Bool -prop_weekYearWholeStart ws y = let - d = fromWeekCalendar FirstWholeWeek ws y 1 ws - (y', dy) = toOrdinalDate d - in y == y' && dy >= 1 && dy <= 7 +prop_weekYearWholeStart ws y = + let + d = fromWeekCalendar FirstWholeWeek ws y 1 ws + (y', dy) = toOrdinalDate d + in + y == y' && dy >= 1 && dy <= 7 prop_weekYearMostStart :: DayOfWeek -> Year -> Bool -prop_weekYearMostStart ws y = let - d = fromWeekCalendar FirstMostWeek ws y 2 ws - (y', dy) = toOrdinalDate d - in y == y' && dy >= 5 && dy <= 11 +prop_weekYearMostStart ws y = + let + d = fromWeekCalendar FirstMostWeek ws y 2 ws + (y', dy) = toOrdinalDate d + in + y == y' && dy >= 5 && dy <= 11 testDiff :: TestTree testDiff = diff --git a/test/main/Test/Clock/Conversion.hs b/test/main/Test/Clock/Conversion.hs index 8efb08c9..020ee0d9 100644 --- a/test/main/Test/Clock/Conversion.hs +++ b/test/main/Test/Clock/Conversion.hs @@ -9,17 +9,19 @@ import Test.Tasty.HUnit testClockConversion :: TestTree testClockConversion = - testGroup "clock conversion" $ let - testPair :: (SystemTime, UTCTime) -> TestTree - testPair (st, ut) = - testGroup (show ut) $ - [ testCase "systemToUTCTime" $ assertEqual (show ut) ut $ systemToUTCTime st - , testCase "utcToSystemTime" $ assertEqual (show ut) st $ utcToSystemTime ut - ] - in [ testPair (MkSystemTime 0 0, UTCTime systemEpochDay 0) - , testPair (MkSystemTime 86399 0, UTCTime systemEpochDay 86399) - , testPair (MkSystemTime 86399 999999999, UTCTime systemEpochDay 86399.999999999) - , testPair (MkSystemTime 86399 1000000000, UTCTime systemEpochDay 86400) - , testPair (MkSystemTime 86399 1999999999, UTCTime systemEpochDay 86400.999999999) - , testPair (MkSystemTime 86400 0, UTCTime (succ systemEpochDay) 0) - ] + testGroup "clock conversion" $ + let + testPair :: (SystemTime, UTCTime) -> TestTree + testPair (st, ut) = + testGroup (show ut) $ + [ testCase "systemToUTCTime" $ assertEqual (show ut) ut $ systemToUTCTime st + , testCase "utcToSystemTime" $ assertEqual (show ut) st $ utcToSystemTime ut + ] + in + [ testPair (MkSystemTime 0 0, UTCTime systemEpochDay 0) + , testPair (MkSystemTime 86399 0, UTCTime systemEpochDay 86399) + , testPair (MkSystemTime 86399 999999999, UTCTime systemEpochDay 86399.999999999) + , testPair (MkSystemTime 86399 1000000000, UTCTime systemEpochDay 86400) + , testPair (MkSystemTime 86399 1999999999, UTCTime systemEpochDay 86400.999999999) + , testPair (MkSystemTime 86400 0, UTCTime (succ systemEpochDay) 0) + ] diff --git a/test/main/Test/Clock/TAI.hs b/test/main/Test/Clock/TAI.hs index 1f1f59d9..b124b618 100644 --- a/test/main/Test/Clock/TAI.hs +++ b/test/main/Test/Clock/TAI.hs @@ -19,28 +19,30 @@ sampleLeapSecondMap _ = Nothing testTAI :: TestTree testTAI = - testGroup "leap second transition" $ let - dayA = fromGregorian 1972 6 30 - dayB = fromGregorian 1972 7 1 - utcTime1 = UTCTime dayA 86399 - utcTime2 = UTCTime dayA 86400 - utcTime3 = UTCTime dayB 0 - mAbsTime1 = utcToTAITime sampleLeapSecondMap utcTime1 - mAbsTime2 = utcToTAITime sampleLeapSecondMap utcTime2 - mAbsTime3 = utcToTAITime sampleLeapSecondMap utcTime3 - in [ testCase "mapping" $ do + testGroup "leap second transition" $ + let + dayA = fromGregorian 1972 6 30 + dayB = fromGregorian 1972 7 1 + utcTime1 = UTCTime dayA 86399 + utcTime2 = UTCTime dayA 86400 + utcTime3 = UTCTime dayB 0 + mAbsTime1 = utcToTAITime sampleLeapSecondMap utcTime1 + mAbsTime2 = utcToTAITime sampleLeapSecondMap utcTime2 + mAbsTime3 = utcToTAITime sampleLeapSecondMap utcTime3 + in + [ testCase "mapping" $ do assertEqual "dayA" (Just 10) $ sampleLeapSecondMap dayA assertEqual "dayB" (Just 11) $ sampleLeapSecondMap dayB - , testCase "day length" $ do + , testCase "day length" $ do assertEqual "dayA" (Just 86401) $ utcDayLength sampleLeapSecondMap dayA assertEqual "dayB" (Just 86400) $ utcDayLength sampleLeapSecondMap dayB - , testCase "differences" $ do + , testCase "differences" $ do absTime1 <- assertJust mAbsTime1 absTime2 <- assertJust mAbsTime2 absTime3 <- assertJust mAbsTime3 assertEqual "absTime2 - absTime1" 1 $ diffAbsoluteTime absTime2 absTime1 assertEqual "absTime3 - absTime2" 1 $ diffAbsoluteTime absTime3 absTime2 - , testGroup + , testGroup "round-trip" [ testCase "1" $ do absTime <- assertJust mAbsTime1 @@ -55,4 +57,4 @@ testTAI = utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime assertEqual "round-trip" utcTime3 utcTime ] - ] + ] diff --git a/test/main/Test/Format/Compile.hs b/test/main/Test/Format/Compile.hs index ef1a18a7..d7f16a3a 100644 --- a/test/main/Test/Format/Compile.hs +++ b/test/main/Test/Format/Compile.hs @@ -2,7 +2,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Format.Compile ( - ) where + +) where import Data.Time diff --git a/test/main/Test/Format/Format.hs b/test/main/Test/Format/Format.hs index c00c55a0..f26e060d 100644 --- a/test/main/Test/Format/Format.hs +++ b/test/main/Test/Format/Format.hs @@ -63,10 +63,12 @@ testDayOfWeek :: TestTree testDayOfWeek = testGroup "DayOfWeek" $ tgroup "uwaA" $ \fmt -> - tgroup days $ \day -> let - dayFormat = formatTime defaultTimeLocale ['%', fmt] day - dowFormat = formatTime defaultTimeLocale ['%', fmt] $ dayOfWeek day - in assertEqual "" dayFormat dowFormat + tgroup days $ \day -> + let + dayFormat = formatTime defaultTimeLocale ['%', fmt] day + dowFormat = formatTime defaultTimeLocale ['%', fmt] $ dayOfWeek day + in + assertEqual "" dayFormat dowFormat testZone :: String -> String -> Int -> TestTree testZone fmt expected minutes = @@ -178,15 +180,23 @@ testCalenderDiffTime = [ testAFormat "%yy%Bm%ww%Dd%Hh%Mm%Ss" "5y4m3w2d2h22m8s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21 , testAFormat "%yy%Bm%ww%Dd%Hh%Mm%ESs" "5y4m3w2d2h22m8.21s" $ CalendarDiffTime 64 $ 23 * 86400 + 8528.21 , testAFormat "%yy%Bm%ww%Dd%Hh%Mm%0ESs" "5y4m3w2d2h22m08.210000000000s" $ - CalendarDiffTime 64 $ 23 * 86400 + 8528.21 + CalendarDiffTime 64 $ + 23 * 86400 + 8528.21 , testAFormat "%bm %dd %hh %mm %Ess" "64m 23d 554h 33262m 1995728.21s" $ - CalendarDiffTime 64 $ 23 * 86400 + 8528.21 + CalendarDiffTime 64 $ + 23 * 86400 + 8528.21 , testAFormat "%yy%Bm%ww%Dd%Hh%Mm%Ss" "-5y-4m-3w-2d-2h-22m-8s" $ - CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21 + CalendarDiffTime (-64) $ + negate $ + 23 * 86400 + 8528.21 , testAFormat "%yy%Bm%ww%Dd%Hh%Mm%ESs" "-5y-4m-3w-2d-2h-22m-8.21s" $ - CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21 + CalendarDiffTime (-64) $ + negate $ + 23 * 86400 + 8528.21 , testAFormat "%bm %dd %hh %mm %Ess" "-64m -23d -554h -33262m -1995728.21s" $ - CalendarDiffTime (-64) $ negate $ 23 * 86400 + 8528.21 + CalendarDiffTime (-64) $ + negate $ + 23 * 86400 + 8528.21 ] testFormat :: TestTree diff --git a/test/main/Test/Format/ISO8601.hs b/test/main/Test/Format/ISO8601.hs index d154e76e..77d8e350 100644 --- a/test/main/Test/Format/ISO8601.hs +++ b/test/main/Test/Format/ISO8601.hs @@ -26,7 +26,8 @@ readShowProperty _ fmt val = let found = formatParseM fmt str expected = Just val - in property $ + in + property $ if expected == found then succeeded else failed{reason = show str ++ ": expected " ++ (show expected) ++ ", found " ++ (show found)} @@ -69,13 +70,15 @@ instance Arbitrary (Durational CalendarDiffDays) where return $ MkDurational $ CalendarDiffDays mm dd instance Arbitrary (Durational CalendarDiffTime) where - arbitrary = let - limit = 40 * 86400 - picofactor = 10 ^ (12 :: Int) - in do - mm <- choose (-10000, 10000) - ss <- choose (negate limit * picofactor, limit * picofactor) - return $ MkDurational $ CalendarDiffTime mm $ fromRational $ ss % picofactor + arbitrary = + let + limit = 40 * 86400 + picofactor = 10 ^ (12 :: Int) + in + do + mm <- choose (-10000, 10000) + ss <- choose (negate limit * picofactor, limit * picofactor) + return $ MkDurational $ CalendarDiffTime mm $ fromRational $ ss % picofactor durationalFormat :: Format a -> Format (Durational a) durationalFormat (MkFormat sa ra) = MkFormat (\b -> sa $ unDurational b) (fmap MkDurational ra) @@ -106,19 +109,24 @@ testReadShowFormat = , nameTest "timeOffsetFormat" $ readShowTests $ timeOffsetFormat , nameTest "timeOfDayAndOffsetFormat" $ readShowTests $ timeOfDayAndOffsetFormat , nameTest "localTimeFormat" $ - readShowTests $ \fe -> localTimeFormat (calendarFormat fe) (timeOfDayFormat fe) + readShowTests $ + \fe -> localTimeFormat (calendarFormat fe) (timeOfDayFormat fe) , nameTest "zonedTimeFormat" $ - readShowTests $ \fe -> zonedTimeFormat (calendarFormat fe) (timeOfDayFormat fe) fe + readShowTests $ + \fe -> zonedTimeFormat (calendarFormat fe) (timeOfDayFormat fe) fe , nameTest "utcTimeFormat" $ readShowTests $ \fe -> utcTimeFormat (calendarFormat fe) (timeOfDayFormat fe) , nameTest "dayAndTimeFormat" $ - readShowTests $ \fe -> dayAndTimeFormat (calendarFormat fe) (timeOfDayFormat fe) + readShowTests $ + \fe -> dayAndTimeFormat (calendarFormat fe) (timeOfDayFormat fe) , nameTest "timeAndOffsetFormat" $ readShowTests $ \fe -> timeAndOffsetFormat (timeOfDayFormat fe) fe , nameTest "durationDaysFormat" $ readShowTest $ durationDaysFormat , nameTest "durationTimeFormat" $ readShowTest $ durationTimeFormat , nameTest "alternativeDurationDaysFormat" $ - readBoth $ \fe -> readShowTest (durationalFormat $ alternativeDurationDaysFormat fe) + readBoth $ + \fe -> readShowTest (durationalFormat $ alternativeDurationDaysFormat fe) , nameTest "alternativeDurationTimeFormat" $ - readBoth $ \fe -> readShowTest (durationalFormat $ alternativeDurationTimeFormat fe) + readBoth $ + \fe -> readShowTest (durationalFormat $ alternativeDurationTimeFormat fe) , nameTest "intervalFormat" $ readShowTests $ \fe -> intervalFormat (localTimeFormat (calendarFormat fe) (timeOfDayFormat fe)) durationTimeFormat @@ -158,11 +166,14 @@ testShowFormats = , testShowReadFormat "durationTimeFormat" durationTimeFormat "PT1M18.77634S" $ CalendarDiffTime 0 $ 78.77634 , testShowReadFormat "durationTimeFormat" durationTimeFormat "PT2H1M18.77634S" $ CalendarDiffTime 0 $ 7278.77634 , testShowReadFormat "durationTimeFormat" durationTimeFormat "P5DT2H1M18.77634S" $ - CalendarDiffTime 0 $ 5 * nominalDay + 7278.77634 + CalendarDiffTime 0 $ + 5 * nominalDay + 7278.77634 , testShowReadFormat "durationTimeFormat" durationTimeFormat "P7Y10M5DT2H1M18.77634S" $ - CalendarDiffTime 94 $ 5 * nominalDay + 7278.77634 + CalendarDiffTime 94 $ + 5 * nominalDay + 7278.77634 , testShowReadFormat "durationTimeFormat" durationTimeFormat "P7Y10MT2H1M18.77634S" $ - CalendarDiffTime 94 $ 7278.77634 + CalendarDiffTime 94 $ + 7278.77634 , testShowReadFormat "durationTimeFormat" durationTimeFormat "P8YT2H1M18.77634S" $ CalendarDiffTime 96 $ 7278.77634 , testShowReadFormat "alternativeDurationDaysFormat" (alternativeDurationDaysFormat ExtendedFormat) "P0001-00-00" $ CalendarDiffDays 12 0 @@ -179,12 +190,14 @@ testShowFormats = "alternativeDurationTimeFormat" (alternativeDurationTimeFormat ExtendedFormat) "P0007-10-05T02:01:18.77634" - $ CalendarDiffTime 94 $ 5 * nominalDay + 7278.77634 + $ CalendarDiffTime 94 + $ 5 * nominalDay + 7278.77634 , testShowReadFormat "alternativeDurationTimeFormat" (alternativeDurationTimeFormat ExtendedFormat) "P4271-10-05T02:01:18.77634" - $ CalendarDiffTime (12 * 4271 + 10) $ 5 * nominalDay + 7278.77634 + $ CalendarDiffTime (12 * 4271 + 10) + $ 5 * nominalDay + 7278.77634 , testShowReadFormat "centuryFormat" centuryFormat "02" 2 , testShowReadFormat "centuryFormat" centuryFormat "21" 21 , testShowReadFormat diff --git a/test/main/Test/Format/ParseTime.hs b/test/main/Test/Format/ParseTime.hs index 1fa05c1a..69b58b25 100644 --- a/test/main/Test/Format/ParseTime.hs +++ b/test/main/Test/Format/ParseTime.hs @@ -40,15 +40,17 @@ data FormatCode pf t = MkFormatCode } instance Show (FormatCode pf t) where - show (MkFormatCode m w a s) = let - ms = m - ws = fromMaybe "" $ fmap show w - as = - if a - then "E" - else "" - ss = [s] - in '%' : (ms <> ws <> as <> ss) + show (MkFormatCode m w a s) = + let + ms = m + ws = fromMaybe "" $ fmap show w + as = + if a + then "E" + else "" + ss = [s] + in + '%' : (ms <> ws <> as <> ss) formatCode :: FormatTime t => FormatCode pf t -> t -> String formatCode fc = format $ show fc @@ -65,19 +67,21 @@ minCodeWidth :: Char -> Int minCodeWidth _ = 0 fcShrink :: FormatCode pf t -> [FormatCode pf t] -fcShrink fc = let - fc1 = case fcWidth fc of - Nothing -> [] - Just w - | w > (minCodeWidth $ fcSpecifier fc) -> [fc{fcWidth = Nothing}, fc{fcWidth = Just $ w - 1}] - Just _ -> [fc{fcWidth = Nothing}] - fc2 = case fcAlt fc of - False -> [] - True -> [fc{fcAlt = False}] - fc3 = case fcModifier fc of - "" -> [] - _ -> [fc{fcModifier = ""}] - in fc1 ++ fc2 ++ fc3 +fcShrink fc = + let + fc1 = case fcWidth fc of + Nothing -> [] + Just w + | w > (minCodeWidth $ fcSpecifier fc) -> [fc{fcWidth = Nothing}, fc{fcWidth = Just $ w - 1}] + Just _ -> [fc{fcWidth = Nothing}] + fc2 = case fcAlt fc of + False -> [] + True -> [fc{fcAlt = False}] + fc3 = case fcModifier fc of + "" -> [] + _ -> [fc{fcModifier = ""}] + in + fc1 ++ fc2 ++ fc3 instance HasFormatCodes t => Arbitrary (FormatCode FormatOnly t) where arbitrary = do @@ -153,11 +157,13 @@ extests = ) readTest :: (Eq a, Show a, Read a) => [(a, String)] -> String -> TestTree -readTest expected target = let - found = reads target - result = assertEqual "" expected found - name = show target - in Test.Tasty.HUnit.testCase name result +readTest expected target = + let + found = reads target + result = assertEqual "" expected found + name = show target + in + Test.Tasty.HUnit.testCase name result readTestsParensSpaces :: forall a. @@ -227,11 +233,13 @@ simpleFormatTests = ] where readsTest :: (Show a, Eq a, ParseTime a) => [(a, String)] -> String -> String -> TestTree - readsTest expected formatStr target = let - found = readSTime False defaultTimeLocale formatStr target - result = assertEqual "" expected found - name = (show formatStr) ++ " of " ++ (show target) - in Test.Tasty.HUnit.testCase name result + readsTest expected formatStr target = + let + found = readSTime False defaultTimeLocale formatStr target + result = assertEqual "" expected found + name = (show formatStr) ++ " of " ++ (show target) + in + Test.Tasty.HUnit.testCase name result spacingTests :: (Show t, Eq t, ParseTime t) => t -> String -> String -> TestTree spacingTests expected formatStr target = @@ -298,25 +306,27 @@ parseCentury int c = parseTest False (Just (fromGregorian (c * 100) 1 1)) ("%-C" ++ int ++ "%y") ((show c) ++ int ++ "00") parseTest :: (Show t, Eq t, ParseTime t) => Bool -> Maybe t -> String -> String -> TestTree -parseTest sp expected formatStr target = let - found = parse sp formatStr target - result = assertEqual "" expected found - name = - (show formatStr) - ++ " of " - ++ (show target) - ++ ( if sp - then " allowing spaces" - else "" - ) - in Test.Tasty.HUnit.testCase name result +parseTest sp expected formatStr target = + let + found = parse sp formatStr target + result = assertEqual "" expected found + name = + (show formatStr) + ++ " of " + ++ (show target) + ++ ( if sp + then " allowing spaces" + else "" + ) + in + Test.Tasty.HUnit.testCase name result {- readsTest :: forall t. (Show t, Eq t, ParseTime t) => Maybe t -> String -> String -> TestTree readsTest (Just e) = readsTest' [(e,"")] readsTest Nothing = readsTest' ([] :: [(t,String)]) -} -enumAdd :: (Enum a) => Int -> a -> a +enumAdd :: Enum a => Int -> a -> a enumAdd i a = toEnum (i + fromEnum a) getMilZoneLetter :: Int -> Char @@ -364,9 +374,11 @@ compareParse expected fmt text = compareResult' (", parsing " ++ (show text)) (J -- test_parse_format :: (FormatTime t, ParseTime t, Show t) => String -> t -> (String, String, Maybe t) -test_parse_format f t = let - s = format f t - in (show t, s, parse False f s `asTypeOf` Just t) +test_parse_format f t = + let + s = format f t + in + (show t, s, parse False f s `asTypeOf` Just t) -- @@ -405,16 +417,20 @@ prop_parse_showOrdinalDate d = compareParse d "%Y-%j" (showOrdinalDate d) -- prop_fromMondayStartWeek :: Day -> Result -prop_fromMondayStartWeek d = let - (w, wd) = mondayStartWeek d - (y, _, _) = toGregorian d - in compareResult d (fromMondayStartWeek y w wd) +prop_fromMondayStartWeek d = + let + (w, wd) = mondayStartWeek d + (y, _, _) = toGregorian d + in + compareResult d (fromMondayStartWeek y w wd) prop_fromSundayStartWeek :: Day -> Result -prop_fromSundayStartWeek d = let - (w, wd) = sundayStartWeek d - (y, _, _) = toGregorian d - in compareResult d (fromSundayStartWeek y w wd) +prop_fromSundayStartWeek d = + let + (w, wd) = sundayStartWeek d + (y, _, _) = toGregorian d + in + compareResult d (fromSundayStartWeek y w wd) -- t == parse (format t) prop_parse_format :: (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result @@ -444,13 +460,15 @@ prop_format_parse_format :: FormatCode ParseAndFormat t -> t -> Result -prop_format_parse_format _ fc v = let - s1 = formatCode fc v - ms1 = in1970 (fmap (formatCode fc) (incompleteS :: Maybe t)) (fcSpecifier fc) s1 - mv2 :: Maybe t - mv2 = parseCode fc s1 - ms2 = fmap (formatCode fc) mv2 - in compareResult ms1 ms2 +prop_format_parse_format _ fc v = + let + s1 = formatCode fc v + ms1 = in1970 (fmap (formatCode fc) (incompleteS :: Maybe t)) (fcSpecifier fc) s1 + mv2 :: Maybe t + mv2 = parseCode fc s1 + ms2 = fmap (formatCode fc) mv2 + in + compareResult ms1 ms2 instance HasFormatCodes Day where allFormatCodes _ = [(False, s) | s <- "DFxYyCBbhmdejfVUW"] @@ -467,7 +485,7 @@ instance HasFormatCodes TimeZone where instance HasFormatCodes ZonedTime where allFormatCodes _ = [(False, s) | s <- "cs"] - ++ allFormatCodes (Proxy :: Proxy LocalTime) + ++ allFormatCodes (Proxy :: Proxy LocalTime) ++ allFormatCodes (Proxy :: Proxy TimeZone) instance HasFormatCodes UTCTime where @@ -525,7 +543,8 @@ typedTests prop = , nameTest "TimeZone" $ tgroup timeZoneFormats prop , nameTest "ZonedTime" $ tgroup zonedTimeFormats prop , nameTest "ZonedTime" $ - tgroup zonedTimeAlmostFormats $ \fmt t -> (todSec $ localTimeOfDay $ zonedTimeToLocalTime t) < 60 ==> prop fmt t + tgroup zonedTimeAlmostFormats $ + \fmt t -> (todSec $ localTimeOfDay $ zonedTimeToLocalTime t) < 60 ==> prop fmt t , nameTest "UTCTime" $ tgroup utcTimeAlmostFormats $ \fmt t -> utctDayTime t < 86400 ==> prop fmt t , nameTest "UniversalTime" $ tgroup universalTimeFormats prop , nameTest "CalendarDiffDays" $ tgroup calendarDiffDaysFormats prop @@ -550,22 +569,24 @@ allTypes f = allLeapSecondTypes :: (forall t. (Eq t, Show t, Arbitrary t, FormatTime t, ParseTime t, HasFormatCodes t) => String -> t -> r) -> [r] -allLeapSecondTypes f = let - day :: Day - day = fromGregorian 2000 01 01 - lsTimeOfDay :: TimeOfDay - lsTimeOfDay = TimeOfDay 23 59 60.5 - lsLocalTime :: LocalTime - lsLocalTime = LocalTime day lsTimeOfDay - lsZonedTime :: ZonedTime - lsZonedTime = ZonedTime lsLocalTime utc - lsUTCTime :: UTCTime - lsUTCTime = UTCTime day 86400.5 - in [ f "TimeOfDay" lsTimeOfDay - , f "LocalTime" lsLocalTime - , f "ZonedTime" lsZonedTime - , f "UTCTime" lsUTCTime - ] +allLeapSecondTypes f = + let + day :: Day + day = fromGregorian 2000 01 01 + lsTimeOfDay :: TimeOfDay + lsTimeOfDay = TimeOfDay 23 59 60.5 + lsLocalTime :: LocalTime + lsLocalTime = LocalTime day lsTimeOfDay + lsZonedTime :: ZonedTime + lsZonedTime = ZonedTime lsLocalTime utc + lsUTCTime :: UTCTime + lsUTCTime = UTCTime day 86400.5 + in + [ f "TimeOfDay" lsTimeOfDay + , f "LocalTime" lsLocalTime + , f "ZonedTime" lsZonedTime + , f "UTCTime" lsUTCTime + ] parseEmptyTest :: forall t. @@ -585,7 +606,9 @@ formatParseFormatTests = nameTest "format_parse_format" [ localOption (QuickCheckTests 50000) $ - nameTest "general" $ allTypes $ \name p -> nameTest name $ prop_format_parse_format p + nameTest "general" $ + allTypes $ + \name p -> nameTest name $ prop_format_parse_format p , nameTest "#177" $ [ nameTest "start" $ \fc -> prop_format_parse_format Proxy fc (fst supportedDayRange) , nameTest "end" $ \fc -> prop_format_parse_format Proxy fc (snd supportedDayRange) diff --git a/test/main/Test/LocalTime/Time.hs b/test/main/Test/LocalTime/Time.hs index 07fb359d..96342d23 100644 --- a/test/main/Test/LocalTime/Time.hs +++ b/test/main/Test/LocalTime/Time.hs @@ -10,16 +10,18 @@ import Test.Tasty import Test.Tasty.HUnit showCal :: Integer -> String -showCal mjd = let - date = ModifiedJulianDay mjd - (y, m, d) = toGregorian date - date' = fromGregorian y m d - in concat - [ show mjd ++ "=" ++ showGregorian date ++ "=" ++ showOrdinalDate date ++ "=" ++ showWeekDate date ++ "\n" - , if date == date' - then "" - else "=" ++ (show $ toModifiedJulianDay date') ++ "!" - ] +showCal mjd = + let + date = ModifiedJulianDay mjd + (y, m, d) = toGregorian date + date' = fromGregorian y m d + in + concat + [ show mjd ++ "=" ++ showGregorian date ++ "=" ++ showOrdinalDate date ++ "=" ++ showWeekDate date ++ "\n" + , if date == date' + then "" + else "=" ++ (show $ toModifiedJulianDay date') ++ "!" + ] testCal :: String testCal = @@ -63,10 +65,12 @@ leapSec1998 :: UTCTime leapSec1998 = localTimeToUTC utc leapSec1998Cal testUTC :: String -testUTC = let - lsMineCal = utcToLocalTime myzone leapSec1998 - lsMine = localTimeToUTC myzone lsMineCal - in unlines [showCal 51178, show leapSec1998Cal, showUTCTime leapSec1998, show lsMineCal, showUTCTime lsMine] +testUTC = + let + lsMineCal = utcToLocalTime myzone leapSec1998 + lsMine = localTimeToUTC myzone lsMineCal + in + unlines [showCal 51178, show leapSec1998Cal, showUTCTime leapSec1998, show lsMineCal, showUTCTime lsMine] neglong :: Rational neglong = -120 @@ -86,17 +90,20 @@ testUT1 = ] testTimeOfDayToDayFraction :: String -testTimeOfDayToDayFraction = let - f = dayFractionToTimeOfDay . timeOfDayToDayFraction - in unlines - [ show $ f $ TimeOfDay 12 34 56.789 - , show $ f $ TimeOfDay 12 34 56.789123 - , show $ f $ TimeOfDay 12 34 56.789123456 - , show $ f $ TimeOfDay 12 34 56.789123456789 - , show $ f $ TimeOfDay minBound 0 0 - ] +testTimeOfDayToDayFraction = + let + f = dayFractionToTimeOfDay . timeOfDayToDayFraction + in + unlines + [ show $ f $ TimeOfDay 12 34 56.789 + , show $ f $ TimeOfDay 12 34 56.789123 + , show $ f $ TimeOfDay 12 34 56.789123456 + , show $ f $ TimeOfDay 12 34 56.789123456789 + , show $ f $ TimeOfDay minBound 0 0 + ] testTime :: TestTree testTime = testCase "testTime" $ - assertEqual "times" testTimeRef $ unlines [testCal, testUTC, testUT1, testTimeOfDayToDayFraction] + assertEqual "times" testTimeRef $ + unlines [testCal, testUTC, testUT1, testTimeOfDayToDayFraction] diff --git a/test/main/Test/LocalTime/TimeOfDay.hs b/test/main/Test/LocalTime/TimeOfDay.hs index 93a3f537..cd220d91 100644 --- a/test/main/Test/LocalTime/TimeOfDay.hs +++ b/test/main/Test/LocalTime/TimeOfDay.hs @@ -11,12 +11,16 @@ testTimeOfDay :: TestTree testTimeOfDay = testGroup "TimeOfDay" - [ testProperty "daysAndTimeOfDayToTime . timeToDaysAndTimeOfDay" $ \ndt -> let - (d, tod) = timeToDaysAndTimeOfDay ndt - ndt' = daysAndTimeOfDayToTime d tod - in ndt' == ndt - , testProperty "timeOfDayToTime . timeToTimeOfDay" $ \dt -> let - tod = timeToTimeOfDay dt - dt' = timeOfDayToTime tod - in dt' == dt + [ testProperty "daysAndTimeOfDayToTime . timeToDaysAndTimeOfDay" $ \ndt -> + let + (d, tod) = timeToDaysAndTimeOfDay ndt + ndt' = daysAndTimeOfDayToTime d tod + in + ndt' == ndt + , testProperty "timeOfDayToTime . timeToTimeOfDay" $ \dt -> + let + tod = timeToTimeOfDay dt + dt' = timeOfDayToTime tod + in + dt' == dt ] diff --git a/test/unix/Test/Format/Format.hs b/test/unix/Test/Format/Format.hs index b0a84ccc..9532f648 100644 --- a/test/unix/Test/Format/Format.hs +++ b/test/unix/Test/Format/Format.hs @@ -76,12 +76,16 @@ locale :: TimeLocale locale = defaultTimeLocale{dateTimeFmt = "%a %b %e %H:%M:%S %Y"} instance Random (F.Fixed res) where - randomR (MkFixed lo, MkFixed hi) oldgen = let - (v, newgen) = randomR (lo, hi) oldgen - in (MkFixed v, newgen) - random oldgen = let - (v, newgen) = random oldgen - in (MkFixed v, newgen) + randomR (MkFixed lo, MkFixed hi) oldgen = + let + (v, newgen) = randomR (lo, hi) oldgen + in + (MkFixed v, newgen) + random oldgen = + let + (v, newgen) = random oldgen + in + (MkFixed v, newgen) instance Arbitrary TimeZone where arbitrary = do @@ -104,10 +108,12 @@ instance Arbitrary TimeOfDay where -- | The size of 'CTime' is platform-dependent. secondsFitInCTime :: Integer -> Bool -secondsFitInCTime sec = let - CTime ct = fromInteger sec - sec' = toInteger ct - in sec == sec' +secondsFitInCTime sec = + let + CTime ct = fromInteger sec + sec' = toInteger ct + in + sec == sec' instance Arbitrary UTCTime where arbitrary = do @@ -147,12 +153,14 @@ unixWorkarounds _ s = s compareFormat :: (String -> String) -> String -> TimeZone -> UTCTime -> Result compareFormat _modUnix fmt zone _time | last fmt == 'Z' && timeZoneName zone == "" = rejected -compareFormat modUnix fmt zone time = let - ctime = utcToZonedTime zone time - haskellText = formatTime locale fmt ctime - unixText = unixFormatTime fmt zone time - expectedText = unixWorkarounds fmt (modUnix unixText) - in assertEqualQC (show time ++ " with " ++ show zone) expectedText haskellText +compareFormat modUnix fmt zone time = + let + ctime = utcToZonedTime zone time + haskellText = formatTime locale fmt ctime + unixText = unixFormatTime fmt zone time + expectedText = unixWorkarounds fmt (modUnix unixText) + in + assertEqualQC (show time ++ " with " ++ show zone) expectedText haskellText -- as found in http://www.opengroup.org/onlinepubs/007908799/xsh/strftime.html -- plus FgGklz @@ -200,10 +208,12 @@ testCompareHashFormat = formatUnitTest :: String -> Pico -> String -> TestTree formatUnitTest fmt sec expected = - nameTest (show fmt) $ let - tod = TimeOfDay 0 0 (1 + sec) - found = formatTime locale fmt tod - in assertEqual "" expected found + nameTest (show fmt) $ + let + tod = TimeOfDay 0 0 (1 + sec) + found = formatTime locale fmt tod + in + assertEqual "" expected found testQs :: [TestTree] testQs = diff --git a/test/unix/Test/LocalTime/TimeZone.hs b/test/unix/Test/LocalTime/TimeZone.hs index 784b643f..5bc10ec6 100644 --- a/test/unix/Test/LocalTime/TimeZone.hs +++ b/test/unix/Test/LocalTime/TimeZone.hs @@ -10,7 +10,8 @@ import Test.Tasty.HUnit testTimeZone :: TestTree testTimeZone = testCase "getTimeZone respects TZ env var" $ do - let epoch = UTCTime (ModifiedJulianDay 57000) 0 + let + epoch = UTCTime (ModifiedJulianDay 57000) 0 setEnv "TZ" "UTC+0" zone1 <- getTimeZone epoch setEnv "TZ" "EST+5" diff --git a/test/unix/Test/TestUtil.hs b/test/unix/Test/TestUtil.hs index e26eb807..124342fd 100644 --- a/test/unix/Test/TestUtil.hs +++ b/test/unix/Test/TestUtil.hs @@ -32,7 +32,7 @@ instance NameTest Result where instance (Arbitrary a, Show a, Testable b) => NameTest (a -> b) where nameTest name = nameTest name . property -instance (Testable a) => NameTest (Gen a) where +instance Testable a => NameTest (Gen a) where nameTest name = nameTest name . property tgroup :: (Show a, NameTest t) => [a] -> (a -> t) -> [TestTree]