time 1.11.1.2 → 1.12
raw patch · 81 files changed
+3293/−3117 lines, 81 filesdep ~basesetup-changed
Dependency ranges changed: base
Files
- Setup.hs +3/−3
- changelog.md +7/−0
- configure +9/−9
- configure.ac +1/−1
- lib/Data/Format.hs +104/−102
- lib/Data/Time/Calendar.hs +6/−6
- lib/Data/Time/Calendar/CalendarDiffDays.hs +13/−21
- lib/Data/Time/Calendar/Days.hs +7/−7
- lib/Data/Time/Calendar/Easter.hs +9/−9
- lib/Data/Time/Calendar/Gregorian.hs +74/−58
- lib/Data/Time/Calendar/Julian.hs +74/−58
- lib/Data/Time/Calendar/JulianYearDay.hs +22/−20
- lib/Data/Time/Calendar/Month.hs +23/−26
- lib/Data/Time/Calendar/MonthDay.hs +44/−26
- lib/Data/Time/Calendar/OrdinalDate.hs +91/−76
- lib/Data/Time/Calendar/Private.hs +6/−5
- lib/Data/Time/Calendar/Quarter.hs +21/−23
- lib/Data/Time/Calendar/Types.hs +39/−1
- lib/Data/Time/Calendar/Week.hs +9/−11
- lib/Data/Time/Calendar/WeekDate.hs +81/−66
- lib/Data/Time/Clock.hs +9/−9
- lib/Data/Time/Clock/Internal/AbsoluteTime.hs +9/−10
- lib/Data/Time/Clock/Internal/CTimespec.hsc +8/−3
- lib/Data/Time/Clock/Internal/CTimeval.hs +2/−0
- lib/Data/Time/Clock/Internal/DiffTime.hs +14/−15
- lib/Data/Time/Clock/Internal/NominalDiffTime.hs +19/−16
- lib/Data/Time/Clock/Internal/POSIXTime.hs +0/−1
- lib/Data/Time/Clock/Internal/SystemTime.hs +20/−12
- lib/Data/Time/Clock/Internal/UTCTime.hs +10/−7
- lib/Data/Time/Clock/Internal/UniversalTime.hs +6/−5
- lib/Data/Time/Clock/POSIX.hs +12/−12
- lib/Data/Time/Clock/System.hs +42/−42
- lib/Data/Time/Clock/TAI.hs +19/−20
- lib/Data/Time/Format.hs +5/−6
- lib/Data/Time/Format/Format/Class.hs +84/−85
- lib/Data/Time/Format/Format/Instances.hs +33/−36
- lib/Data/Time/Format/ISO8601.hs +129/−117
- lib/Data/Time/Format/Internal.hs +9/−8
- lib/Data/Time/Format/Locale.hs +55/−56
- lib/Data/Time/Format/Parse.hs +112/−73
- lib/Data/Time/Format/Parse/Class.hs +139/−135
- lib/Data/Time/Format/Parse/Instances.hs +194/−199
- lib/Data/Time/LocalTime.hs +14/−15
- lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs +15/−21
- lib/Data/Time/LocalTime/Internal/LocalTime.hs +12/−11
- lib/Data/Time/LocalTime/Internal/TimeOfDay.hs +34/−31
- lib/Data/Time/LocalTime/Internal/TimeZone.hs +50/−47
- lib/Data/Time/LocalTime/Internal/ZonedTime.hs +10/−8
- lib/include/HsTimeConfig.h +0/−122
- test/ShowDefaultTZAbbreviations.hs +5/−4
- test/main/Main.hs +16/−14
- test/main/Test/Arbitrary.hs +43/−38
- test/main/Test/Calendar/AddDays.hs +11/−5
- test/main/Test/Calendar/CalendarProps.hs +6/−9
- test/main/Test/Calendar/Calendars.hs +3/−3
- test/main/Test/Calendar/ClipDates.hs +16/−14
- test/main/Test/Calendar/ClipDatesRef.hs +567/−567
- test/main/Test/Calendar/ConvertBack.hs +16/−16
- test/main/Test/Calendar/Duration.hs +13/−13
- test/main/Test/Calendar/Easter.hs +20/−21
- test/main/Test/Calendar/LongWeekYears.hs +11/−9
- test/main/Test/Calendar/MonthDay.hs +10/−9
- test/main/Test/Calendar/MonthOfYear.hs +26/−0
- test/main/Test/Calendar/Valid.hs +85/−79
- test/main/Test/Calendar/Week.hs +76/−75
- test/main/Test/Clock/Conversion.hs +16/−16
- test/main/Test/Clock/Resolution.hs +22/−21
- test/main/Test/Clock/TAI.hs +40/−40
- test/main/Test/Format/Compile.hs +5/−6
- test/main/Test/Format/Format.hs +39/−39
- test/main/Test/Format/ISO8601.hs +141/−120
- test/main/Test/Format/ParseTime.hs +230/−206
- test/main/Test/LocalTime/CalendarDiffTime.hs +4/−4
- test/main/Test/LocalTime/Time.hs +41/−41
- test/main/Test/LocalTime/TimeOfDay.hs +11/−11
- test/main/Test/LocalTime/TimeRef.hs +6/−5
- test/main/Test/Types.hs +17/−1
- test/unix/Test/Format/Format.hs +73/−61
- test/unix/Test/LocalTime/TimeZone.hs +3/−3
- test/unix/Test/TestUtil.hs +2/−2
- time.cabal +11/−15
Setup.hs view
@@ -1,6 +1,6 @@-module Main- ( main- ) where+module Main (+ main,+) where import Distribution.Simple
changelog.md view
@@ -1,5 +1,12 @@ # Change Log +## [1.12] - 2021-06-12+- support GHC 8.8, 8.10, 9.0 only+- add patterns for each month of year+- fix: don't provide TAI clock where it's unavailable (e.g. FreeBSD)+- fix: handle time of day 24:00:00 for ISO 8601 parsing (only)+- fix parsing of %f and %G with negative years+ ## [1.11.1.2] - 2021-04-24 - fix cabal file - correct "license" field in cabal file
configure view
@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles.-# Generated by GNU Autoconf 2.69 for Haskell time package 1.11.1.2.+# Generated by GNU Autoconf 2.69 for Haskell time package 1.12. # # Report bugs to <ashley@semantic.org>. #@@ -580,8 +580,8 @@ # Identity of this package. PACKAGE_NAME='Haskell time package' PACKAGE_TARNAME='time'-PACKAGE_VERSION='1.11.1.2'-PACKAGE_STRING='Haskell time package 1.11.1.2'+PACKAGE_VERSION='1.12'+PACKAGE_STRING='Haskell time package 1.12' PACKAGE_BUGREPORT='ashley@semantic.org' PACKAGE_URL='' @@ -1238,7 +1238,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF-\`configure' configures Haskell time package 1.11.1.2 to adapt to many kinds of systems.+\`configure' configures Haskell time package 1.12 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1300,7 +1300,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in- short | recursive ) echo "Configuration of Haskell time package 1.11.1.2:";;+ short | recursive ) echo "Configuration of Haskell time package 1.12:";; esac cat <<\_ACEOF @@ -1386,7 +1386,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF-Haskell time package configure 1.11.1.2+Haskell time package configure 1.12 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc.@@ -1858,7 +1858,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by Haskell time package $as_me 1.11.1.2, which was+It was created by Haskell time package $as_me 1.12, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@@@ -4193,7 +4193,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log="-This file was extended by Haskell time package $as_me 1.11.1.2, which was+This file was extended by Haskell time package $as_me 1.12, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES@@ -4246,7 +4246,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\-Haskell time package config.status 1.11.1.2+Haskell time package config.status 1.12 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\"
configure.ac view
@@ -1,4 +1,4 @@-AC_INIT([Haskell time package], [1.11.1.2], [ashley@semantic.org], [time])+AC_INIT([Haskell time package], [1.12], [ashley@semantic.org], [time]) # Safety check: Ensure that we are in the correct source directory. AC_CONFIG_SRCDIR([lib/include/HsTime.h])
lib/Data/Format.hs view
@@ -1,34 +1,34 @@ {-# LANGUAGE Safe #-} -module Data.Format- ( Productish(..)- , Summish(..)- , parseReader- , Format(..)- , formatShow- , formatParseM- , isoMap- , mapMFormat- , filterFormat- , clipFormat- , enumMap- , literalFormat- , specialCaseShowFormat- , specialCaseFormat- , optionalFormat- , casesFormat- , optionalSignFormat- , mandatorySignFormat- , SignOption(..)- , integerFormat- , decimalFormat- ) where+module Data.Format (+ Productish (..),+ Summish (..),+ parseReader,+ Format (..),+ formatShow,+ formatParseM,+ isoMap,+ mapMFormat,+ filterFormat,+ clipFormat,+ enumMap,+ literalFormat,+ specialCaseShowFormat,+ specialCaseFormat,+ optionalFormat,+ casesFormat,+ optionalSignFormat,+ mandatorySignFormat,+ SignOption (..),+ integerFormat,+ decimalFormat,+) where import Control.Monad.Fail import Data.Char import Data.Void-import Prelude hiding (fail) import Text.ParserCombinators.ReadP+import Prelude hiding (fail) class IsoVariant f where isoMap :: (a -> b) -> (b -> a) -> f a -> f b@@ -61,10 +61,10 @@ -- | A text format for a type data Format t = MkFormat- { formatShowM :: t -> Maybe String- -- ^ Show a value in the format, if representable- , formatReadP :: ReadP t- -- ^ Read a value in the format+ { -- | Show a value in the format, if representable+ formatShowM :: t -> Maybe String+ , -- | Read a value in the format+ formatReadP :: ReadP t } -- | Show a value in the format, or error if unrepresentable@@ -92,86 +92,88 @@ filterFormat :: (a -> Bool) -> Format a -> Format a filterFormat test = mapMFormat- (\a ->- if test a- then Just a- else Nothing)- (\a ->- if test a- then Just a- else Nothing)+ ( \a ->+ if test a+ then Just a+ else Nothing+ )+ ( \a ->+ if test a+ then Just a+ else Nothing+ ) -- | Limits are inclusive clipFormat :: Ord a => (a, a) -> Format a -> Format a clipFormat (lo, hi) = filterFormat (\a -> a >= lo && a <= hi) instance Productish Format where- pUnit = MkFormat {formatShowM = \_ -> Just "", formatReadP = return ()}- (<**>) (MkFormat sa ra) (MkFormat sb rb) = let- sab (a, b) = do- astr <- sa a- bstr <- sb b- return $ astr ++ bstr- rab = do- a <- ra- b <- rb- return (a, b)- in MkFormat sab rab- (MkFormat sa ra) **> (MkFormat sb rb) = let- s b = do- astr <- sa ()- bstr <- sb b- return $ astr ++ bstr- r = do- ra- rb- in MkFormat s r- (MkFormat sa ra) <** (MkFormat sb rb) = let- s a = do- astr <- sa a- bstr <- sb ()- return $ astr ++ bstr- r = do- a <- ra- rb- return a- in MkFormat s r+ pUnit = MkFormat{formatShowM = \_ -> Just "", formatReadP = return ()}+ (<**>) (MkFormat sa ra) (MkFormat sb rb) =+ let sab (a, b) = do+ astr <- sa a+ bstr <- sb b+ return $ astr ++ bstr+ rab = do+ a <- ra+ b <- rb+ return (a, b)+ in MkFormat sab rab+ (MkFormat sa ra) **> (MkFormat sb rb) =+ let s b = do+ astr <- sa ()+ bstr <- sb b+ return $ astr ++ bstr+ r = do+ ra+ rb+ in MkFormat s r+ (MkFormat sa ra) <** (MkFormat sb rb) =+ let s a = do+ astr <- sa a+ bstr <- sb ()+ return $ astr ++ bstr+ r = do+ a <- ra+ rb+ return a+ in MkFormat s r instance Summish Format where pVoid = MkFormat absurd pfail- (MkFormat sa ra) <++> (MkFormat sb rb) = let- sab (Left a) = sa a- sab (Right b) = sb b- rab = (fmap Left ra) +++ (fmap Right rb)- in MkFormat sab rab+ (MkFormat sa ra) <++> (MkFormat sb rb) =+ let sab (Left a) = sa a+ sab (Right b) = sb b+ rab = (fmap Left ra) +++ (fmap Right rb)+ in MkFormat sab rab literalFormat :: String -> Format ()-literalFormat s = MkFormat {formatShowM = \_ -> Just s, formatReadP = string s >> return ()}+literalFormat s = MkFormat{formatShowM = \_ -> Just s, formatReadP = string s >> return ()} specialCaseShowFormat :: Eq a => (a, String) -> Format a -> Format a-specialCaseShowFormat (val, str) (MkFormat s r) = let- s' t- | t == val = Just str- s' t = s t- in MkFormat s' r+specialCaseShowFormat (val, str) (MkFormat s r) =+ let s' t+ | t == val = Just str+ s' t = s t+ in MkFormat s' r specialCaseFormat :: Eq a => (a, String) -> Format a -> Format a-specialCaseFormat (val, str) (MkFormat s r) = let- s' t- | t == val = Just str- s' t = s t- r' = (string str >> return val) +++ r- in MkFormat s' r'+specialCaseFormat (val, str) (MkFormat s r) =+ let s' t+ | t == val = Just str+ s' t = s t+ r' = (string str >> return val) +++ r+ in MkFormat s' r' optionalFormat :: Eq a => a -> Format a -> Format a optionalFormat val = specialCaseFormat (val, "") casesFormat :: Eq a => [(a, String)] -> Format a-casesFormat pairs = let- s t = lookup t pairs- r [] = pfail- r ((v, str):pp) = (string str >> return v) <++ r pp- in MkFormat s $ r pairs+casesFormat pairs =+ let s t = lookup t pairs+ r [] = pfail+ r ((v, str) : pp) = (string str >> return v) <++ r pp+ in MkFormat s $ r pairs optionalSignFormat :: (Eq t, Num t) => Format t optionalSignFormat = casesFormat [(1, ""), (1, "+"), (0, ""), (-1, "-")]@@ -218,20 +220,20 @@ trimTrailing s = s showNumber :: Show t => SignOption -> Maybe Int -> t -> Maybe String-showNumber signOpt mdigitcount t = let- showIt str = let- (intPart, decPart) = break ((==) '.') str- in (zeroPad mdigitcount intPart) ++ trimTrailing decPart- in case show t of- ('-':str) ->- case signOpt of- NoSign -> Nothing- _ -> Just $ '-' : showIt str- str ->- Just $- case signOpt of- PosNegSign -> '+' : showIt str- _ -> showIt str+showNumber signOpt mdigitcount t =+ let showIt str =+ let (intPart, decPart) = break ((==) '.') str+ in (zeroPad mdigitcount intPart) ++ trimTrailing decPart+ in case show t of+ ('-' : str) ->+ case signOpt of+ NoSign -> Nothing+ _ -> Just $ '-' : showIt str+ str ->+ Just $+ case signOpt of+ PosNegSign -> '+' : showIt str+ _ -> showIt str integerFormat :: (Show t, Read t, Num t) => SignOption -> Maybe Int -> Format t integerFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount False)
lib/Data/Time/Calendar.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE Safe #-} -module Data.Time.Calendar- ( module Data.Time.Calendar.Days- , module Data.Time.Calendar.CalendarDiffDays- , module Data.Time.Calendar.Gregorian- , module Data.Time.Calendar.Week- ) where+module Data.Time.Calendar (+ module Data.Time.Calendar.Days,+ module Data.Time.Calendar.CalendarDiffDays,+ module Data.Time.Calendar.Gregorian,+ module Data.Time.Calendar.Week,+) where import Data.Time.Calendar.CalendarDiffDays import Data.Time.Calendar.Days
lib/Data/Time/Calendar/CalendarDiffDays.hs view
@@ -1,32 +1,24 @@ {-# LANGUAGE Safe #-} -module Data.Time.Calendar.CalendarDiffDays- (- -- * Calendar Duration- module Data.Time.Calendar.CalendarDiffDays- ) where+module Data.Time.Calendar.CalendarDiffDays (+ -- * Calendar Duration+ module Data.Time.Calendar.CalendarDiffDays,+) where -#if MIN_VERSION_base(4,11,0)-#else-import Data.Semigroup hiding (option)-#endif-import Data.Typeable-import Data.Data import Control.DeepSeq+import Data.Data data CalendarDiffDays = CalendarDiffDays { cdMonths :: Integer , cdDays :: Integer- } deriving (Eq,- Data-#if __GLASGOW_HASKELL__ >= 802- -- ^ @since 1.9.2-#endif- ,Typeable-#if __GLASGOW_HASKELL__ >= 802- -- ^ @since 1.9.2-#endif- )+ }+ deriving+ ( Eq+ , -- | @since 1.9.2+ Data+ , -- | @since 1.9.2+ Typeable+ ) instance NFData CalendarDiffDays where rnf (CalendarDiffDays m d) = rnf m `seq` rnf d `seq` ()
lib/Data/Time/Calendar/Days.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE Safe #-} -module Data.Time.Calendar.Days- (+module Data.Time.Calendar.Days ( -- * Days- Day(..)- , addDays- , diffDays- ) where+ Day (..),+ addDays,+ diffDays,+) where import Control.DeepSeq import Data.Data@@ -15,7 +14,8 @@ -- | The Modified Julian Day is a standard count of days, with zero being the day 1858-11-17. newtype Day = ModifiedJulianDay { toModifiedJulianDay :: Integer- } deriving (Eq, Ord, Data, Typeable)+ }+ deriving (Eq, Ord, Data, Typeable) instance NFData Day where rnf (ModifiedJulianDay a) = rnf a
lib/Data/Time/Calendar/Easter.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE Safe #-} -module Data.Time.Calendar.Easter- ( sundayAfter- , orthodoxPaschalMoon- , orthodoxEaster- , gregorianPaschalMoon- , gregorianEaster- ) where+module Data.Time.Calendar.Easter (+ sundayAfter,+ orthodoxPaschalMoon,+ orthodoxEaster,+ gregorianPaschalMoon,+ gregorianEaster,+) where -- formulae from Reingold & Dershowitz, _Calendrical Calculations_, ch. 8. import Data.Time.Calendar@@ -18,7 +18,7 @@ -- | Given a year, find the Paschal full moon according to Orthodox Christian tradition orthodoxPaschalMoon :: Year -> Day-orthodoxPaschalMoon year = addDays (-shiftedEpact) (fromJulian jyear 4 19)+orthodoxPaschalMoon year = addDays (- shiftedEpact) (fromJulian jyear 4 19) where shiftedEpact = mod (14 + 11 * (mod year 19)) 30 jyear =@@ -32,7 +32,7 @@ -- | Given a year, find the Paschal full moon according to the Gregorian method gregorianPaschalMoon :: Year -> Day-gregorianPaschalMoon year = addDays (-adjustedEpact) (fromGregorian year 4 19)+gregorianPaschalMoon year = addDays (- adjustedEpact) (fromGregorian year 4 19) where century = (div year 100) + 1 shiftedEpact = mod (14 + 11 * (mod year 19) - (div (3 * century) 4) + (div (5 + 8 * century) 25)) 30
lib/Data/Time/Calendar/Gregorian.hs view
@@ -1,34 +1,46 @@ {-# LANGUAGE Safe #-}+ {-# OPTIONS -fno-warn-orphans #-} -module Data.Time.Calendar.Gregorian- (+module Data.Time.Calendar.Gregorian ( -- * Year, month and day- Year- , MonthOfYear- , DayOfMonth+ Year,+ MonthOfYear,+ pattern January,+ pattern February,+ pattern March,+ pattern April,+ pattern May,+ pattern June,+ pattern July,+ pattern August,+ pattern September,+ pattern October,+ pattern November,+ pattern December,+ DayOfMonth,+ -- * Gregorian calendar- , toGregorian- , fromGregorian- , pattern YearMonthDay- , fromGregorianValid- , showGregorian- , gregorianMonthLength+ toGregorian,+ fromGregorian,+ pattern YearMonthDay,+ fromGregorianValid,+ showGregorian,+ gregorianMonthLength, -- calendrical arithmetic -- e.g. "one month after March 31st"- , addGregorianMonthsClip- , addGregorianMonthsRollOver- , addGregorianYearsClip- , addGregorianYearsRollOver- , addGregorianDurationClip- , addGregorianDurationRollOver- , diffGregorianDurationClip- , diffGregorianDurationRollOver+ addGregorianMonthsClip,+ addGregorianMonthsRollOver,+ addGregorianYearsClip,+ addGregorianYearsRollOver,+ addGregorianDurationClip,+ addGregorianDurationRollOver,+ diffGregorianDurationClip,+ diffGregorianDurationRollOver, -- re-exported from OrdinalDate- , isLeapYear- ) where+ isLeapYear,+) where -import Data.Time.Calendar.Types import Data.Time.Calendar.CalendarDiffDays import Data.Time.Calendar.Days import Data.Time.Calendar.MonthDay@@ -50,12 +62,12 @@ -- | Bidirectional abstract constructor for the proleptic Gregorian calendar. -- Invalid values will be clipped to the correct range, month first, then day. pattern YearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day-pattern YearMonthDay y m d <- (toGregorian -> (y,m,d)) where- YearMonthDay y m d = fromGregorian y m d+pattern YearMonthDay y m d <-+ (toGregorian -> (y, m, d))+ where+ YearMonthDay y m d = fromGregorian y m d -#if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE YearMonthDay #-}-#endif -- | Convert from proleptic Gregorian calendar. -- Invalid values will return Nothing@@ -117,42 +129,46 @@ -- | 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. -- Same as 'diffGregorianDurationClip' for positive durations. diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays-diffGregorianDurationRollOver 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 = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1- in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed+diffGregorianDurationRollOver 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 = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1+ in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed -- orphan instance instance Show Day where
lib/Data/Time/Calendar/Julian.hs view
@@ -1,35 +1,47 @@ {-# LANGUAGE Safe #-} -module Data.Time.Calendar.Julian- ( Year- , MonthOfYear- , DayOfMonth- , DayOfYear- , module Data.Time.Calendar.JulianYearDay- , toJulian- , fromJulian- , pattern JulianYearMonthDay- , fromJulianValid- , showJulian- , julianMonthLength+module Data.Time.Calendar.Julian (+ Year,+ MonthOfYear,+ pattern January,+ pattern February,+ pattern March,+ pattern April,+ pattern May,+ pattern June,+ pattern July,+ pattern August,+ pattern September,+ pattern October,+ pattern November,+ pattern December,+ DayOfMonth,+ DayOfYear,+ module Data.Time.Calendar.JulianYearDay,+ toJulian,+ fromJulian,+ pattern JulianYearMonthDay,+ fromJulianValid,+ showJulian,+ julianMonthLength, -- calendrical arithmetic -- e.g. "one month after March 31st"- , addJulianMonthsClip- , addJulianMonthsRollOver- , addJulianYearsClip- , addJulianYearsRollOver- , addJulianDurationClip- , addJulianDurationRollOver- , diffJulianDurationClip- , diffJulianDurationRollOver- ) where+ addJulianMonthsClip,+ addJulianMonthsRollOver,+ addJulianYearsClip,+ addJulianYearsRollOver,+ addJulianDurationClip,+ addJulianDurationRollOver,+ diffJulianDurationClip,+ diffJulianDurationRollOver,+) where -import Data.Time.Calendar.Types import Data.Time.Calendar.CalendarDiffDays import Data.Time.Calendar.Days import Data.Time.Calendar.JulianYearDay import Data.Time.Calendar.MonthDay import Data.Time.Calendar.Private+import Data.Time.Calendar.Types -- | Convert to proleptic Julian calendar. toJulian :: Day -> (Year, MonthOfYear, DayOfMonth)@@ -46,12 +58,12 @@ -- | Bidirectional abstract constructor for the proleptic Julian calendar. -- Invalid values will be clipped to the correct range, month first, then day. pattern JulianYearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day-pattern JulianYearMonthDay y m d <- (toJulian -> (y,m,d)) where- JulianYearMonthDay y m d = fromJulian y m d+pattern JulianYearMonthDay y m d <-+ (toJulian -> (y, m, d))+ where+ JulianYearMonthDay y m d = fromJulian y m d -#if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE JulianYearMonthDay #-}-#endif -- | Convert from proleptic Julian calendar. -- Invalid values will return Nothing.@@ -113,39 +125,43 @@ -- | 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. -- Same as 'diffJulianDurationClip' for positive durations. diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays-diffJulianDurationRollOver 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 = addJulianDurationRollOver (CalendarDiffDays ymAllowed 0) day1- in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed+diffJulianDurationRollOver 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 = addJulianDurationRollOver (CalendarDiffDays ymAllowed 0) day1+ in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
lib/Data/Time/Calendar/JulianYearDay.hs view
@@ -1,14 +1,13 @@ {-# LANGUAGE Safe #-} -module Data.Time.Calendar.JulianYearDay- (+module Data.Time.Calendar.JulianYearDay ( -- * Year and day format- module Data.Time.Calendar.JulianYearDay- ) where+ module Data.Time.Calendar.JulianYearDay,+) where -import Data.Time.Calendar.Types import Data.Time.Calendar.Days import Data.Time.Calendar.Private+import Data.Time.Calendar.Types -- | Convert to proleptic Julian year and day format. toJulianYearAndDay :: Day -> (Year, DayOfYear)@@ -28,16 +27,19 @@ where y = year - 1 mjd =- (fromIntegral- (clip- 1- (if isJulianLeapYear year- then 366- else 365)- day)) +- (365 * y) +- (div y 4) -- 678578+ ( fromIntegral+ ( clip+ 1+ ( if isJulianLeapYear year+ then 366+ else 365+ )+ day+ )+ )+ + (365 * y)+ + (div y 4)+ - 678578 -- | Convert from proleptic Julian year and day format. -- Invalid day numbers will return Nothing@@ -46,12 +48,12 @@ day' <- clipValid 1- (if isJulianLeapYear year- then 366- else 365)+ ( if isJulianLeapYear year+ then 366+ else 365+ ) day- let- y = year - 1+ let y = year - 1 mjd = (fromIntegral day') + (365 * y) + (div y 4) - 678578 return (ModifiedJulianDay mjd)
lib/Data/Time/Calendar/Month.hs view
@@ -1,28 +1,25 @@ {-# LANGUAGE Safe #-}-#if __GLASGOW_HASKELL__ < 802-{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-incomplete-uni-patterns #-}-#endif -- | An absolute count of common calendar months.-module Data.Time.Calendar.Month- (- Month(..), addMonths, diffMonths,- pattern YearMonth,- fromYearMonthValid,- pattern MonthDay,- fromMonthDayValid- ) where+module Data.Time.Calendar.Month (+ Month (..),+ addMonths,+ diffMonths,+ pattern YearMonth,+ fromYearMonthValid,+ pattern MonthDay,+ fromMonthDayValid,+) where -import Data.Time.Calendar.Types+import Control.DeepSeq+import Data.Data+import Data.Fixed+import Data.Ix import Data.Time.Calendar.Days import Data.Time.Calendar.Gregorian import Data.Time.Calendar.Private-import Data.Data-import Data.Fixed-import Text.Read import Text.ParserCombinators.ReadP-import Control.DeepSeq-import Data.Ix+import Text.Read -- | An absolute count of common calendar months. -- Number is equal to @(year * 12) + (monthOfYear - 1)@.@@ -69,30 +66,30 @@ -- | Bidirectional abstract constructor. -- Invalid months of year will be clipped to the correct range. pattern YearMonth :: Year -> MonthOfYear -> Month-pattern YearMonth y my <- MkMonth ((\m -> divMod' m 12) -> (y,succ . fromInteger -> my)) where- YearMonth y my = MkMonth $ (y * 12) + toInteger (pred $ clip 1 12 my)+pattern YearMonth y my <-+ MkMonth ((\m -> divMod' m 12) -> (y, succ . fromInteger -> my))+ where+ YearMonth y my = MkMonth $ (y * 12) + toInteger (pred $ clip 1 12 my) fromYearMonthValid :: Year -> MonthOfYear -> Maybe Month fromYearMonthValid y my = do my' <- clipValid 1 12 my return $ YearMonth y my' -#if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE YearMonth #-}-#endif -toMonthDay :: Day -> (Month,DayOfMonth)+toMonthDay :: Day -> (Month, DayOfMonth) toMonthDay (YearMonthDay y my dm) = (YearMonth y my, dm) -- | Bidirectional abstract constructor. -- Invalid days of month will be clipped to the correct range. pattern MonthDay :: Month -> DayOfMonth -> Day-pattern MonthDay m dm <- (toMonthDay -> (m,dm)) where- MonthDay (YearMonth y my) dm = YearMonthDay y my dm+pattern MonthDay m dm <-+ (toMonthDay -> (m, dm))+ where+ MonthDay (YearMonth y my) dm = YearMonthDay y my dm fromMonthDayValid :: Month -> DayOfMonth -> Maybe Day fromMonthDayValid (YearMonth y my) dm = fromGregorianValid y my dm -#if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE MonthDay #-}-#endif
lib/Data/Time/Calendar/MonthDay.hs view
@@ -1,15 +1,29 @@ {-# LANGUAGE Safe #-} -module Data.Time.Calendar.MonthDay- ( MonthOfYear, DayOfMonth, DayOfYear- , monthAndDayToDayOfYear- , monthAndDayToDayOfYearValid- , dayOfYearToMonthAndDay- , monthLength- ) where+module Data.Time.Calendar.MonthDay (+ MonthOfYear,+ pattern January,+ pattern February,+ pattern March,+ pattern April,+ pattern May,+ pattern June,+ pattern July,+ pattern August,+ pattern September,+ pattern October,+ pattern November,+ pattern December,+ DayOfMonth,+ DayOfYear,+ monthAndDayToDayOfYear,+ monthAndDayToDayOfYearValid,+ dayOfYearToMonthAndDay,+ monthLength,+) where -import Data.Time.Calendar.Types import Data.Time.Calendar.Private+import Data.Time.Calendar.Types -- | Convert month and day in the Gregorian or Julian calendars to day of year. -- First arg is leap year flag.@@ -22,9 +36,10 @@ k = if month' <= 2 then 0- else if isLeap- then -1- else -2+ else+ if isLeap+ then -1+ else -2 -- | Convert month and day in the Gregorian or Julian calendars to day of year. -- First arg is leap year flag.@@ -32,15 +47,15 @@ monthAndDayToDayOfYearValid isLeap month day = do month' <- clipValid 1 12 month day' <- clipValid 1 (monthLength' isLeap month') day- let- day'' = fromIntegral day'+ let day'' = fromIntegral day' month'' = fromIntegral month' k = if month' <= 2 then 0- else if isLeap- then -1- else -2+ else+ if isLeap+ then -1+ else -2 return ((div (367 * month'' - 362) 12) + k + day'') -- | Convert day of year in the Gregorian or Julian calendars to month and day.@@ -49,15 +64,17 @@ dayOfYearToMonthAndDay isLeap yd = findMonthDay (monthLengths isLeap)- (clip- 1- (if isLeap- then 366- else 365)- yd)+ ( clip+ 1+ ( if isLeap+ then 366+ else 365+ )+ yd+ ) findMonthDay :: [Int] -> Int -> (Int, Int)-findMonthDay (n:ns) yd+findMonthDay (n : ns) yd | yd > n = (\(m, d) -> (m + 1, d)) (findMonthDay ns (yd - n)) findMonthDay _ yd = (1, yd) @@ -73,8 +90,8 @@ monthLengths isleap = [ 31 , if isleap- then 29- else 28+ then 29+ else 28 , 31 , 30 , 31@@ -86,4 +103,5 @@ , 30 , 31 ]- --J F M A M J J A S O N D++--J F M A M J J A S O N D
lib/Data/Time/Calendar/OrdinalDate.hs view
@@ -3,9 +3,9 @@ -- | ISO 8601 Ordinal Date format module Data.Time.Calendar.OrdinalDate (Day, Year, DayOfYear, WeekOfYear, module Data.Time.Calendar.OrdinalDate) where -import Data.Time.Calendar.Types import Data.Time.Calendar.Days import Data.Time.Calendar.Private+import Data.Time.Calendar.Types -- | Convert to ISO 8601 Ordinal Date format. toOrdinalDate :: Day -> (Year, DayOfYear)@@ -29,28 +29,31 @@ where y = year - 1 mjd =- (fromIntegral- (clip- 1- (if isLeapYear year- then 366- else 365)- day)) +- (365 * y) +- (div y 4) -- (div y 100) +- (div y 400) -- 678576+ ( fromIntegral+ ( clip+ 1+ ( if isLeapYear year+ then 366+ else 365+ )+ day+ )+ )+ + (365 * y)+ + (div y 4)+ - (div y 100)+ + (div y 400)+ - 678576 -- | Bidirectional abstract constructor for ISO 8601 Ordinal Date format. -- Invalid day numbers will be clipped to the correct range (1 to 365 or 366). pattern YearDay :: Year -> DayOfYear -> Day-pattern YearDay y d <- (toOrdinalDate -> (y,d)) where- YearDay y d = fromOrdinalDate y d+pattern YearDay y d <-+ (toOrdinalDate -> (y, d))+ where+ YearDay y d = fromOrdinalDate y d -#if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE YearDay #-}-#endif -- | Convert from ISO 8601 Ordinal Date format. -- Invalid day numbers return 'Nothing'@@ -59,12 +62,12 @@ day' <- clipValid 1- (if isLeapYear year- then 366- else 365)+ ( if isLeapYear year+ then 366+ else 365+ ) day- let- y = year - 1+ let y = year - 1 mjd = (fromIntegral day') + (365 * y) + (div y 4) - (div y 100) + (div y 400) - 678576 return (ModifiedJulianDay mjd) @@ -103,34 +106,39 @@ -- The first Monday is the first day of week 1, any earlier days in the year -- are week 0 (as @%W@ in 'Data.Time.Format.formatTime'). fromMondayStartWeek ::- Year -- ^ Year.- -> WeekOfYear -- ^ Monday-starting week number (as @%W@ in 'Data.Time.Format.formatTime').- -> Int -- ^ Day of week.- -- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime').- -> 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+ -- | Year.+ Year ->+ -- | Monday-starting week number (as @%W@ in 'Data.Time.Format.formatTime').+ WeekOfYear ->+ -- | Day of week.+ -- 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 fromMondayStartWeekValid ::- Year -- ^ Year.- -> WeekOfYear -- ^ Monday-starting week number (as @%W@ in 'Data.Time.Format.formatTime').- -> Int -- ^ Day of week.- -- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime').- -> Maybe Day+ -- | Year.+ Year ->+ -- | Monday-starting week number (as @%W@ in 'Data.Time.Format.formatTime').+ WeekOfYear ->+ -- | Day of week.+ -- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime').+ Int ->+ Maybe Day fromMondayStartWeekValid year w d = do d' <- clipValid 1 7 d- let- -- first day of the year+ let -- first day of the year firstDay = fromOrdinalDate year 1 -- 0-based week of year zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7@@ -143,9 +151,10 @@ zbYearDay' <- clipValid 0- (if isLeapYear year- then 365- else 364)+ ( if isLeapYear year+ then 365+ else 364+ ) zbYearDay return $ addDays zbYearDay' firstDay @@ -154,34 +163,39 @@ -- The first Sunday is the first day of week 1, any earlier days in the -- year are week 0 (as @%U@ in 'Data.Time.Format.formatTime'). fromSundayStartWeek ::- Year -- ^ Year.- -> WeekOfYear -- ^ Sunday-starting week number (as @%U@ in 'Data.Time.Format.formatTime').- -> Int -- ^ Day of week- -- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime').- -> 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+ -- | Year.+ Year ->+ -- | Sunday-starting week number (as @%U@ in 'Data.Time.Format.formatTime').+ WeekOfYear ->+ -- | Day of week+ -- 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 fromSundayStartWeekValid ::- Year -- ^ Year.- -> WeekOfYear -- ^ Sunday-starting week number (as @%U@ in 'Data.Time.Format.formatTime').- -> Int -- ^ Day of week.- -- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime').- -> Maybe Day+ -- | Year.+ Year ->+ -- | Sunday-starting week number (as @%U@ in 'Data.Time.Format.formatTime').+ WeekOfYear ->+ -- | Day of week.+ -- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime').+ Int ->+ Maybe Day fromSundayStartWeekValid year w d = do d' <- clipValid 0 6 d- let- -- first day of the year+ let -- first day of the year firstDay = fromOrdinalDate year 1 -- 0-based week of year zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7@@ -194,8 +208,9 @@ zbYearDay' <- clipValid 0- (if isLeapYear year- then 365- else 364)+ ( if isLeapYear year+ then 365+ else 364+ ) zbYearDay return $ addDays zbYearDay' firstDay
lib/Data/Time/Calendar/Private.hs view
@@ -5,8 +5,9 @@ import Data.Fixed data PadOption- = Pad Int- Char+ = Pad+ Int+ Char | NoPad showPadded :: PadOption -> String -> String@@ -73,6 +74,6 @@ 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)
lib/Data/Time/Calendar/Quarter.hs view
@@ -1,29 +1,27 @@ {-# LANGUAGE Safe #-}-#if __GLASGOW_HASKELL__ < 802-{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-incomplete-uni-patterns #-}-#endif -- | Year quarters.-module Data.Time.Calendar.Quarter- (- QuarterOfYear(..), addQuarters, diffQuarters,- Quarter(..),- pattern YearQuarter,- monthOfYearQuarter,- monthQuarter,- dayQuarter- ) where+module Data.Time.Calendar.Quarter (+ QuarterOfYear (..),+ addQuarters,+ diffQuarters,+ Quarter (..),+ pattern YearQuarter,+ monthOfYearQuarter,+ monthQuarter,+ dayQuarter,+) where -import Data.Time.Calendar.Types-import Data.Time.Calendar.Private-import Data.Time.Calendar.Days-import Data.Time.Calendar.Month+import Control.DeepSeq import Data.Data import Data.Fixed-import Text.Read-import Text.ParserCombinators.ReadP-import Control.DeepSeq import Data.Ix+import Data.Time.Calendar.Days+import Data.Time.Calendar.Month+import Data.Time.Calendar.Private+import Data.Time.Calendar.Types+import Text.ParserCombinators.ReadP+import Text.Read -- | Quarters of each year. Each quarter corresponds to three months. data QuarterOfYear = Q1 | Q2 | Q3 | Q4 deriving (Eq, Ord, Data, Typeable, Read, Show, Ix)@@ -95,12 +93,12 @@ -- | Bidirectional abstract constructor. pattern YearQuarter :: Year -> QuarterOfYear -> Quarter-pattern YearQuarter y qy <- MkQuarter ((\q -> divMod' q 4) -> (y,toEnum . succ . fromInteger -> qy)) where- YearQuarter y qy = MkQuarter $ (y * 4) + toInteger (pred $ fromEnum qy)+pattern YearQuarter y qy <-+ MkQuarter ((\q -> divMod' q 4) -> (y, toEnum . succ . fromInteger -> qy))+ where+ YearQuarter y qy = MkQuarter $ (y * 4) + toInteger (pred $ fromEnum qy) -#if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE YearQuarter #-}-#endif monthOfYearQuarter :: MonthOfYear -> QuarterOfYear monthOfYearQuarter my | my <= 3 = Q1
lib/Data/Time/Calendar/Types.hs view
@@ -2,12 +2,50 @@ module Data.Time.Calendar.Types where - -- | Year of Common Era. type Year = Integer -- | Month of year, in range 1 (January) to 12 (December). type MonthOfYear = Int++pattern January :: MonthOfYear+pattern January = 1++pattern February :: MonthOfYear+pattern February = 2++pattern March :: MonthOfYear+pattern March = 3++pattern April :: MonthOfYear+pattern April = 4++pattern May :: MonthOfYear+pattern May = 5++pattern June :: MonthOfYear+pattern June = 6++pattern July :: MonthOfYear+pattern July = 7++pattern August :: MonthOfYear+pattern August = 8++pattern September :: MonthOfYear+pattern September = 9++pattern October :: MonthOfYear+pattern October = 10++pattern November :: MonthOfYear+pattern November = 11++-- | The twelve 'MonthOfYear' patterns form a @COMPLETE@ set.+pattern December :: MonthOfYear+pattern December = 12++{-# COMPLETE January, February, March, April, May, June, July, August, September, October, November, December #-} -- | Day of month, in range 1 to 31. type DayOfMonth = Int
lib/Data/Time/Calendar/Week.hs view
@@ -1,18 +1,17 @@ {-# LANGUAGE Safe #-} -module Data.Time.Calendar.Week- (- -- * Week- DayOfWeek(..)- , dayOfWeek- , dayOfWeekDiff- , firstDayOfWeekOnAfter- ) where+module Data.Time.Calendar.Week (+ -- * Week+ DayOfWeek (..),+ dayOfWeek,+ dayOfWeekDiff,+ firstDayOfWeekOnAfter,+) where +import Control.DeepSeq+import Data.Data import Data.Fixed import Data.Ix-import Data.Data-import Control.DeepSeq import Data.Time.Calendar.Days data DayOfWeek@@ -62,7 +61,6 @@ dayOfWeek :: Day -> DayOfWeek dayOfWeek (ModifiedJulianDay d) = toEnum $ fromInteger $ d + 3- -- | @dayOfWeekDiff a b = a - b@ in range 0 to 6. -- The number of days from b to the next a.
lib/Data/Time/Calendar/WeekDate.hs view
@@ -1,93 +1,108 @@ {-# LANGUAGE Safe #-} -- | Week-based calendars-module Data.Time.Calendar.WeekDate- (- Year, WeekOfYear, DayOfWeek(..), dayOfWeek,- FirstWeekType (..),toWeekCalendar,fromWeekCalendar,fromWeekCalendarValid,- -- * ISO 8601 Week Date format- toWeekDate, fromWeekDate, pattern YearWeekDay,- fromWeekDateValid, showWeekDate- ) where+module Data.Time.Calendar.WeekDate (+ Year,+ WeekOfYear,+ DayOfWeek (..),+ dayOfWeek,+ FirstWeekType (..),+ toWeekCalendar,+ fromWeekCalendar,+ fromWeekCalendarValid, -import Data.Time.Calendar.Types+ -- * ISO 8601 Week Date format+ toWeekDate,+ fromWeekDate,+ pattern YearWeekDay,+ fromWeekDateValid,+ showWeekDate,+) where+ import Data.Time.Calendar.Days-import Data.Time.Calendar.Week import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.Private-+import Data.Time.Calendar.Week data FirstWeekType- = FirstWholeWeek- -- ^ first week is the first whole week of the year- | FirstMostWeek- -- ^ first week is the first week with four days in the year- deriving Eq+ = -- | first week is the first whole week of the year+ FirstWholeWeek+ | -- | first week is the first week with four days in the year+ FirstMostWeek+ deriving (Eq) 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. toWeekCalendar ::- FirstWeekType- -- ^ how to reckon the first week of the year- -> DayOfWeek- -- ^ the first day of each week- -> 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)+ -- | how to reckon the first week of the year+ FirstWeekType ->+ -- | the first day of each week+ 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) -- | Convert from the given kind of "week calendar". -- Invalid week and day values will be clipped to the correct range. fromWeekCalendar ::- FirstWeekType- -- ^ how to reckon the first week of the year- -> DayOfWeek- -- ^ the first day of each week- -> Year -> 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+ -- | how to reckon the first week of the year+ FirstWeekType ->+ -- | the first day of each week+ DayOfWeek ->+ Year ->+ 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 -- | Convert from the given kind of "week calendar". -- Invalid week and day values will return Nothing. fromWeekCalendarValid ::- FirstWeekType- -- ^ how to reckon the first week of the year- -> DayOfWeek- -- ^ the first day of each week- -> Year -> 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+ -- | how to reckon the first week of the year+ FirstWeekType ->+ -- | the first day of each week+ DayOfWeek ->+ Year ->+ 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 -- | 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.@@ -97,12 +112,12 @@ -- | Bidirectional abstract constructor for ISO 8601 Week Date format. -- Invalid week values will be clipped to the correct range. pattern YearWeekDay :: Year -> WeekOfYear -> DayOfWeek -> Day-pattern YearWeekDay y wy dw <- (toWeekDate -> (y,wy,toEnum -> dw)) where- YearWeekDay y wy dw = fromWeekDate y wy (fromEnum dw)+pattern YearWeekDay y wy dw <-+ (toWeekDate -> (y, wy, toEnum -> dw))+ where+ YearWeekDay y wy dw = fromWeekDate y wy (fromEnum dw) -#if __GLASGOW_HASKELL__ >= 802 {-# COMPLETE YearWeekDay #-}-#endif -- | 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 return Nothing.
lib/Data/Time/Clock.hs view
@@ -1,15 +1,15 @@ {-# LANGUAGE Safe #-} -- | Types and functions for UTC and UT1-module Data.Time.Clock- ( module Data.Time.Clock.Internal.UniversalTime- , module Data.Time.Clock.Internal.DiffTime- , module Data.Time.Clock.Internal.UTCTime- , module Data.Time.Clock.Internal.NominalDiffTime- , module Data.Time.Clock.Internal.UTCDiff- , getCurrentTime- , getTime_resolution- ) where+module Data.Time.Clock (+ module Data.Time.Clock.Internal.UniversalTime,+ module Data.Time.Clock.Internal.DiffTime,+ module Data.Time.Clock.Internal.UTCTime,+ module Data.Time.Clock.Internal.NominalDiffTime,+ module Data.Time.Clock.Internal.UTCDiff,+ getCurrentTime,+ getTime_resolution,+) where import Data.Time.Clock.Internal.DiffTime import Data.Time.Clock.Internal.NominalDiffTime
lib/Data/Time/Clock/Internal/AbsoluteTime.hs view
@@ -1,15 +1,14 @@ {-# LANGUAGE Safe #-} -- | TAI and leap-second maps for converting to UTC: most people won't need this module.-module Data.Time.Clock.Internal.AbsoluteTime- (+module Data.Time.Clock.Internal.AbsoluteTime ( -- TAI arithmetic- AbsoluteTime- , taiEpoch- , addAbsoluteTime- , diffAbsoluteTime- , taiNominalDayStart- ) where+ AbsoluteTime,+ taiEpoch,+ addAbsoluteTime,+ diffAbsoluteTime,+ taiNominalDayStart,+) where import Control.DeepSeq import Data.Data@@ -17,8 +16,8 @@ import Data.Time.Clock.Internal.DiffTime -- | AbsoluteTime is TAI, time as measured by a clock.-newtype AbsoluteTime =- MkAbsoluteTime DiffTime+newtype AbsoluteTime+ = MkAbsoluteTime DiffTime deriving (Eq, Ord, Data, Typeable) instance NFData AbsoluteTime where
lib/Data/Time/Clock/Internal/CTimespec.hsc view
@@ -31,7 +31,7 @@ clock_getres :: ClockID -> Ptr CTimespec -> IO CInt -- | Get the resolution of the given clock.-clockGetRes :: #{type clockid_t} -> IO (Either Errno CTimespec)+clockGetRes :: ClockID -> IO (Either Errno CTimespec) clockGetRes clockid = alloca $ \ptspec -> do rc <- clock_getres clockid ptspec case rc of@@ -52,8 +52,13 @@ clock_REALTIME :: ClockID clock_REALTIME = #{const CLOCK_REALTIME} -clock_TAI :: ClockID-clock_TAI = #{const 11}+clock_TAI :: Maybe ClockID+clock_TAI =+#if defined(CLOCK_TAI)+ Just #{const CLOCK_TAI}+#else+ Nothing+#endif realtimeRes :: CTimespec realtimeRes = unsafePerformIO $ do
lib/Data/Time/Clock/Internal/CTimeval.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} module Data.Time.Clock.Internal.CTimeval where+ #ifndef mingw32_HOST_OS -- All Unix-specific, this import Foreign
lib/Data/Time/Clock/Internal/DiffTime.hs view
@@ -1,28 +1,27 @@ {-# LANGUAGE Trustworthy #-} -module Data.Time.Clock.Internal.DiffTime- (+module Data.Time.Clock.Internal.DiffTime ( -- * Absolute intervals- DiffTime- , secondsToDiffTime- , picosecondsToDiffTime- , diffTimeToPicoseconds- ) where+ DiffTime,+ secondsToDiffTime,+ picosecondsToDiffTime,+ diffTimeToPicoseconds,+) where import Control.DeepSeq import Data.Data import Data.Fixed+import GHC.Read import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadPrec-import GHC.Read -- | This is a length of time, as measured by a clock. -- Conversion functions such as 'fromInteger' and 'realToFrac' will treat it as seconds. -- For example, @(0.010 :: DiffTime)@ corresponds to 10 milliseconds. -- -- It has a precision of one picosecond (= 10^-12 s). Enumeration functions will treat it as picoseconds.-newtype DiffTime =- MkDiffTime Pico+newtype DiffTime+ = MkDiffTime Pico deriving (Eq, Ord, Data, Typeable) instance NFData DiffTime where@@ -65,9 +64,9 @@ 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@@ -86,6 +85,6 @@ diffTimeToPicoseconds (MkDiffTime (MkFixed x)) = x {-# RULES-"realToFrac/DiffTime->Pico" realToFrac = \ (MkDiffTime ps) -> ps+"realToFrac/DiffTime->Pico" realToFrac = \(MkDiffTime ps) -> ps "realToFrac/Pico->DiffTime" realToFrac = MkDiffTime- #-}+ #-}
lib/Data/Time/Clock/Internal/NominalDiffTime.hs view
@@ -1,18 +1,18 @@ {-# LANGUAGE Trustworthy #-} -module Data.Time.Clock.Internal.NominalDiffTime- ( NominalDiffTime- , secondsToNominalDiffTime- , nominalDiffTimeToSeconds- , nominalDay- ) where+module Data.Time.Clock.Internal.NominalDiffTime (+ NominalDiffTime,+ secondsToNominalDiffTime,+ nominalDiffTimeToSeconds,+ nominalDay,+) where import Control.DeepSeq import Data.Data import Data.Fixed+import GHC.Read import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadPrec-import GHC.Read -- | This is a length of time, as measured by UTC. -- It has a precision of 10^-12 s.@@ -25,8 +25,8 @@ -- It ignores leap-seconds, so it's not necessarily a fixed amount of clock time. -- For instance, 23:00 UTC + 2 hours of NominalDiffTime = 01:00 UTC (+ 1 day), -- regardless of whether a leap-second intervened.-newtype NominalDiffTime =- MkNominalDiffTime Pico+newtype NominalDiffTime+ = MkNominalDiffTime Pico deriving (Eq, Ord, Data, Typeable) -- | Create a 'NominalDiffTime' from a number of seconds.@@ -91,14 +91,17 @@ floor (MkNominalDiffTime a) = floor a {-# RULES-"realToFrac/DiffTime->NominalDiffTime" realToFrac =- \ dt -> MkNominalDiffTime (realToFrac dt)-"realToFrac/NominalDiffTime->DiffTime" realToFrac =- \ (MkNominalDiffTime ps) -> realToFrac ps-"realToFrac/NominalDiffTime->Pico" realToFrac =- \ (MkNominalDiffTime ps) -> ps+"realToFrac/DiffTime->NominalDiffTime"+ realToFrac =+ \dt -> MkNominalDiffTime (realToFrac dt)+"realToFrac/NominalDiffTime->DiffTime"+ realToFrac =+ \(MkNominalDiffTime ps) -> realToFrac ps+"realToFrac/NominalDiffTime->Pico"+ realToFrac =+ \(MkNominalDiffTime ps) -> ps "realToFrac/Pico->NominalDiffTime" realToFrac = MkNominalDiffTime- #-}+ #-} -- | One day in 'NominalDiffTime'. nominalDay :: NominalDiffTime
lib/Data/Time/Clock/Internal/POSIXTime.hs view
@@ -11,5 +11,4 @@ -- | POSIX time is the nominal time since 1970-01-01 00:00 UTC -- -- To convert from a 'Foreign.C.Types.CTime' or @System.Posix.EpochTime@, use 'realToFrac'.--- type POSIXTime = NominalDiffTime
lib/Data/Time/Clock/Internal/SystemTime.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ #include "HsTimeConfig.h" #if defined(mingw32_HOST_OS) || !defined(HAVE_CLOCK_GETTIME)@@ -6,15 +8,15 @@ {-# LANGUAGE Trustworthy #-} #endif -module Data.Time.Clock.Internal.SystemTime- ( SystemTime(..)- , getSystemTime- , getTime_resolution- , getTAISystemTime- ) where+module Data.Time.Clock.Internal.SystemTime (+ SystemTime (..),+ getSystemTime,+ getTime_resolution,+ getTAISystemTime,+) where -import Data.Data import Control.DeepSeq+import Data.Data import Data.Int (Int64) import Data.Time.Clock.Internal.DiffTime import Data.Word@@ -34,9 +36,10 @@ -- Its semantics depends on the clock function, but the epoch is typically the beginning of 1970. -- Note that 'systemNanoseconds' of 1E9 to 2E9-1 can be used to represent leap seconds. data SystemTime = MkSystemTime- { systemSeconds :: {-# UNPACK #-}!Int64- , systemNanoseconds :: {-# UNPACK #-}!Word32- } deriving (Eq, Ord, Show, Data, Typeable)+ { systemSeconds :: {-# UNPACK #-} !Int64+ , systemNanoseconds :: {-# UNPACK #-} !Word32+ }+ deriving (Eq, Ord, Show, Data, Typeable) instance NFData SystemTime where rnf a = a `seq` ()@@ -44,12 +47,15 @@ -- | Get the system time, epoch start of 1970 UTC, leap-seconds ignored. -- 'getSystemTime' is typically much faster than 'getCurrentTime'. getSystemTime :: IO SystemTime+ -- | The resolution of 'getSystemTime', 'getCurrentTime', 'getPOSIXTime'. -- On UNIX systems this uses @clock_getres@, which may be <https://github.com/microsoft/WSL/issues/6029 wrong on WSL2>. getTime_resolution :: DiffTime+ -- | If supported, get TAI time, epoch start of 1970 TAI, with resolution. -- This is supported only on UNIX systems, and only those with CLOCK_TAI available at run-time. getTAISystemTime :: Maybe (DiffTime, IO SystemTime)+ #ifdef mingw32_HOST_OS -- On Windows, the equlvalent of POSIX time is "file time", defined as -- the number of 100-nanosecond intervals that have elapsed since@@ -81,8 +87,10 @@ getTime_resolution = timespecToDiffTime realtimeRes -getTAISystemTime =- fmap (\resolution -> (timespecToDiffTime resolution, clockGetSystemTime clock_TAI)) $ clockResolution clock_TAI+getTAISystemTime = do+ clockID <- clock_TAI+ resolution <- clockResolution clockID+ return $ (timespecToDiffTime resolution, clockGetSystemTime clockID) #else -- Use gettimeofday getSystemTime = do
lib/Data/Time/Clock/Internal/UTCTime.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE Safe #-} -module Data.Time.Clock.Internal.UTCTime- (+module Data.Time.Clock.Internal.UTCTime ( -- * UTC+ -- | UTC is time as measured by a clock, corrected to keep pace with the earth by adding or removing -- occasional seconds, known as \"leap seconds\". -- These corrections are not predictable and are announced with six month's notice.@@ -11,8 +11,8 @@ -- -- If you don't care about leap seconds, use 'UTCTime' and 'NominalDiffTime' for your clock calculations, -- and you'll be fine.- UTCTime(..)- ) where+ UTCTime (..),+) where import Control.DeepSeq import Data.Data@@ -23,9 +23,12 @@ -- It consists of the day number, and a time offset from midnight. -- Note that if a day has a leap second added to it, it will have 86401 seconds. data UTCTime = UTCTime- { utctDay :: Day -- ^ the day- , utctDayTime :: DiffTime -- ^ the time from midnight, 0 <= t < 86401s (because of leap-seconds)- } deriving (Data, Typeable)+ { -- | the day+ utctDay :: Day+ , -- | the time from midnight, 0 <= t < 86401s (because of leap-seconds)+ utctDayTime :: DiffTime+ }+ deriving (Data, Typeable) instance NFData UTCTime where rnf (UTCTime d t) = rnf d `seq` rnf t `seq` ()
lib/Data/Time/Clock/Internal/UniversalTime.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE Safe #-} -module Data.Time.Clock.Internal.UniversalTime- (+module Data.Time.Clock.Internal.UniversalTime ( -- * Universal Time+ -- | Time as measured by the Earth.- UniversalTime(..)- ) where+ UniversalTime (..),+) where import Control.DeepSeq import Data.Data@@ -14,7 +14,8 @@ -- It's used to represent UT1, which is time as measured by the earth's rotation, adjusted for various wobbles. newtype UniversalTime = ModJulianDate { getModJulianDate :: Rational- } deriving (Eq, Ord, Data, Typeable)+ }+ deriving (Eq, Ord, Data, Typeable) instance NFData UniversalTime where rnf (ModJulianDate a) = rnf a
lib/Data/Time/Clock/POSIX.hs view
@@ -17,15 +17,15 @@ -- > main = do -- > u <- getCurrentTime -- > print $ nanosSinceEpoch u-module Data.Time.Clock.POSIX- ( posixDayLength- , POSIXTime- , posixSecondsToUTCTime- , utcTimeToPOSIXSeconds- , getPOSIXTime- , getCurrentTime- , systemToPOSIXTime- ) where+module Data.Time.Clock.POSIX (+ posixDayLength,+ POSIXTime,+ posixSecondsToUTCTime,+ utcTimeToPOSIXSeconds,+ getPOSIXTime,+ getCurrentTime,+ systemToPOSIXTime,+) where import Data.Fixed import Data.Time.Calendar.Days@@ -34,9 +34,9 @@ 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) =
lib/Data/Time/Clock/System.hs view
@@ -1,15 +1,15 @@ {-# LANGUAGE Safe #-} -- | Fast access to the system clock.-module Data.Time.Clock.System- ( systemEpochDay- , SystemTime(..)- , truncateSystemTimeLeapSecond- , getSystemTime- , systemToUTCTime- , utcToSystemTime- , systemToTAITime- ) where+module Data.Time.Clock.System (+ systemEpochDay,+ SystemTime (..),+ truncateSystemTimeLeapSecond,+ getSystemTime,+ systemToUTCTime,+ utcToSystemTime,+ systemToTAITime,+) where import Data.Int (Int64) import Data.Time.Calendar.Days@@ -27,48 +27,48 @@ -- | 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
lib/Data/Time/Clock/TAI.hs view
@@ -1,19 +1,19 @@ {-# LANGUAGE Safe #-}+ {-# OPTIONS -fno-warn-orphans #-} -- | TAI and leap-second maps for converting to UTC: most people won't need this module.-module Data.Time.Clock.TAI- (+module Data.Time.Clock.TAI ( -- TAI arithmetic- module Data.Time.Clock.Internal.AbsoluteTime+ module Data.Time.Clock.Internal.AbsoluteTime, -- leap-second map type- , LeapSecondMap+ LeapSecondMap, -- conversion between UTC and TAI with map- , utcDayLength- , utcToTAITime- , taiToUTCTime- , taiClock- ) where+ utcDayLength,+ utcToTAITime,+ taiToUTCTime,+ taiClock,+) where import Data.Fixed import Data.Maybe@@ -49,17 +49,16 @@ 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)
lib/Data/Time/Format.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE Safe #-} -module Data.Time.Format- (+module Data.Time.Format ( -- * UNIX-style formatting- FormatTime()- , formatTime- , module Data.Time.Format.Parse- ) where+ FormatTime (),+ formatTime,+ module Data.Time.Format.Parse,+) where import Data.Time.Format.Format.Class import Data.Time.Format.Format.Instances ()
lib/Data/Time/Format/Format/Class.hs view
@@ -1,23 +1,22 @@ {-# LANGUAGE Safe #-} -module Data.Time.Format.Format.Class- (- -- * Formatting- formatTime- , FormatNumericPadding- , FormatOptions(..)- , FormatTime(..)- , ShowPadded- , PadOption- , formatGeneral- , formatString- , formatNumber- , formatNumberStd- , showPaddedFixed- , showPaddedFixedFraction- , quotBy- , remBy- ) where+module Data.Time.Format.Format.Class (+ -- * Formatting+ formatTime,+ FormatNumericPadding,+ FormatOptions (..),+ FormatTime (..),+ ShowPadded,+ PadOption,+ formatGeneral,+ formatString,+ formatNumber,+ formatNumberStd,+ showPaddedFixed,+ showPaddedFixedFraction,+ quotBy,+ remBy,+) where import Data.Char import Data.Fixed@@ -40,36 +39,36 @@ -- 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)+ Bool -> Bool -> Int -> Char -> (TimeLocale -> PadOption -> t -> String) -> (FormatOptions -> t -> String) formatGeneral trunc fdef idef cdef ff fo = ff (foLocale fo) $ getPadOption trunc fdef idef cdef (foPadding fo) (foWidth fo) @@ -85,25 +84,25 @@ 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'. --@@ -329,18 +328,18 @@ -- [@%0ES@] seconds of minute as two digits, with decimal point and \<width\> (default 12) decimal places. formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String formatTime _ [] _ = ""-formatTime locale ('%':cs) t =+formatTime locale ('%' : cs) t = case formatTime1 locale cs t of Just result -> result Nothing -> '%' : (formatTime locale cs t)-formatTime locale (c:cs) t = c : (formatTime locale cs t)+formatTime locale (c : cs) t = c : (formatTime locale cs t) 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-formatTime1 locale ('^':cs) t = formatTime2 locale (fmap toUpper) Nothing cs t-formatTime1 locale ('#':cs) t = formatTime2 locale (fmap toLower) Nothing cs t+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+formatTime1 locale ('^' : cs) t = formatTime2 locale (fmap toUpper) Nothing cs t+formatTime1 locale ('#' : cs) t = formatTime2 locale (fmap toLower) Nothing cs t formatTime1 locale cs t = formatTime2 locale id Nothing cs t getDigit :: Char -> Maybe Int@@ -352,31 +351,31 @@ pullNumber :: Maybe Int -> String -> (Maybe Int, String) pullNumber mx [] = (mx, [])-pullNumber mx s@(c:cs) =+pullNumber mx s@(c : cs) = case getDigit c of Just i -> pullNumber (Just $ (fromMaybe 0 mx) * 10 + i) 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)- => TimeLocale- -> (String -> String)- -> Maybe FormatNumericPadding- -> Maybe Int- -> String- -> t- -> Maybe String-formatTime3 locale recase mpad mwidth ('E':cs) = formatTime4 True recase (MkFormatOptions locale mpad mwidth) cs+ (FormatTime t) =>+ TimeLocale ->+ (String -> String) ->+ Maybe FormatNumericPadding ->+ Maybe Int ->+ String ->+ t ->+ Maybe String+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 alt recase fo (c:cs) t = Just $ (recase (formatChar alt c fo t)) ++ (formatTime (foLocale fo) cs t)+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
lib/Data/Time/Format/Format/Instances.hs view
@@ -1,11 +1,8 @@ {-# LANGUAGE Safe #-}+ {-# OPTIONS -fno-warn-orphans #-}-#if __GLASGOW_HASKELL__ < 802-{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-incomplete-uni-patterns #-}-#endif -module Data.Time.Format.Format.Instances- (+module Data.Time.Format.Format.Instances ( ) where import Control.Applicative ((<|>))@@ -14,8 +11,8 @@ import Data.Time.Calendar.CalendarDiffDays import Data.Time.Calendar.Days import Data.Time.Calendar.Gregorian-import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.Month+import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.Private import Data.Time.Calendar.Week import Data.Time.Calendar.WeekDate@@ -38,15 +35,15 @@ instance FormatTime LocalTime where formatCharacter _ 'c' = Just $ \fo -> formatTime (foLocale fo) $ dateTimeFmt $ foLocale fo formatCharacter alt c =- mapFormatCharacter localDay (formatCharacter alt c) <|>- mapFormatCharacter localTimeOfDay (formatCharacter alt c)+ mapFormatCharacter localDay (formatCharacter alt c)+ <|> 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@@ -83,22 +80,22 @@ formatCharacter _ 's' = Just $ formatNumber True 1 '0' $ (floor . utcTimeToPOSIXSeconds . zonedTimeToUTC :: ZonedTime -> Integer) formatCharacter alt c =- mapFormatCharacter zonedTimeToLocalTime (formatCharacter alt c) <|>- mapFormatCharacter zonedTimeZone (formatCharacter alt c)+ mapFormatCharacter zonedTimeToLocalTime (formatCharacter alt c)+ <|> mapFormatCharacter zonedTimeZone (formatCharacter alt c) 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@@ -169,12 +166,12 @@ 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@@ -191,12 +188,12 @@ 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
lib/Data/Time/Format/ISO8601.hs view
@@ -1,55 +1,59 @@ {-# LANGUAGE Safe #-} -module Data.Time.Format.ISO8601- (- -- * Format- Format- , formatShowM- , formatShow- , formatReadP- , formatParseM- -- * Common formats- , ISO8601(..)- , iso8601Show- , iso8601ParseM- -- * All formats- , FormatExtension(..)- , formatReadPExtension- , parseFormatExtension- , calendarFormat- , yearMonthFormat- , yearFormat- , centuryFormat- , expandedCalendarFormat- , expandedYearMonthFormat- , expandedYearFormat- , expandedCenturyFormat- , ordinalDateFormat- , expandedOrdinalDateFormat- , weekDateFormat- , yearWeekFormat- , expandedWeekDateFormat- , expandedYearWeekFormat- , timeOfDayFormat- , hourMinuteFormat- , hourFormat- , withTimeDesignator- , withUTCDesignator- , timeOffsetFormat- , timeOfDayAndOffsetFormat- , localTimeFormat- , zonedTimeFormat- , utcTimeFormat- , dayAndTimeFormat- , timeAndOffsetFormat- , durationDaysFormat- , durationTimeFormat- , alternativeDurationDaysFormat- , alternativeDurationTimeFormat- , intervalFormat- , recurringIntervalFormat- ) where+module Data.Time.Format.ISO8601 (+ -- * Format+ Format,+ formatShowM,+ formatShow,+ formatReadP,+ formatParseM, + -- * Common formats+ ISO8601 (..),+ iso8601Show,+ iso8601ParseM,++ -- * All formats+ FormatExtension (..),+ formatReadPExtension,+ parseFormatExtension,+ calendarFormat,+ yearMonthFormat,+ yearFormat,+ centuryFormat,+ expandedCalendarFormat,+ expandedYearMonthFormat,+ expandedYearFormat,+ expandedCenturyFormat,+ ordinalDateFormat,+ expandedOrdinalDateFormat,+ weekDateFormat,+ yearWeekFormat,+ expandedWeekDateFormat,+ expandedYearWeekFormat,+ timeOfDayFormat,+ hourMinuteFormat,+ hourFormat,+ withTimeDesignator,+ withUTCDesignator,+ timeOffsetFormat,+ timeOfDayAndOffsetFormat,+ localTimeFormat,+ zonedTimeFormat,+ utcTimeFormat,+ dayAndTimeFormat,+ timeAndOffsetFormat,+ durationDaysFormat,+ durationTimeFormat,+ alternativeDurationDaysFormat,+ alternativeDurationTimeFormat,+ intervalFormat,+ recurringIntervalFormat,++ -- * Other+ isoMakeTimeOfDayValid,+) where+ import Control.Monad.Fail import Data.Fixed import Data.Format@@ -58,15 +62,14 @@ import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.Private import Data.Time.Calendar.WeekDate-import Prelude hiding (fail) import Text.ParserCombinators.ReadP+import Prelude hiding (fail) data FormatExtension- = - -- | ISO 8601:2004(E) sec. 2.3.4. Use hyphens and colons.+ = -- | ISO 8601:2004(E) sec. 2.3.4. Use hyphens and colons. ExtendedFormat- -- | ISO 8601:2004(E) sec. 2.3.3. Omit hyphens and colons. "The basic format should be avoided in plain text."- | BasicFormat+ | -- | ISO 8601:2004(E) sec. 2.3.3. Omit hyphens and colons. "The basic format should be avoided in plain text."+ BasicFormat -- | Read a value in either extended or basic format formatReadPExtension :: (FormatExtension -> Format t) -> ReadP t@@ -150,8 +153,15 @@ mapWeekDate = mapMFormat (\(y, (w, d)) -> fromWeekDateValid y w d) (\day -> (\(y, w, d) -> Just (y, (w, d))) $ toWeekDate day) +-- | Like `makeTimeOfDayValid`, but accepts @24 0 0@ per ISO 8601:2004(E) sec. 4.2.3+--+-- @since 1.12+isoMakeTimeOfDayValid :: Int -> Int -> Pico -> Maybe TimeOfDay+isoMakeTimeOfDayValid 24 0 0 = return (TimeOfDay 24 0 0)+isoMakeTimeOfDayValid h m s = makeTimeOfDayValid h m s+ mapTimeOfDay :: Format (Int, (Int, Pico)) -> Format TimeOfDay-mapTimeOfDay = mapMFormat (\(h, (m, s)) -> makeTimeOfDayValid h m s) (\(TimeOfDay h m s) -> Just (h, (m, s)))+mapTimeOfDay = mapMFormat (\(h, (m, s)) -> isoMakeTimeOfDayValid h m s) (\(TimeOfDay h m s) -> Just (h, (m, s))) -- | ISO 8601:2004(E) sec. 4.1.2.2 calendarFormat :: FormatExtension -> Format Day@@ -221,25 +231,27 @@ -- | 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- _ -> 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- _ -> 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@@ -251,14 +263,14 @@ -- | ISO 8601:2004(E) sec. 4.2.5.1 timeOffsetFormat :: FormatExtension -> Format TimeZone-timeOffsetFormat fe = let- toTimeZone (sign, (h, m)) = minutesToTimeZone $ sign * (h * 60 + m)- fromTimeZone tz = let- mm = timeZoneMinutes tz- hm = quotRem (abs mm) 60- in (signum mm, hm)- in isoMap toTimeZone fromTimeZone $- mandatorySignFormat <**> extColonFormat fe (integerFormat NoSign (Just 2)) (integerFormat NoSign (Just 2))+timeOffsetFormat fe =+ let toTimeZone (sign, (h, m)) = minutesToTimeZone $ sign * (h * 60 + m)+ fromTimeZone tz =+ let mm = timeZoneMinutes tz+ hm = quotRem (abs mm) 60+ in (signum mm, hm)+ in isoMap toTimeZone fromTimeZone $+ mandatorySignFormat <**> extColonFormat fe (integerFormat NoSign (Just 2)) (integerFormat NoSign (Just 2)) -- | ISO 8601:2004(E) sec. 4.2.5.2 timeOfDayAndOffsetFormat :: FormatExtension -> Format (TimeOfDay, TimeZone)@@ -273,7 +285,7 @@ zonedTimeFormat :: Format Day -> Format TimeOfDay -> FormatExtension -> Format ZonedTime zonedTimeFormat fday ftod fe = isoMap (\(lt, tz) -> ZonedTime lt tz) (\(ZonedTime lt tz) -> (lt, tz)) $- timeAndOffsetFormat (localTimeFormat fday ftod) fe+ timeAndOffsetFormat (localTimeFormat fday ftod) fe -- | ISO 8601:2004(E) sec. 4.3.2 utcTimeFormat :: Format Day -> Format TimeOfDay -> Format UTCTime@@ -295,10 +307,10 @@ decDesignator c = optionalFormat 0 $ decimalFormat NoSign 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@@ -306,44 +318,44 @@ -- | 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)@@ -353,7 +365,7 @@ 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.
lib/Data/Time/Format/Internal.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE Safe #-} -{-|-The contents of this module is liable to change, or disappear entirely.-Please <https://github.com/haskell/time/issues/new let me know> if you depend on anything here.--}-module Data.Time.Format.Internal- ( FormatTime(..)- , ParseTime(..)- ) where+-- |+--The contents of this module is liable to change, or disappear entirely.+--Please <https://github.com/haskell/time/issues/new let me know> if you depend on anything here.+module Data.Time.Format.Internal (+ Format (..),+ FormatTime (..),+ ParseTime (..),+) where +import Data.Format import Data.Time.Format.Format.Class import Data.Time.Format.Parse.Class
lib/Data/Time/Format/Locale.hs view
@@ -1,27 +1,28 @@ {-# LANGUAGE Safe #-} -- Note: this file derives from old-locale:System.Locale.hs, which is copyright (c) The University of Glasgow 2001-module Data.Time.Format.Locale- ( TimeLocale(..)- , defaultTimeLocale- , iso8601DateFormat- , rfc822DateFormat- ) where+module Data.Time.Format.Locale (+ TimeLocale (..),+ defaultTimeLocale,+ iso8601DateFormat,+ rfc822DateFormat,+) where import Data.Time.LocalTime.Internal.TimeZone data TimeLocale = TimeLocale- { wDays :: [(String, String)]- -- ^ full and abbreviated week days, starting with Sunday- , months :: [(String, String)]- -- ^ full and abbreviated months- , amPm :: (String, String)- -- ^ AM\/PM symbols- , dateTimeFmt, dateFmt, timeFmt, time12Fmt :: String- -- ^ formatting strings- , knownTimeZones :: [TimeZone]- -- ^ time zones known by name- } deriving (Eq, Ord, Show)+ { -- | full and abbreviated week days, starting with Sunday+ wDays :: [(String, String)]+ , -- | full and abbreviated months+ months :: [(String, String)]+ , -- | AM\/PM symbols+ amPm :: (String, String)+ , -- | formatting strings+ dateTimeFmt, dateFmt, timeFmt, time12Fmt :: String+ , -- | time zones known by name+ knownTimeZones :: [TimeZone]+ }+ deriving (Eq, Ord, Show) -- | Locale representing American usage. --@@ -32,50 +33,48 @@ defaultTimeLocale = TimeLocale { wDays =- [ ("Sunday", "Sun")- , ("Monday", "Mon")- , ("Tuesday", "Tue")- , ("Wednesday", "Wed")- , ("Thursday", "Thu")- , ("Friday", "Fri")- , ("Saturday", "Sat")- ]+ [ ("Sunday", "Sun")+ , ("Monday", "Mon")+ , ("Tuesday", "Tue")+ , ("Wednesday", "Wed")+ , ("Thursday", "Thu")+ , ("Friday", "Fri")+ , ("Saturday", "Sat")+ ] , months =- [ ("January", "Jan")- , ("February", "Feb")- , ("March", "Mar")- , ("April", "Apr")- , ("May", "May")- , ("June", "Jun")- , ("July", "Jul")- , ("August", "Aug")- , ("September", "Sep")- , ("October", "Oct")- , ("November", "Nov")- , ("December", "Dec")- ]+ [ ("January", "Jan")+ , ("February", "Feb")+ , ("March", "Mar")+ , ("April", "Apr")+ , ("May", "May")+ , ("June", "Jun")+ , ("July", "Jul")+ , ("August", "Aug")+ , ("September", "Sep")+ , ("October", "Oct")+ , ("November", "Nov")+ , ("December", "Dec")+ ] , amPm = ("AM", "PM") , dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y" , dateFmt = "%m/%d/%y" , timeFmt = "%H:%M:%S" , time12Fmt = "%I:%M:%S %p" , knownTimeZones =- [ TimeZone 0 False "UT"- , TimeZone 0 False "GMT"- , TimeZone (-5 * 60) False "EST"- , TimeZone (-4 * 60) True "EDT"- , TimeZone (-6 * 60) False "CST"- , TimeZone (-5 * 60) True "CDT"- , TimeZone (-7 * 60) False "MST"- , TimeZone (-6 * 60) True "MDT"- , TimeZone (-8 * 60) False "PST"- , TimeZone (-7 * 60) True "PDT"- ]+ [ TimeZone 0 False "UT"+ , TimeZone 0 False "GMT"+ , TimeZone (-5 * 60) False "EST"+ , TimeZone (-4 * 60) True "EDT"+ , TimeZone (-6 * 60) False "CST"+ , TimeZone (-5 * 60) True "CDT"+ , TimeZone (-7 * 60) False "MST"+ , TimeZone (-6 * 60) True "MDT"+ , TimeZone (-8 * 60) False "PST"+ , TimeZone (-7 * 60) True "PDT"+ ] } -{-# DEPRECATED-iso8601DateFormat "use \"Data.Time.Format.ISO8601\" functions instead"- #-}+{-# DEPRECATED iso8601DateFormat "use \"Data.Time.Format.ISO8601\" functions instead" #-} {- | Construct format string according to <http://en.wikipedia.org/wiki/ISO_8601 ISO-8601>. @@ -88,10 +87,10 @@ -} iso8601DateFormat :: Maybe String -> String iso8601DateFormat mTimeFmt =- "%Y-%m-%d" ++- case mTimeFmt of- Nothing -> ""- Just fmt -> 'T' : fmt+ "%Y-%m-%d"+ ++ case mTimeFmt of+ Nothing -> ""+ Just fmt -> 'T' : fmt -- | Format string according to <http://tools.ietf.org/html/rfc822#section-5 RFC822>. rfc822DateFormat :: String
lib/Data/Time/Format/Parse.hs view
@@ -1,24 +1,24 @@ {-# LANGUAGE Safe #-}+ {-# OPTIONS -fno-warn-orphans #-} -module Data.Time.Format.Parse- (+module Data.Time.Format.Parse ( -- * UNIX-style parsing- parseTimeM- , parseTimeMultipleM- , parseTimeOrError- , readSTime- , readPTime- , ParseTime()+ parseTimeM,+ parseTimeMultipleM,+ parseTimeOrError,+ readSTime,+ readPTime,+ ParseTime (),+ -- * Locale- , module Data.Time.Format.Locale- ) where+ module Data.Time.Format.Locale,+) where import Control.Applicative ((<|>)) import Control.Monad.Fail import Data.Char import Data.Proxy-import Data.Traversable import Data.Time.Calendar.Days import Data.Time.Clock.Internal.UTCTime import Data.Time.Clock.Internal.UniversalTime@@ -29,8 +29,9 @@ import Data.Time.LocalTime.Internal.TimeOfDay import Data.Time.LocalTime.Internal.TimeZone import Data.Time.LocalTime.Internal.ZonedTime-import Prelude hiding (fail)+import Data.Traversable import Text.ParserCombinators.ReadP hiding (char, string)+import Prelude hiding (fail) -- | Parses a time value given a format string. -- Missing information will be derived from 1970-01-01 00:00 UTC (which was a Thursday).@@ -56,27 +57,35 @@ -- -- > Prelude Data.Time> parseTimeM True defaultTimeLocale "%Y-%-m-%-d" "2010-3-04" :: Maybe Day -- > Just 2010-03-04--- parseTimeM ::- (MonadFail m, ParseTime t)- => Bool -- ^ Accept leading and trailing whitespace?- -> TimeLocale -- ^ Time locale.- -> String -- ^ Format string.- -> String -- ^ Input string.- -> m t -- ^ Return the time value, or fail if the input could not be parsed using the given format.+ (MonadFail m, ParseTime t) =>+ -- | Accept leading and trailing whitespace?+ Bool ->+ -- | Time locale.+ TimeLocale ->+ -- | Format string.+ String ->+ -- | Input string.+ String ->+ -- | Return the time value, or fail if the input could not be parsed using the given format.+ m t parseTimeM acceptWS l fmt s = parseTimeMultipleM acceptWS l [(fmt, s)] -- | Parses a time value given a list of pairs of format and input. -- Resulting value is constructed from all provided specifiers. parseTimeMultipleM' ::- (MonadFail m, ParseTime t)- => Proxy t- -> Bool -- ^ Accept leading and trailing whitespace?- -> TimeLocale -- ^ Time locale.- -> [(String, String)] -- ^ Pairs of (format string, input string).- -> m t -- ^ Return the time value, or fail if the input could not be parsed using the given format.+ (MonadFail m, ParseTime t) =>+ Proxy t ->+ -- | Accept leading and trailing whitespace?+ Bool ->+ -- | Time locale.+ TimeLocale ->+ -- | Pairs of (format string, input string).+ [(String, String)] ->+ -- | Return the time value, or fail if the input could not be parsed using the given format.+ m t parseTimeMultipleM' pt acceptWS l fmts = do- specss <- for fmts $ \(fmt,s) -> parseTimeSpecifiersM pt acceptWS l fmt s+ specss <- for fmts $ \(fmt, s) -> parseTimeSpecifiersM pt acceptWS l fmt s case buildTime l $ mconcat specss of Just t -> return t Nothing -> fail "parseTimeM: cannot construct"@@ -84,22 +93,31 @@ -- | Parses a time value given a list of pairs of format and input. -- Resulting value is constructed from all provided specifiers. parseTimeMultipleM ::- (MonadFail m, ParseTime t)- => Bool -- ^ Accept leading and trailing whitespace?- -> TimeLocale -- ^ Time locale.- -> [(String, String)] -- ^ Pairs of (format string, input string).- -> m t -- ^ Return the time value, or fail if the input could not be parsed using the given format.+ (MonadFail m, ParseTime t) =>+ -- | Accept leading and trailing whitespace?+ Bool ->+ -- | Time locale.+ TimeLocale ->+ -- | Pairs of (format string, input string).+ [(String, String)] ->+ -- | Return the time value, or fail if the input could not be parsed using the given format.+ m t parseTimeMultipleM = parseTimeMultipleM' Proxy -- | Parse a time value given a format string. Fails if the input could -- not be parsed using the given format. See 'parseTimeM' for details. parseTimeOrError ::- ParseTime t- => Bool -- ^ Accept leading and trailing whitespace?- -> TimeLocale -- ^ Time locale.- -> String -- ^ Format string.- -> String -- ^ Input string.- -> t -- ^ The time value.+ ParseTime t =>+ -- | Accept leading and trailing whitespace?+ Bool ->+ -- | Time locale.+ TimeLocale ->+ -- | Format string.+ String ->+ -- | Input string.+ String ->+ -- | The time value.+ t parseTimeOrError acceptWS l fmt s = case parseTimeM acceptWS l fmt s of [t] -> t@@ -107,13 +125,17 @@ _ -> error $ "parseTimeOrError: multiple parses of " ++ show s parseTimeSpecifiersM ::- (MonadFail m, ParseTime t)- => Proxy t- -> Bool -- ^ Accept leading and trailing whitespace?- -> TimeLocale -- ^ Time locale.- -> String -- ^ Format string- -> String -- ^ Input string.- -> m [(Char, String)]+ (MonadFail m, ParseTime t) =>+ Proxy t ->+ -- | Accept leading and trailing whitespace?+ Bool ->+ -- | Time locale.+ TimeLocale ->+ -- | Format string+ String ->+ -- | Input string.+ String ->+ m [(Char, String)] parseTimeSpecifiersM pt acceptWS l fmt s = case parseTimeSpecifiers pt acceptWS l fmt s of [t] -> return t@@ -121,43 +143,56 @@ _ -> fail $ "parseTimeM: multiple parses of " ++ show s parseTimeSpecifiers ::- ParseTime t- => Proxy t- -> Bool -- ^ Accept leading and trailing whitespace?- -> TimeLocale -- ^ Time locale.- -> String -- ^ Format string- -> String -- ^ Input string.- -> [[(Char, String)]]+ ParseTime t =>+ Proxy t ->+ -- | Accept leading and trailing whitespace?+ Bool ->+ -- | Time locale.+ TimeLocale ->+ -- | Format string+ String ->+ -- | Input string.+ String ->+ [[(Char, String)]] parseTimeSpecifiers pt False l fmt s = [t | (t, "") <- readP_to_S (readPSpecifiers pt False l fmt) s] parseTimeSpecifiers pt True l fmt s = [t | (t, r) <- readP_to_S (readPSpecifiers pt True l fmt) s, all isSpace r] -- | Parse a time value given a format string. See 'parseTimeM' for details. readSTime ::- ParseTime t- => Bool -- ^ Accept leading whitespace?- -> TimeLocale -- ^ Time locale.- -> String -- ^ Format string- -> ReadS t+ ParseTime t =>+ -- | Accept leading whitespace?+ Bool ->+ -- | Time locale.+ TimeLocale ->+ -- | Format string+ String ->+ ReadS t readSTime acceptWS l f = readP_to_S $ readPTime acceptWS l f readPSpecifiers ::- ParseTime t- => Proxy t- -> Bool -- ^ Accept leading whitespace?- -> TimeLocale -- ^ Time locale.- -> String -- ^ Format string- -> ReadP [(Char, String)]+ ParseTime t =>+ Proxy t ->+ -- | Accept leading whitespace?+ Bool ->+ -- | Time locale.+ TimeLocale ->+ -- | Format string+ String ->+ ReadP [(Char, String)] readPSpecifiers pt False l f = parseSpecifiers pt l f readPSpecifiers pt True l f = (skipSpaces >> parseSpecifiers pt l f) <++ parseSpecifiers pt l f -- | Parse a time value given a format string. See 'parseTimeM' for details. readPTime' ::- ParseTime t- => Proxy t- -> Bool -- ^ Accept leading whitespace?- -> TimeLocale -- ^ Time locale.- -> String -- ^ Format string- -> ReadP t+ ParseTime t =>+ Proxy t ->+ -- | Accept leading whitespace?+ Bool ->+ -- | Time locale.+ TimeLocale ->+ -- | Format string+ String ->+ ReadP t readPTime' pt ws l f = do pairs <- readPSpecifiers pt ws l f case buildTime l pairs of@@ -166,14 +201,18 @@ -- | Parse a time value given a format string. See 'parseTimeM' for details. readPTime ::- ParseTime t- => Bool -- ^ Accept leading whitespace?- -> TimeLocale -- ^ Time locale.- -> String -- ^ Format string- -> ReadP t+ ParseTime t =>+ -- | Accept leading whitespace?+ Bool ->+ -- | Time locale.+ TimeLocale ->+ -- | Format string+ String ->+ ReadP t readPTime = readPTime' Proxy -- * Read instances for time package types+ instance Read Day where readsPrec _ = readParen False $ readSTime True defaultTimeLocale "%Y-%m-%d"
lib/Data/Time/Format/Parse/Class.hs view
@@ -1,15 +1,14 @@ {-# LANGUAGE Safe #-} -module Data.Time.Format.Parse.Class- (- -- * Parsing- ParseNumericPadding(..)- , ParseTime(..)- , parseSpecifiers- , timeSubstituteTimeSpecifier- , timeParseTimeSpecifier- , durationParseTimeSpecifier- ) where+module Data.Time.Format.Parse.Class (+ -- * Parsing+ ParseNumericPadding (..),+ ParseTime (..),+ parseSpecifiers,+ timeSubstituteTimeSpecifier,+ timeParseTimeSpecifier,+ durationParseTimeSpecifier,+) where import Data.Char import Data.Maybe@@ -28,10 +27,12 @@ -- | @since 1.9.1 substituteTimeSpecifier :: Proxy t -> TimeLocale -> Char -> Maybe String substituteTimeSpecifier _ _ _ = Nothing+ -- | Get the string corresponding to the given format specifier. -- -- @since 1.9.1 parseTimeSpecifier :: Proxy t -> TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String+ -- | Builds a time value from a parsed input string. -- If the input does not include all the information needed to -- construct a complete value, any missing parts should be taken@@ -40,10 +41,12 @@ -- -- @since 1.9.1 buildTime ::- TimeLocale -- ^ The time locale.- -> [(Char, String)] -- ^ Pairs of format characters and the- -- corresponding part of the input.- -> Maybe t+ -- | The time locale.+ TimeLocale ->+ -- | Pairs of format characters and the+ -- corresponding part of the input.+ [(Char, String)] ->+ Maybe t -- | Case-insensitive version of 'Text.ParserCombinators.ReadP.char'. charCI :: Char -> ReadP Char@@ -52,9 +55,8 @@ -- | Case-insensitive version of 'Text.ParserCombinators.ReadP.string'. stringCI :: String -> ReadP String stringCI this = do- let- scan [] _ = return this- scan (x:xs) (y:ys)+ let scan [] _ = return this+ scan (x : xs) (y : ys) | toUpper x == toUpper y = do _ <- get scan xs ys@@ -63,41 +65,41 @@ 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+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- 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+ 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,74 +138,76 @@ 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)- in case c of- -- century- 'C' -> (char '-' >> fmap ('-' :) (digits SpacePadding 2)) <++ digits SpacePadding 2- 'f' -> digits SpacePadding 2- -- year- 'Y' -> (char '-' >> fmap ('-' :) (digits SpacePadding 4)) <++ digits SpacePadding 4- 'G' -> 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@@ -218,19 +222,19 @@ 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
lib/Data/Time/Format/Parse/Instances.hs view
@@ -1,25 +1,20 @@ {-# LANGUAGE Safe #-}+ {-# OPTIONS -fno-warn-orphans #-} -module Data.Time.Format.Parse.Instances- (+module Data.Time.Format.Parse.Instances ( ) where -#if MIN_VERSION_base(4,13,0) import Control.Applicative ((<|>))-#else-import Control.Applicative ((<$>), (<*>), (<|>))-#endif import Data.Char import Data.Fixed-import Data.List (elemIndex,find)+import Data.List (elemIndex, find) import Data.Ratio-import Data.Time.Calendar.Types import Data.Time.Calendar.CalendarDiffDays import Data.Time.Calendar.Days import Data.Time.Calendar.Gregorian-import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.Month+import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.Private (clipValid) import Data.Time.Calendar.WeekDate import Data.Time.Clock.Internal.DiffTime@@ -44,8 +39,9 @@ | DCMonthDay DayOfMonth -- 1-31 | DCYearDay DayOfYear -- 1-366 | DCWeekDay Int -- 1-7 (mon-sun)- | DCYearWeek WeekType- WeekOfYear -- 1-53 or 0-53+ | DCYearWeek+ WeekType+ WeekOfYear -- 1-53 or 0-53 data WeekType = ISOWeek@@ -53,121 +49,118 @@ | 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+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 century (all but the last two digits of the year), 00 - 99 'f' -> do a <- ra return [DCCentury a]- -- %Y: year+ -- %Y: year 'Y' -> do a <- ra return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)]- -- %G: year for Week Date format+ -- %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: 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: 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: 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: 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: 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: 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: 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: 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: 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: 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: 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: day of week, short form (snd from wDays locale), Sun - Sat 'a' -> do a' <- zeroBasedListIndex $ fmap snd $ wDays l- let- a =+ 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: day of week, long form (fst from wDays locale), Sunday - Saturday 'A' -> do a' <- zeroBasedListIndex $ fmap fst $ wDays l- let- a =+ let a = if a' == 0 then 7 else a' return [DCWeekDay a]- -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday)+ -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday) 'w' -> do raw <- ra a' <- clipValid 0 6 raw- let- a =+ let a = if a' == 0 then 7 else a' return [DCWeekDay a]- -- %j: day of year for Ordinal Date format, 001 - 366+ -- %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+ -- unrecognised, pass on to other parsers _ -> return [] -makeDayComponents :: TimeLocale -> [(Char,String)] -> Maybe [DayComponent]-makeDayComponents l pairs = do+makeDayComponents :: TimeLocale -> [(Char, String)] -> Maybe [DayComponent]+makeDayComponents l pairs = do components <- for pairs $ \(c, x) -> makeDayComponent l c x return $ concat components @@ -181,27 +174,27 @@ cs <- makeDayComponents l pairs -- '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- 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 (_:xs) = rest xs+ 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+ 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 (_ : xs) = rest xs rest [] = rest [DCYearMonth 1] rest cs @@ -212,87 +205,90 @@ cs <- makeDayComponents l pairs -- '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:_) = fromYearMonthValid y m- rest (_:xs) = rest xs+ 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 : _) = 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 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- 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)+ 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+ 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@@ -322,11 +318,11 @@ 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)@@ -334,50 +330,49 @@ 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 +409,19 @@ 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+ 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
lib/Data/Time/LocalTime.hs view
@@ -1,22 +1,21 @@ {-# LANGUAGE Safe #-} -module Data.Time.LocalTime- (+module Data.Time.LocalTime ( -- * Time zones- TimeZone(..)- , timeZoneOffsetString- , timeZoneOffsetString'- , minutesToTimeZone- , hoursToTimeZone- , utc+ TimeZone (..),+ timeZoneOffsetString,+ timeZoneOffsetString',+ minutesToTimeZone,+ hoursToTimeZone,+ utc, -- getting the locale time zone- , getTimeZone- , getCurrentTimeZone- , module Data.Time.LocalTime.Internal.TimeOfDay- , module Data.Time.LocalTime.Internal.CalendarDiffTime- , module Data.Time.LocalTime.Internal.LocalTime- , module Data.Time.LocalTime.Internal.ZonedTime- ) where+ getTimeZone,+ getCurrentTimeZone,+ module Data.Time.LocalTime.Internal.TimeOfDay,+ module Data.Time.LocalTime.Internal.CalendarDiffTime,+ module Data.Time.LocalTime.Internal.LocalTime,+ module Data.Time.LocalTime.Internal.ZonedTime,+) where import Data.Time.Format () import Data.Time.LocalTime.Internal.CalendarDiffTime
lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs view
@@ -1,33 +1,27 @@ {-# LANGUAGE Safe #-} -module Data.Time.LocalTime.Internal.CalendarDiffTime- (- -- * Calendar Duration- module Data.Time.LocalTime.Internal.CalendarDiffTime- ) where-#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup hiding (option)-#endif-import Data.Fixed-import Data.Typeable-import Data.Data+module Data.Time.LocalTime.Internal.CalendarDiffTime (+ -- * Calendar Duration+ module Data.Time.LocalTime.Internal.CalendarDiffTime,+) where+ import Control.DeepSeq+import Data.Data+import Data.Fixed import Data.Time.Calendar.CalendarDiffDays import Data.Time.Clock.Internal.NominalDiffTime data CalendarDiffTime = CalendarDiffTime { ctMonths :: Integer , ctTime :: NominalDiffTime- } deriving (Eq,- Data-#if __GLASGOW_HASKELL__ >= 802- -- ^ @since 1.9.2-#endif- ,Typeable-#if __GLASGOW_HASKELL__ >= 802- -- ^ @since 1.9.2-#endif- )+ }+ deriving+ ( Eq+ , -- | @since 1.9.2+ Data+ , -- | @since 1.9.2+ Typeable+ ) instance NFData CalendarDiffTime where rnf (CalendarDiffTime m t) = rnf m `seq` rnf t `seq` ()
lib/Data/Time/LocalTime/Internal/LocalTime.hs view
@@ -1,18 +1,18 @@ {-# LANGUAGE Safe #-}+ {-# OPTIONS -fno-warn-orphans #-} -module Data.Time.LocalTime.Internal.LocalTime- (+module Data.Time.LocalTime.Internal.LocalTime ( -- * Local Time- LocalTime(..)- , addLocalTime- , diffLocalTime+ LocalTime (..),+ addLocalTime,+ diffLocalTime, -- converting UTC and UT1 times to LocalTime- , utcToLocalTime- , localTimeToUTC- , ut1ToLocalTime- , localTimeToUT1- ) where+ utcToLocalTime,+ localTimeToUTC,+ ut1ToLocalTime,+ localTimeToUT1,+) where import Control.DeepSeq import Data.Data@@ -32,7 +32,8 @@ data LocalTime = LocalTime { localDay :: Day , localTimeOfDay :: TimeOfDay- } deriving (Eq, Ord, Data, Typeable)+ }+ deriving (Eq, Ord, Data, Typeable) instance NFData LocalTime where rnf (LocalTime d t) = rnf d `seq` rnf t `seq` ()
lib/Data/Time/LocalTime/Internal/TimeOfDay.hs view
@@ -1,23 +1,22 @@ {-# LANGUAGE Safe #-} -module Data.Time.LocalTime.Internal.TimeOfDay- (+module Data.Time.LocalTime.Internal.TimeOfDay ( -- * Time of day- TimeOfDay(..)- , midnight- , midday- , makeTimeOfDayValid- , timeToDaysAndTimeOfDay- , daysAndTimeOfDayToTime- , utcToLocalTimeOfDay- , localToUTCTimeOfDay- , timeToTimeOfDay- , pastMidnight- , timeOfDayToTime- , sinceMidnight- , dayFractionToTimeOfDay- , timeOfDayToDayFraction- ) where+ TimeOfDay (..),+ midnight,+ midday,+ makeTimeOfDayValid,+ timeToDaysAndTimeOfDay,+ daysAndTimeOfDayToTime,+ utcToLocalTimeOfDay,+ localToUTCTimeOfDay,+ timeToTimeOfDay,+ pastMidnight,+ timeOfDayToTime,+ sinceMidnight,+ dayFractionToTimeOfDay,+ timeOfDayToDayFraction,+) where import Control.DeepSeq import Data.Data@@ -28,15 +27,19 @@ import Data.Time.LocalTime.Internal.TimeZone -- | Time of day as represented in hour, minute and second (with picoseconds), typically used to express local time of day.+--+-- @TimeOfDay 24 0 0@ is considered invalid for the purposes of 'makeTimeOfDayValid', as well as reading and parsing,+-- but valid for ISO 8601 parsing in "Data.Time.Format.ISO8601". data TimeOfDay = TimeOfDay- { todHour :: Int- -- ^ range 0 - 23- , todMin :: Int- -- ^ range 0 - 59- , todSec :: Pico- -- ^ Note that 0 <= 'todSec' < 61, accomodating leap seconds.- -- Any local minute may have a leap second, since leap seconds happen in all zones simultaneously- } deriving (Eq, Ord, Data, Typeable)+ { -- | range 0 - 23+ todHour :: Int+ , -- | range 0 - 59+ todMin :: Int+ , -- | Note that 0 <= 'todSec' < 61, accomodating leap seconds.+ -- Any local minute may have a leap second, since leap seconds happen in all zones simultaneously+ todSec :: Pico+ }+ deriving (Eq, Ord, Data, Typeable) instance NFData TimeOfDay where rnf (TimeOfDay h m s) = rnf h `seq` rnf m `seq` rnf s `seq` ()@@ -62,12 +65,12 @@ -- | 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
lib/Data/Time/LocalTime/Internal/TimeZone.hs view
@@ -1,20 +1,19 @@-{-# LANGUAGE Safe #-} {-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE Safe #-} -module Data.Time.LocalTime.Internal.TimeZone- (+module Data.Time.LocalTime.Internal.TimeZone ( -- * Time zones- TimeZone(..)- , timeZoneOffsetString- , timeZoneOffsetString'- , timeZoneOffsetString''- , minutesToTimeZone- , hoursToTimeZone- , utc+ TimeZone (..),+ timeZoneOffsetString,+ timeZoneOffsetString',+ timeZoneOffsetString'',+ minutesToTimeZone,+ hoursToTimeZone,+ utc, -- getting the locale time zone- , getTimeZone- , getCurrentTimeZone- ) where+ getTimeZone,+ getCurrentTimeZone,+) where import Control.DeepSeq import Data.Data@@ -27,13 +26,14 @@ -- | A TimeZone is a whole number of minutes offset from UTC, together with a name and a \"just for summer\" flag. data TimeZone = TimeZone- { timeZoneMinutes :: Int- -- ^ The number of minutes offset from UTC. Positive means local time will be later in the day than UTC.- , timeZoneSummerOnly :: Bool- -- ^ Is this time zone just persisting for the summer?- , timeZoneName :: String- -- ^ The name of the zone, typically a three- or four-letter acronym.- } deriving (Eq, Ord, Data, Typeable)+ { -- | The number of minutes offset from UTC. Positive means local time will be later in the day than UTC.+ timeZoneMinutes :: Int+ , -- | Is this time zone just persisting for the summer?+ timeZoneSummerOnly :: Bool+ , -- | The name of the zone, typically a three- or four-letter acronym.+ timeZoneName :: String+ }+ deriving (Eq, Ord, Data, Typeable) instance NFData TimeZone where rnf (TimeZone m so n) = rnf m `seq` rnf so `seq` rnf n `seq` ()@@ -48,12 +48,12 @@ 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 _ _)@@ -79,34 +79,37 @@ utc = TimeZone 0 False "UTC" {-# CFILES cbits/HsTime.c #-}-foreign import ccall unsafe "HsTime.h get_current_timezone_seconds" get_current_timezone_seconds- :: CTime -> Ptr CInt -> Ptr CString -> IO CLong+foreign import ccall unsafe "HsTime.h get_current_timezone_seconds"+ get_current_timezone_seconds ::+ CTime -> Ptr CInt -> Ptr CString -> IO CLong getTimeZoneCTime :: CTime -> IO TimeZone getTimeZoneCTime ctime = with 0- (\pdst ->- with- nullPtr- (\pcname -> do- secs <- get_current_timezone_seconds ctime pdst pcname- case secs of- 0x80000000 -> fail "localtime_r failed"- _ -> do- dst <- peek pdst- cname <- peek pcname- name <- peekCString cname- return (TimeZone (div (fromIntegral secs) 60) (dst == 1) name)))+ ( \pdst ->+ with+ nullPtr+ ( \pcname -> do+ secs <- get_current_timezone_seconds ctime pdst pcname+ case secs of+ 0x80000000 -> fail "localtime_r failed"+ _ -> do+ dst <- peek pdst+ cname <- peek pcname+ name <- peekCString cname+ return (TimeZone (div (fromIntegral secs) 60) (dst == 1) name)+ )+ ) +-- 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- -- there's no instance Bounded CTime, so this is the easiest way to check for overflow- 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 local time-zone for a given time (varying as per summertime adjustments). getTimeZoneSystem :: SystemTime -> IO TimeZone
lib/Data/Time/LocalTime/Internal/ZonedTime.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE Safe #-}+ {-# OPTIONS -fno-warn-orphans #-} -module Data.Time.LocalTime.Internal.ZonedTime- ( ZonedTime(..)- , utcToZonedTime- , zonedTimeToUTC- , getZonedTime- , utcToLocalZonedTime- ) where+module Data.Time.LocalTime.Internal.ZonedTime (+ ZonedTime (..),+ utcToZonedTime,+ zonedTimeToUTC,+ getZonedTime,+ utcToLocalZonedTime,+) where import Control.DeepSeq import Data.Data@@ -24,7 +25,8 @@ data ZonedTime = ZonedTime { zonedTimeToLocalTime :: LocalTime , zonedTimeZone :: TimeZone- } deriving (Data, Typeable)+ }+ deriving (Data, Typeable) instance NFData ZonedTime where rnf (ZonedTime lt z) = rnf lt `seq` rnf z `seq` ()
− lib/include/HsTimeConfig.h
@@ -1,122 +0,0 @@-/* lib/include/HsTimeConfig.h. Generated from HsTimeConfig.h.in by configure. */-/* lib/include/HsTimeConfig.h.in. Generated from configure.ac by autoheader. */--/* Define to 1 if you have the `clock_gettime' function. */-#define HAVE_CLOCK_GETTIME 1--/* Define to 1 if you have the declaration of `altzone', and to 0 if you- don't. */-#define HAVE_DECL_ALTZONE 0--/* Define to 1 if you have the declaration of `tzname', and to 0 if you don't.- */-/* #undef HAVE_DECL_TZNAME */--/* Define to 1 if you have the `gmtime_r' function. */-#define HAVE_GMTIME_R 1--/* Define to 1 if you have the <inttypes.h> header file. */-#define HAVE_INTTYPES_H 1--/* Define to 1 if you have the `localtime_r' function. */-#define HAVE_LOCALTIME_R 1--/* Define to 1 if you have the <memory.h> header file. */-#define HAVE_MEMORY_H 1--/* Define to 1 if you have the <stdint.h> header file. */-#define HAVE_STDINT_H 1--/* Define to 1 if you have the <stdlib.h> header file. */-#define HAVE_STDLIB_H 1--/* Define to 1 if you have the <strings.h> header file. */-#define HAVE_STRINGS_H 1--/* Define to 1 if you have the <string.h> header file. */-#define HAVE_STRING_H 1--/* Define to 1 if `tm_zone' is a member of `struct tm'. */-#define HAVE_STRUCT_TM_TM_ZONE 1--/* Define to 1 if you have the <sys/stat.h> header file. */-#define HAVE_SYS_STAT_H 1--/* Define to 1 if you have the <sys/time.h> header file. */-#define HAVE_SYS_TIME_H 1--/* Define to 1 if you have the <sys/types.h> header file. */-#define HAVE_SYS_TYPES_H 1--/* Define to 1 if you have the <time.h> header file. */-#define HAVE_TIME_H 1--/* Define to 1 if your `struct tm' has `tm_zone'. Deprecated, use- `HAVE_STRUCT_TM_TM_ZONE' instead. */-#define HAVE_TM_ZONE 1--/* Define to 1 if you don't have `tm_zone' but do have the external array- `tzname'. */-/* #undef HAVE_TZNAME */--/* Define to 1 if you have the <unistd.h> header file. */-#define HAVE_UNISTD_H 1--/* Define to the address where bug reports for this package should be sent. */-#define PACKAGE_BUGREPORT "ashley@semantic.org"--/* Define to the full name of this package. */-#define PACKAGE_NAME "Haskell time package"--/* Define to the full name and version of this package. */-#define PACKAGE_STRING "Haskell time package 1.11.1.2"--/* Define to the one symbol short name of this package. */-#define PACKAGE_TARNAME "time"--/* Define to the home page for this package. */-#define PACKAGE_URL ""--/* Define to the version of this package. */-#define PACKAGE_VERSION "1.11.1.2"--/* Define to 1 if you have the ANSI C header files. */-#define STDC_HEADERS 1--/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */-#define TIME_WITH_SYS_TIME 1--/* Define to 1 if your <sys/time.h> declares `struct tm'. */-/* #undef TM_IN_SYS_TIME */--/* Enable extensions on AIX 3, Interix. */-#ifndef _ALL_SOURCE-# define _ALL_SOURCE 1-#endif-/* Enable GNU extensions on systems that have them. */-#ifndef _GNU_SOURCE-# define _GNU_SOURCE 1-#endif-/* Enable threading extensions on Solaris. */-#ifndef _POSIX_PTHREAD_SEMANTICS-# define _POSIX_PTHREAD_SEMANTICS 1-#endif-/* Enable extensions on HP NonStop. */-#ifndef _TANDEM_SOURCE-# define _TANDEM_SOURCE 1-#endif-/* Enable general extensions on Solaris. */-#ifndef __EXTENSIONS__-# define __EXTENSIONS__ 1-#endif---/* Define to 1 if on MINIX. */-/* #undef _MINIX */--/* Define to 2 if the system does not provide POSIX.1 features except with- this defined. */-/* #undef _POSIX_1_SOURCE */--/* Define to 1 if you need to in order for `stat' and other things to work. */-/* #undef _POSIX_SOURCE */
test/ShowDefaultTZAbbreviations.hs view
@@ -4,10 +4,11 @@ showTZ :: TimeZone -> String showTZ tz =- (formatTime defaultTimeLocale "%Z %z" tz) ++- (if timeZoneSummerOnly tz- then " DST"- else "")+ (formatTime defaultTimeLocale "%Z %z" tz)+ ++ ( if timeZoneSummerOnly tz+ then " DST"+ else ""+ ) main :: IO () main = mapM_ (\tz -> putStrLn (showTZ tz)) (knownTimeZones defaultTimeLocale)
test/main/Main.hs view
@@ -1,6 +1,5 @@ module Main where -import Test.Types() import Test.Calendar.AddDays import Test.Calendar.CalendarProps import Test.Calendar.Calendars@@ -10,6 +9,7 @@ import Test.Calendar.Easter import Test.Calendar.LongWeekYears import Test.Calendar.MonthDay+import Test.Calendar.MonthOfYear import Test.Calendar.Valid import Test.Calendar.Week import Test.Clock.Conversion@@ -23,25 +23,27 @@ import Test.LocalTime.Time import Test.LocalTime.TimeOfDay import Test.Tasty+import Test.Types () tests :: TestTree tests = testGroup "Time" [ testGroup- "Calendar"- [ addDaysTest- , testCalendarProps- , testCalendars- , clipDates- , convertBack- , longWeekYears- , testMonthDay- , testEaster- , testValid- , testWeek- , testDuration- ]+ "Calendar"+ [ addDaysTest+ , testCalendarProps+ , testCalendars+ , clipDates+ , convertBack+ , longWeekYears+ , testMonthDay+ , testMonthOfYear+ , testEaster+ , testValid+ , testWeek+ , testDuration+ ] , testGroup "Clock" [testClockConversion, testResolutions, testTAI] , testGroup "Format" [testFormat, testParseTime, testISO8601] , testGroup "LocalTime" [testTime, testTimeOfDay, testCalendarDiffTime]
test/main/Test/Arbitrary.hs view
@@ -6,10 +6,11 @@ import Data.Fixed import Data.Ratio import Data.Time-import Data.Time.Calendar.WeekDate import Data.Time.Calendar.Month import Data.Time.Calendar.Quarter+import Data.Time.Calendar.WeekDate import Data.Time.Clock.POSIX+import System.Random import Test.Tasty.QuickCheck hiding (reason) instance Arbitrary DayOfWeek where@@ -31,25 +32,28 @@ instance Arbitrary QuarterOfYear where arbitrary = liftM toEnum $ choose (1, 4) +deriving instance Random Day+ instance Arbitrary Day where- arbitrary = liftM ModifiedJulianDay $ choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31- 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+ arbitrary = choose (fromGregorian (-9900) 1 1, fromGregorian 9999 12 31)+ 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@@ -90,28 +94,29 @@ 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)
test/main/Test/Calendar/AddDays.hs view
@@ -1,6 +1,6 @@-module Test.Calendar.AddDays- ( addDaysTest- ) where+module Test.Calendar.AddDays (+ addDaysTest,+) where import Data.Time.Calendar import Test.Calendar.AddDaysRef@@ -36,8 +36,14 @@ increment <- increments day <- days return- ((showGregorian day) ++- " + " ++ (show increment) ++ " * " ++ aname ++ " = " ++ showGregorian (adder increment day))+ ( (showGregorian day)+ ++ " + "+ ++ (show increment)+ ++ " * "+ ++ aname+ ++ " = "+ ++ showGregorian (adder increment day)+ ) addDaysTest :: TestTree addDaysTest = testCase "addDays" $ assertEqual "" addDaysRef $ unlines resultDays
test/main/Test/Calendar/CalendarProps.hs view
@@ -1,15 +1,12 @@-#if __GLASGOW_HASKELL__ < 802-{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-incomplete-uni-patterns #-}-#endif-module Test.Calendar.CalendarProps- ( testCalendarProps- ) where+module Test.Calendar.CalendarProps (+ testCalendarProps,+) where import Data.Time.Calendar.Month import Data.Time.Calendar.Quarter-import Test.TestUtil-import Test.Tasty import Test.Arbitrary ()+import Test.Tasty+import Test.TestUtil testYearMonth :: TestTree testYearMonth = nameTest "YearMonth" $ \m -> case m of@@ -24,4 +21,4 @@ YearQuarter y qy -> q == YearQuarter y qy testCalendarProps :: TestTree-testCalendarProps = nameTest "calender-props" [testYearMonth,testMonthDay,testYearQuarter]+testCalendarProps = nameTest "calender-props" [testYearMonth, testMonthDay, testYearQuarter]
test/main/Test/Calendar/Calendars.hs view
@@ -1,6 +1,6 @@-module Test.Calendar.Calendars- ( testCalendars- ) where+module Test.Calendar.Calendars (+ testCalendars,+) where import Data.Time.Calendar import Data.Time.Calendar.Julian
test/main/Test/Calendar/ClipDates.hs view
@@ -1,6 +1,6 @@-module Test.Calendar.ClipDates- ( clipDates- ) where+module Test.Calendar.ClipDates (+ clipDates,+) where import Data.Time.Calendar import Data.Time.Calendar.OrdinalDate@@ -20,24 +20,26 @@ -- tupleUp2 :: [a] -> [b] -> [(a, b)]-tupleUp2 l1 l2 = concatMap (\e -> map (e, ) l2) l1+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+testPairs name expected found = testGroup name $ fmap (\(e, f) -> testCase e $ assertEqual "" e f) $ zip expected found -- clipDates :: TestTree clipDates =- testGroup "clipDates"- [- testPairs "YearAndDay" clipDatesYearAndDayRef $ map yearAndDay $ tupleUp2 [1968, 1969, 1971] [-4, 0, 1, 200, 364, 365, 366, 367, 700],- testPairs "Gregorian" clipDatesGregorianDayRef $ map gregorian $- tupleUp3 [1968, 1969, 1971] [-20, -1, 0, 1, 2, 12, 13, 17] [-7, -1, 0, 1, 2, 27, 28, 29, 30, 31, 32, 40],- testPairs "ISOWeekDay" clipDatesISOWeekDayRef $ map iSOWeekDay $+ testGroup+ "clipDates"+ [ testPairs "YearAndDay" clipDatesYearAndDayRef $ map yearAndDay $ tupleUp2 [1968, 1969, 1971] [-4, 0, 1, 200, 364, 365, 366, 367, 700]+ , testPairs "Gregorian" clipDatesGregorianDayRef $+ map gregorian $+ tupleUp3 [1968, 1969, 1971] [-20, -1, 0, 1, 2, 12, 13, 17] [-7, -1, 0, 1, 2, 27, 28, 29, 30, 31, 32, 40]+ , testPairs "ISOWeekDay" clipDatesISOWeekDayRef $+ map iSOWeekDay $ tupleUp3 [1968, 1969, 2004] [-20, -1, 0, 1, 20, 51, 52, 53, 54] [-2, -1, 0, 1, 4, 6, 7, 8, 9] ]
test/main/Test/Calendar/ClipDatesRef.hs view
@@ -2,570 +2,570 @@ clipDatesYearAndDayRef :: [String] clipDatesYearAndDayRef =- [ "1968--4 = 1968-001"- , "1968-0 = 1968-001"- , "1968-1 = 1968-001"- , "1968-200 = 1968-200"- , "1968-364 = 1968-364"- , "1968-365 = 1968-365"- , "1968-366 = 1968-366"- , "1968-367 = 1968-366"- , "1968-700 = 1968-366"- , "1969--4 = 1969-001"- , "1969-0 = 1969-001"- , "1969-1 = 1969-001"- , "1969-200 = 1969-200"- , "1969-364 = 1969-364"- , "1969-365 = 1969-365"- , "1969-366 = 1969-365"- , "1969-367 = 1969-365"- , "1969-700 = 1969-365"- , "1971--4 = 1971-001"- , "1971-0 = 1971-001"- , "1971-1 = 1971-001"- , "1971-200 = 1971-200"- , "1971-364 = 1971-364"- , "1971-365 = 1971-365"- , "1971-366 = 1971-365"- , "1971-367 = 1971-365"- , "1971-700 = 1971-365"- ]--clipDatesGregorianDayRef :: [String]-clipDatesGregorianDayRef =- [ "1968--20--7 = 1968-01-01"- , "1968--20--1 = 1968-01-01"- , "1968--20-0 = 1968-01-01"- , "1968--20-1 = 1968-01-01"- , "1968--20-2 = 1968-01-02"- , "1968--20-27 = 1968-01-27"- , "1968--20-28 = 1968-01-28"- , "1968--20-29 = 1968-01-29"- , "1968--20-30 = 1968-01-30"- , "1968--20-31 = 1968-01-31"- , "1968--20-32 = 1968-01-31"- , "1968--20-40 = 1968-01-31"- , "1968--1--7 = 1968-01-01"- , "1968--1--1 = 1968-01-01"- , "1968--1-0 = 1968-01-01"- , "1968--1-1 = 1968-01-01"- , "1968--1-2 = 1968-01-02"- , "1968--1-27 = 1968-01-27"- , "1968--1-28 = 1968-01-28"- , "1968--1-29 = 1968-01-29"- , "1968--1-30 = 1968-01-30"- , "1968--1-31 = 1968-01-31"- , "1968--1-32 = 1968-01-31"- , "1968--1-40 = 1968-01-31"- , "1968-0--7 = 1968-01-01"- , "1968-0--1 = 1968-01-01"- , "1968-0-0 = 1968-01-01"- , "1968-0-1 = 1968-01-01"- , "1968-0-2 = 1968-01-02"- , "1968-0-27 = 1968-01-27"- , "1968-0-28 = 1968-01-28"- , "1968-0-29 = 1968-01-29"- , "1968-0-30 = 1968-01-30"- , "1968-0-31 = 1968-01-31"- , "1968-0-32 = 1968-01-31"- , "1968-0-40 = 1968-01-31"- , "1968-1--7 = 1968-01-01"- , "1968-1--1 = 1968-01-01"- , "1968-1-0 = 1968-01-01"- , "1968-1-1 = 1968-01-01"- , "1968-1-2 = 1968-01-02"- , "1968-1-27 = 1968-01-27"- , "1968-1-28 = 1968-01-28"- , "1968-1-29 = 1968-01-29"- , "1968-1-30 = 1968-01-30"- , "1968-1-31 = 1968-01-31"- , "1968-1-32 = 1968-01-31"- , "1968-1-40 = 1968-01-31"- , "1968-2--7 = 1968-02-01"- , "1968-2--1 = 1968-02-01"- , "1968-2-0 = 1968-02-01"- , "1968-2-1 = 1968-02-01"- , "1968-2-2 = 1968-02-02"- , "1968-2-27 = 1968-02-27"- , "1968-2-28 = 1968-02-28"- , "1968-2-29 = 1968-02-29"- , "1968-2-30 = 1968-02-29"- , "1968-2-31 = 1968-02-29"- , "1968-2-32 = 1968-02-29"- , "1968-2-40 = 1968-02-29"- , "1968-12--7 = 1968-12-01"- , "1968-12--1 = 1968-12-01"- , "1968-12-0 = 1968-12-01"- , "1968-12-1 = 1968-12-01"- , "1968-12-2 = 1968-12-02"- , "1968-12-27 = 1968-12-27"- , "1968-12-28 = 1968-12-28"- , "1968-12-29 = 1968-12-29"- , "1968-12-30 = 1968-12-30"- , "1968-12-31 = 1968-12-31"- , "1968-12-32 = 1968-12-31"- , "1968-12-40 = 1968-12-31"- , "1968-13--7 = 1968-12-01"- , "1968-13--1 = 1968-12-01"- , "1968-13-0 = 1968-12-01"- , "1968-13-1 = 1968-12-01"- , "1968-13-2 = 1968-12-02"- , "1968-13-27 = 1968-12-27"- , "1968-13-28 = 1968-12-28"- , "1968-13-29 = 1968-12-29"- , "1968-13-30 = 1968-12-30"- , "1968-13-31 = 1968-12-31"- , "1968-13-32 = 1968-12-31"- , "1968-13-40 = 1968-12-31"- , "1968-17--7 = 1968-12-01"- , "1968-17--1 = 1968-12-01"- , "1968-17-0 = 1968-12-01"- , "1968-17-1 = 1968-12-01"- , "1968-17-2 = 1968-12-02"- , "1968-17-27 = 1968-12-27"- , "1968-17-28 = 1968-12-28"- , "1968-17-29 = 1968-12-29"- , "1968-17-30 = 1968-12-30"- , "1968-17-31 = 1968-12-31"- , "1968-17-32 = 1968-12-31"- , "1968-17-40 = 1968-12-31"- , "1969--20--7 = 1969-01-01"- , "1969--20--1 = 1969-01-01"- , "1969--20-0 = 1969-01-01"- , "1969--20-1 = 1969-01-01"- , "1969--20-2 = 1969-01-02"- , "1969--20-27 = 1969-01-27"- , "1969--20-28 = 1969-01-28"- , "1969--20-29 = 1969-01-29"- , "1969--20-30 = 1969-01-30"- , "1969--20-31 = 1969-01-31"- , "1969--20-32 = 1969-01-31"- , "1969--20-40 = 1969-01-31"- , "1969--1--7 = 1969-01-01"- , "1969--1--1 = 1969-01-01"- , "1969--1-0 = 1969-01-01"- , "1969--1-1 = 1969-01-01"- , "1969--1-2 = 1969-01-02"- , "1969--1-27 = 1969-01-27"- , "1969--1-28 = 1969-01-28"- , "1969--1-29 = 1969-01-29"- , "1969--1-30 = 1969-01-30"- , "1969--1-31 = 1969-01-31"- , "1969--1-32 = 1969-01-31"- , "1969--1-40 = 1969-01-31"- , "1969-0--7 = 1969-01-01"- , "1969-0--1 = 1969-01-01"- , "1969-0-0 = 1969-01-01"- , "1969-0-1 = 1969-01-01"- , "1969-0-2 = 1969-01-02"- , "1969-0-27 = 1969-01-27"- , "1969-0-28 = 1969-01-28"- , "1969-0-29 = 1969-01-29"- , "1969-0-30 = 1969-01-30"- , "1969-0-31 = 1969-01-31"- , "1969-0-32 = 1969-01-31"- , "1969-0-40 = 1969-01-31"- , "1969-1--7 = 1969-01-01"- , "1969-1--1 = 1969-01-01"- , "1969-1-0 = 1969-01-01"- , "1969-1-1 = 1969-01-01"- , "1969-1-2 = 1969-01-02"- , "1969-1-27 = 1969-01-27"- , "1969-1-28 = 1969-01-28"- , "1969-1-29 = 1969-01-29"- , "1969-1-30 = 1969-01-30"- , "1969-1-31 = 1969-01-31"- , "1969-1-32 = 1969-01-31"- , "1969-1-40 = 1969-01-31"- , "1969-2--7 = 1969-02-01"- , "1969-2--1 = 1969-02-01"- , "1969-2-0 = 1969-02-01"- , "1969-2-1 = 1969-02-01"- , "1969-2-2 = 1969-02-02"- , "1969-2-27 = 1969-02-27"- , "1969-2-28 = 1969-02-28"- , "1969-2-29 = 1969-02-28"- , "1969-2-30 = 1969-02-28"- , "1969-2-31 = 1969-02-28"- , "1969-2-32 = 1969-02-28"- , "1969-2-40 = 1969-02-28"- , "1969-12--7 = 1969-12-01"- , "1969-12--1 = 1969-12-01"- , "1969-12-0 = 1969-12-01"- , "1969-12-1 = 1969-12-01"- , "1969-12-2 = 1969-12-02"- , "1969-12-27 = 1969-12-27"- , "1969-12-28 = 1969-12-28"- , "1969-12-29 = 1969-12-29"- , "1969-12-30 = 1969-12-30"- , "1969-12-31 = 1969-12-31"- , "1969-12-32 = 1969-12-31"- , "1969-12-40 = 1969-12-31"- , "1969-13--7 = 1969-12-01"- , "1969-13--1 = 1969-12-01"- , "1969-13-0 = 1969-12-01"- , "1969-13-1 = 1969-12-01"- , "1969-13-2 = 1969-12-02"- , "1969-13-27 = 1969-12-27"- , "1969-13-28 = 1969-12-28"- , "1969-13-29 = 1969-12-29"- , "1969-13-30 = 1969-12-30"- , "1969-13-31 = 1969-12-31"- , "1969-13-32 = 1969-12-31"- , "1969-13-40 = 1969-12-31"- , "1969-17--7 = 1969-12-01"- , "1969-17--1 = 1969-12-01"- , "1969-17-0 = 1969-12-01"- , "1969-17-1 = 1969-12-01"- , "1969-17-2 = 1969-12-02"- , "1969-17-27 = 1969-12-27"- , "1969-17-28 = 1969-12-28"- , "1969-17-29 = 1969-12-29"- , "1969-17-30 = 1969-12-30"- , "1969-17-31 = 1969-12-31"- , "1969-17-32 = 1969-12-31"- , "1969-17-40 = 1969-12-31"- , "1971--20--7 = 1971-01-01"- , "1971--20--1 = 1971-01-01"- , "1971--20-0 = 1971-01-01"- , "1971--20-1 = 1971-01-01"- , "1971--20-2 = 1971-01-02"- , "1971--20-27 = 1971-01-27"- , "1971--20-28 = 1971-01-28"- , "1971--20-29 = 1971-01-29"- , "1971--20-30 = 1971-01-30"- , "1971--20-31 = 1971-01-31"- , "1971--20-32 = 1971-01-31"- , "1971--20-40 = 1971-01-31"- , "1971--1--7 = 1971-01-01"- , "1971--1--1 = 1971-01-01"- , "1971--1-0 = 1971-01-01"- , "1971--1-1 = 1971-01-01"- , "1971--1-2 = 1971-01-02"- , "1971--1-27 = 1971-01-27"- , "1971--1-28 = 1971-01-28"- , "1971--1-29 = 1971-01-29"- , "1971--1-30 = 1971-01-30"- , "1971--1-31 = 1971-01-31"- , "1971--1-32 = 1971-01-31"- , "1971--1-40 = 1971-01-31"- , "1971-0--7 = 1971-01-01"- , "1971-0--1 = 1971-01-01"- , "1971-0-0 = 1971-01-01"- , "1971-0-1 = 1971-01-01"- , "1971-0-2 = 1971-01-02"- , "1971-0-27 = 1971-01-27"- , "1971-0-28 = 1971-01-28"- , "1971-0-29 = 1971-01-29"- , "1971-0-30 = 1971-01-30"- , "1971-0-31 = 1971-01-31"- , "1971-0-32 = 1971-01-31"- , "1971-0-40 = 1971-01-31"- , "1971-1--7 = 1971-01-01"- , "1971-1--1 = 1971-01-01"- , "1971-1-0 = 1971-01-01"- , "1971-1-1 = 1971-01-01"- , "1971-1-2 = 1971-01-02"- , "1971-1-27 = 1971-01-27"- , "1971-1-28 = 1971-01-28"- , "1971-1-29 = 1971-01-29"- , "1971-1-30 = 1971-01-30"- , "1971-1-31 = 1971-01-31"- , "1971-1-32 = 1971-01-31"- , "1971-1-40 = 1971-01-31"- , "1971-2--7 = 1971-02-01"- , "1971-2--1 = 1971-02-01"- , "1971-2-0 = 1971-02-01"- , "1971-2-1 = 1971-02-01"- , "1971-2-2 = 1971-02-02"- , "1971-2-27 = 1971-02-27"- , "1971-2-28 = 1971-02-28"- , "1971-2-29 = 1971-02-28"- , "1971-2-30 = 1971-02-28"- , "1971-2-31 = 1971-02-28"- , "1971-2-32 = 1971-02-28"- , "1971-2-40 = 1971-02-28"- , "1971-12--7 = 1971-12-01"- , "1971-12--1 = 1971-12-01"- , "1971-12-0 = 1971-12-01"- , "1971-12-1 = 1971-12-01"- , "1971-12-2 = 1971-12-02"- , "1971-12-27 = 1971-12-27"- , "1971-12-28 = 1971-12-28"- , "1971-12-29 = 1971-12-29"- , "1971-12-30 = 1971-12-30"- , "1971-12-31 = 1971-12-31"- , "1971-12-32 = 1971-12-31"- , "1971-12-40 = 1971-12-31"- , "1971-13--7 = 1971-12-01"- , "1971-13--1 = 1971-12-01"- , "1971-13-0 = 1971-12-01"- , "1971-13-1 = 1971-12-01"- , "1971-13-2 = 1971-12-02"- , "1971-13-27 = 1971-12-27"- , "1971-13-28 = 1971-12-28"- , "1971-13-29 = 1971-12-29"- , "1971-13-30 = 1971-12-30"- , "1971-13-31 = 1971-12-31"- , "1971-13-32 = 1971-12-31"- , "1971-13-40 = 1971-12-31"- , "1971-17--7 = 1971-12-01"- , "1971-17--1 = 1971-12-01"- , "1971-17-0 = 1971-12-01"- , "1971-17-1 = 1971-12-01"- , "1971-17-2 = 1971-12-02"- , "1971-17-27 = 1971-12-27"- , "1971-17-28 = 1971-12-28"- , "1971-17-29 = 1971-12-29"- , "1971-17-30 = 1971-12-30"- , "1971-17-31 = 1971-12-31"- , "1971-17-32 = 1971-12-31"- , "1971-17-40 = 1971-12-31"- ]--clipDatesISOWeekDayRef :: [String]-clipDatesISOWeekDayRef =- [ "1968-W-20--2 = 1968-W01-1"- , "1968-W-20--1 = 1968-W01-1"- , "1968-W-20-0 = 1968-W01-1"- , "1968-W-20-1 = 1968-W01-1"- , "1968-W-20-4 = 1968-W01-4"- , "1968-W-20-6 = 1968-W01-6"- , "1968-W-20-7 = 1968-W01-7"- , "1968-W-20-8 = 1968-W01-7"- , "1968-W-20-9 = 1968-W01-7"- , "1968-W-1--2 = 1968-W01-1"- , "1968-W-1--1 = 1968-W01-1"- , "1968-W-1-0 = 1968-W01-1"- , "1968-W-1-1 = 1968-W01-1"- , "1968-W-1-4 = 1968-W01-4"- , "1968-W-1-6 = 1968-W01-6"- , "1968-W-1-7 = 1968-W01-7"- , "1968-W-1-8 = 1968-W01-7"- , "1968-W-1-9 = 1968-W01-7"- , "1968-W0--2 = 1968-W01-1"- , "1968-W0--1 = 1968-W01-1"- , "1968-W0-0 = 1968-W01-1"- , "1968-W0-1 = 1968-W01-1"- , "1968-W0-4 = 1968-W01-4"- , "1968-W0-6 = 1968-W01-6"- , "1968-W0-7 = 1968-W01-7"- , "1968-W0-8 = 1968-W01-7"- , "1968-W0-9 = 1968-W01-7"- , "1968-W1--2 = 1968-W01-1"- , "1968-W1--1 = 1968-W01-1"- , "1968-W1-0 = 1968-W01-1"- , "1968-W1-1 = 1968-W01-1"- , "1968-W1-4 = 1968-W01-4"- , "1968-W1-6 = 1968-W01-6"- , "1968-W1-7 = 1968-W01-7"- , "1968-W1-8 = 1968-W01-7"- , "1968-W1-9 = 1968-W01-7"- , "1968-W20--2 = 1968-W20-1"- , "1968-W20--1 = 1968-W20-1"- , "1968-W20-0 = 1968-W20-1"- , "1968-W20-1 = 1968-W20-1"- , "1968-W20-4 = 1968-W20-4"- , "1968-W20-6 = 1968-W20-6"- , "1968-W20-7 = 1968-W20-7"- , "1968-W20-8 = 1968-W20-7"- , "1968-W20-9 = 1968-W20-7"- , "1968-W51--2 = 1968-W51-1"- , "1968-W51--1 = 1968-W51-1"- , "1968-W51-0 = 1968-W51-1"- , "1968-W51-1 = 1968-W51-1"- , "1968-W51-4 = 1968-W51-4"- , "1968-W51-6 = 1968-W51-6"- , "1968-W51-7 = 1968-W51-7"- , "1968-W51-8 = 1968-W51-7"- , "1968-W51-9 = 1968-W51-7"- , "1968-W52--2 = 1968-W52-1"- , "1968-W52--1 = 1968-W52-1"- , "1968-W52-0 = 1968-W52-1"- , "1968-W52-1 = 1968-W52-1"- , "1968-W52-4 = 1968-W52-4"- , "1968-W52-6 = 1968-W52-6"- , "1968-W52-7 = 1968-W52-7"- , "1968-W52-8 = 1968-W52-7"- , "1968-W52-9 = 1968-W52-7"- , "1968-W53--2 = 1968-W52-1"- , "1968-W53--1 = 1968-W52-1"- , "1968-W53-0 = 1968-W52-1"- , "1968-W53-1 = 1968-W52-1"- , "1968-W53-4 = 1968-W52-4"- , "1968-W53-6 = 1968-W52-6"- , "1968-W53-7 = 1968-W52-7"- , "1968-W53-8 = 1968-W52-7"- , "1968-W53-9 = 1968-W52-7"- , "1968-W54--2 = 1968-W52-1"- , "1968-W54--1 = 1968-W52-1"- , "1968-W54-0 = 1968-W52-1"- , "1968-W54-1 = 1968-W52-1"- , "1968-W54-4 = 1968-W52-4"- , "1968-W54-6 = 1968-W52-6"- , "1968-W54-7 = 1968-W52-7"- , "1968-W54-8 = 1968-W52-7"- , "1968-W54-9 = 1968-W52-7"- , "1969-W-20--2 = 1969-W01-1"- , "1969-W-20--1 = 1969-W01-1"- , "1969-W-20-0 = 1969-W01-1"- , "1969-W-20-1 = 1969-W01-1"- , "1969-W-20-4 = 1969-W01-4"- , "1969-W-20-6 = 1969-W01-6"- , "1969-W-20-7 = 1969-W01-7"- , "1969-W-20-8 = 1969-W01-7"- , "1969-W-20-9 = 1969-W01-7"- , "1969-W-1--2 = 1969-W01-1"- , "1969-W-1--1 = 1969-W01-1"- , "1969-W-1-0 = 1969-W01-1"- , "1969-W-1-1 = 1969-W01-1"- , "1969-W-1-4 = 1969-W01-4"- , "1969-W-1-6 = 1969-W01-6"- , "1969-W-1-7 = 1969-W01-7"- , "1969-W-1-8 = 1969-W01-7"- , "1969-W-1-9 = 1969-W01-7"- , "1969-W0--2 = 1969-W01-1"- , "1969-W0--1 = 1969-W01-1"- , "1969-W0-0 = 1969-W01-1"- , "1969-W0-1 = 1969-W01-1"- , "1969-W0-4 = 1969-W01-4"- , "1969-W0-6 = 1969-W01-6"- , "1969-W0-7 = 1969-W01-7"- , "1969-W0-8 = 1969-W01-7"- , "1969-W0-9 = 1969-W01-7"- , "1969-W1--2 = 1969-W01-1"- , "1969-W1--1 = 1969-W01-1"- , "1969-W1-0 = 1969-W01-1"- , "1969-W1-1 = 1969-W01-1"- , "1969-W1-4 = 1969-W01-4"- , "1969-W1-6 = 1969-W01-6"- , "1969-W1-7 = 1969-W01-7"- , "1969-W1-8 = 1969-W01-7"- , "1969-W1-9 = 1969-W01-7"- , "1969-W20--2 = 1969-W20-1"- , "1969-W20--1 = 1969-W20-1"- , "1969-W20-0 = 1969-W20-1"- , "1969-W20-1 = 1969-W20-1"- , "1969-W20-4 = 1969-W20-4"- , "1969-W20-6 = 1969-W20-6"- , "1969-W20-7 = 1969-W20-7"- , "1969-W20-8 = 1969-W20-7"- , "1969-W20-9 = 1969-W20-7"- , "1969-W51--2 = 1969-W51-1"- , "1969-W51--1 = 1969-W51-1"- , "1969-W51-0 = 1969-W51-1"- , "1969-W51-1 = 1969-W51-1"- , "1969-W51-4 = 1969-W51-4"- , "1969-W51-6 = 1969-W51-6"- , "1969-W51-7 = 1969-W51-7"- , "1969-W51-8 = 1969-W51-7"- , "1969-W51-9 = 1969-W51-7"- , "1969-W52--2 = 1969-W52-1"- , "1969-W52--1 = 1969-W52-1"- , "1969-W52-0 = 1969-W52-1"- , "1969-W52-1 = 1969-W52-1"- , "1969-W52-4 = 1969-W52-4"- , "1969-W52-6 = 1969-W52-6"- , "1969-W52-7 = 1969-W52-7"- , "1969-W52-8 = 1969-W52-7"- , "1969-W52-9 = 1969-W52-7"- , "1969-W53--2 = 1969-W52-1"- , "1969-W53--1 = 1969-W52-1"- , "1969-W53-0 = 1969-W52-1"- , "1969-W53-1 = 1969-W52-1"- , "1969-W53-4 = 1969-W52-4"- , "1969-W53-6 = 1969-W52-6"- , "1969-W53-7 = 1969-W52-7"- , "1969-W53-8 = 1969-W52-7"- , "1969-W53-9 = 1969-W52-7"- , "1969-W54--2 = 1969-W52-1"- , "1969-W54--1 = 1969-W52-1"- , "1969-W54-0 = 1969-W52-1"- , "1969-W54-1 = 1969-W52-1"- , "1969-W54-4 = 1969-W52-4"- , "1969-W54-6 = 1969-W52-6"- , "1969-W54-7 = 1969-W52-7"- , "1969-W54-8 = 1969-W52-7"- , "1969-W54-9 = 1969-W52-7"- , "2004-W-20--2 = 2004-W01-1"- , "2004-W-20--1 = 2004-W01-1"- , "2004-W-20-0 = 2004-W01-1"- , "2004-W-20-1 = 2004-W01-1"- , "2004-W-20-4 = 2004-W01-4"- , "2004-W-20-6 = 2004-W01-6"- , "2004-W-20-7 = 2004-W01-7"- , "2004-W-20-8 = 2004-W01-7"- , "2004-W-20-9 = 2004-W01-7"- , "2004-W-1--2 = 2004-W01-1"- , "2004-W-1--1 = 2004-W01-1"- , "2004-W-1-0 = 2004-W01-1"- , "2004-W-1-1 = 2004-W01-1"- , "2004-W-1-4 = 2004-W01-4"- , "2004-W-1-6 = 2004-W01-6"- , "2004-W-1-7 = 2004-W01-7"- , "2004-W-1-8 = 2004-W01-7"- , "2004-W-1-9 = 2004-W01-7"- , "2004-W0--2 = 2004-W01-1"- , "2004-W0--1 = 2004-W01-1"- , "2004-W0-0 = 2004-W01-1"- , "2004-W0-1 = 2004-W01-1"- , "2004-W0-4 = 2004-W01-4"- , "2004-W0-6 = 2004-W01-6"- , "2004-W0-7 = 2004-W01-7"- , "2004-W0-8 = 2004-W01-7"- , "2004-W0-9 = 2004-W01-7"- , "2004-W1--2 = 2004-W01-1"- , "2004-W1--1 = 2004-W01-1"- , "2004-W1-0 = 2004-W01-1"- , "2004-W1-1 = 2004-W01-1"- , "2004-W1-4 = 2004-W01-4"- , "2004-W1-6 = 2004-W01-6"- , "2004-W1-7 = 2004-W01-7"- , "2004-W1-8 = 2004-W01-7"- , "2004-W1-9 = 2004-W01-7"- , "2004-W20--2 = 2004-W20-1"- , "2004-W20--1 = 2004-W20-1"- , "2004-W20-0 = 2004-W20-1"- , "2004-W20-1 = 2004-W20-1"- , "2004-W20-4 = 2004-W20-4"- , "2004-W20-6 = 2004-W20-6"- , "2004-W20-7 = 2004-W20-7"- , "2004-W20-8 = 2004-W20-7"- , "2004-W20-9 = 2004-W20-7"- , "2004-W51--2 = 2004-W51-1"- , "2004-W51--1 = 2004-W51-1"- , "2004-W51-0 = 2004-W51-1"- , "2004-W51-1 = 2004-W51-1"- , "2004-W51-4 = 2004-W51-4"- , "2004-W51-6 = 2004-W51-6"- , "2004-W51-7 = 2004-W51-7"- , "2004-W51-8 = 2004-W51-7"- , "2004-W51-9 = 2004-W51-7"- , "2004-W52--2 = 2004-W52-1"- , "2004-W52--1 = 2004-W52-1"- , "2004-W52-0 = 2004-W52-1"- , "2004-W52-1 = 2004-W52-1"- , "2004-W52-4 = 2004-W52-4"- , "2004-W52-6 = 2004-W52-6"- , "2004-W52-7 = 2004-W52-7"- , "2004-W52-8 = 2004-W52-7"- , "2004-W52-9 = 2004-W52-7"- , "2004-W53--2 = 2004-W53-1"- , "2004-W53--1 = 2004-W53-1"- , "2004-W53-0 = 2004-W53-1"- , "2004-W53-1 = 2004-W53-1"- , "2004-W53-4 = 2004-W53-4"- , "2004-W53-6 = 2004-W53-6"- , "2004-W53-7 = 2004-W53-7"- , "2004-W53-8 = 2004-W53-7"- , "2004-W53-9 = 2004-W53-7"- , "2004-W54--2 = 2004-W53-1"- , "2004-W54--1 = 2004-W53-1"- , "2004-W54-0 = 2004-W53-1"- , "2004-W54-1 = 2004-W53-1"- , "2004-W54-4 = 2004-W53-4"- , "2004-W54-6 = 2004-W53-6"- , "2004-W54-7 = 2004-W53-7"- , "2004-W54-8 = 2004-W53-7"- , "2004-W54-9 = 2004-W53-7"- ]+ [ "1968--4 = 1968-001"+ , "1968-0 = 1968-001"+ , "1968-1 = 1968-001"+ , "1968-200 = 1968-200"+ , "1968-364 = 1968-364"+ , "1968-365 = 1968-365"+ , "1968-366 = 1968-366"+ , "1968-367 = 1968-366"+ , "1968-700 = 1968-366"+ , "1969--4 = 1969-001"+ , "1969-0 = 1969-001"+ , "1969-1 = 1969-001"+ , "1969-200 = 1969-200"+ , "1969-364 = 1969-364"+ , "1969-365 = 1969-365"+ , "1969-366 = 1969-365"+ , "1969-367 = 1969-365"+ , "1969-700 = 1969-365"+ , "1971--4 = 1971-001"+ , "1971-0 = 1971-001"+ , "1971-1 = 1971-001"+ , "1971-200 = 1971-200"+ , "1971-364 = 1971-364"+ , "1971-365 = 1971-365"+ , "1971-366 = 1971-365"+ , "1971-367 = 1971-365"+ , "1971-700 = 1971-365"+ ]++clipDatesGregorianDayRef :: [String]+clipDatesGregorianDayRef =+ [ "1968--20--7 = 1968-01-01"+ , "1968--20--1 = 1968-01-01"+ , "1968--20-0 = 1968-01-01"+ , "1968--20-1 = 1968-01-01"+ , "1968--20-2 = 1968-01-02"+ , "1968--20-27 = 1968-01-27"+ , "1968--20-28 = 1968-01-28"+ , "1968--20-29 = 1968-01-29"+ , "1968--20-30 = 1968-01-30"+ , "1968--20-31 = 1968-01-31"+ , "1968--20-32 = 1968-01-31"+ , "1968--20-40 = 1968-01-31"+ , "1968--1--7 = 1968-01-01"+ , "1968--1--1 = 1968-01-01"+ , "1968--1-0 = 1968-01-01"+ , "1968--1-1 = 1968-01-01"+ , "1968--1-2 = 1968-01-02"+ , "1968--1-27 = 1968-01-27"+ , "1968--1-28 = 1968-01-28"+ , "1968--1-29 = 1968-01-29"+ , "1968--1-30 = 1968-01-30"+ , "1968--1-31 = 1968-01-31"+ , "1968--1-32 = 1968-01-31"+ , "1968--1-40 = 1968-01-31"+ , "1968-0--7 = 1968-01-01"+ , "1968-0--1 = 1968-01-01"+ , "1968-0-0 = 1968-01-01"+ , "1968-0-1 = 1968-01-01"+ , "1968-0-2 = 1968-01-02"+ , "1968-0-27 = 1968-01-27"+ , "1968-0-28 = 1968-01-28"+ , "1968-0-29 = 1968-01-29"+ , "1968-0-30 = 1968-01-30"+ , "1968-0-31 = 1968-01-31"+ , "1968-0-32 = 1968-01-31"+ , "1968-0-40 = 1968-01-31"+ , "1968-1--7 = 1968-01-01"+ , "1968-1--1 = 1968-01-01"+ , "1968-1-0 = 1968-01-01"+ , "1968-1-1 = 1968-01-01"+ , "1968-1-2 = 1968-01-02"+ , "1968-1-27 = 1968-01-27"+ , "1968-1-28 = 1968-01-28"+ , "1968-1-29 = 1968-01-29"+ , "1968-1-30 = 1968-01-30"+ , "1968-1-31 = 1968-01-31"+ , "1968-1-32 = 1968-01-31"+ , "1968-1-40 = 1968-01-31"+ , "1968-2--7 = 1968-02-01"+ , "1968-2--1 = 1968-02-01"+ , "1968-2-0 = 1968-02-01"+ , "1968-2-1 = 1968-02-01"+ , "1968-2-2 = 1968-02-02"+ , "1968-2-27 = 1968-02-27"+ , "1968-2-28 = 1968-02-28"+ , "1968-2-29 = 1968-02-29"+ , "1968-2-30 = 1968-02-29"+ , "1968-2-31 = 1968-02-29"+ , "1968-2-32 = 1968-02-29"+ , "1968-2-40 = 1968-02-29"+ , "1968-12--7 = 1968-12-01"+ , "1968-12--1 = 1968-12-01"+ , "1968-12-0 = 1968-12-01"+ , "1968-12-1 = 1968-12-01"+ , "1968-12-2 = 1968-12-02"+ , "1968-12-27 = 1968-12-27"+ , "1968-12-28 = 1968-12-28"+ , "1968-12-29 = 1968-12-29"+ , "1968-12-30 = 1968-12-30"+ , "1968-12-31 = 1968-12-31"+ , "1968-12-32 = 1968-12-31"+ , "1968-12-40 = 1968-12-31"+ , "1968-13--7 = 1968-12-01"+ , "1968-13--1 = 1968-12-01"+ , "1968-13-0 = 1968-12-01"+ , "1968-13-1 = 1968-12-01"+ , "1968-13-2 = 1968-12-02"+ , "1968-13-27 = 1968-12-27"+ , "1968-13-28 = 1968-12-28"+ , "1968-13-29 = 1968-12-29"+ , "1968-13-30 = 1968-12-30"+ , "1968-13-31 = 1968-12-31"+ , "1968-13-32 = 1968-12-31"+ , "1968-13-40 = 1968-12-31"+ , "1968-17--7 = 1968-12-01"+ , "1968-17--1 = 1968-12-01"+ , "1968-17-0 = 1968-12-01"+ , "1968-17-1 = 1968-12-01"+ , "1968-17-2 = 1968-12-02"+ , "1968-17-27 = 1968-12-27"+ , "1968-17-28 = 1968-12-28"+ , "1968-17-29 = 1968-12-29"+ , "1968-17-30 = 1968-12-30"+ , "1968-17-31 = 1968-12-31"+ , "1968-17-32 = 1968-12-31"+ , "1968-17-40 = 1968-12-31"+ , "1969--20--7 = 1969-01-01"+ , "1969--20--1 = 1969-01-01"+ , "1969--20-0 = 1969-01-01"+ , "1969--20-1 = 1969-01-01"+ , "1969--20-2 = 1969-01-02"+ , "1969--20-27 = 1969-01-27"+ , "1969--20-28 = 1969-01-28"+ , "1969--20-29 = 1969-01-29"+ , "1969--20-30 = 1969-01-30"+ , "1969--20-31 = 1969-01-31"+ , "1969--20-32 = 1969-01-31"+ , "1969--20-40 = 1969-01-31"+ , "1969--1--7 = 1969-01-01"+ , "1969--1--1 = 1969-01-01"+ , "1969--1-0 = 1969-01-01"+ , "1969--1-1 = 1969-01-01"+ , "1969--1-2 = 1969-01-02"+ , "1969--1-27 = 1969-01-27"+ , "1969--1-28 = 1969-01-28"+ , "1969--1-29 = 1969-01-29"+ , "1969--1-30 = 1969-01-30"+ , "1969--1-31 = 1969-01-31"+ , "1969--1-32 = 1969-01-31"+ , "1969--1-40 = 1969-01-31"+ , "1969-0--7 = 1969-01-01"+ , "1969-0--1 = 1969-01-01"+ , "1969-0-0 = 1969-01-01"+ , "1969-0-1 = 1969-01-01"+ , "1969-0-2 = 1969-01-02"+ , "1969-0-27 = 1969-01-27"+ , "1969-0-28 = 1969-01-28"+ , "1969-0-29 = 1969-01-29"+ , "1969-0-30 = 1969-01-30"+ , "1969-0-31 = 1969-01-31"+ , "1969-0-32 = 1969-01-31"+ , "1969-0-40 = 1969-01-31"+ , "1969-1--7 = 1969-01-01"+ , "1969-1--1 = 1969-01-01"+ , "1969-1-0 = 1969-01-01"+ , "1969-1-1 = 1969-01-01"+ , "1969-1-2 = 1969-01-02"+ , "1969-1-27 = 1969-01-27"+ , "1969-1-28 = 1969-01-28"+ , "1969-1-29 = 1969-01-29"+ , "1969-1-30 = 1969-01-30"+ , "1969-1-31 = 1969-01-31"+ , "1969-1-32 = 1969-01-31"+ , "1969-1-40 = 1969-01-31"+ , "1969-2--7 = 1969-02-01"+ , "1969-2--1 = 1969-02-01"+ , "1969-2-0 = 1969-02-01"+ , "1969-2-1 = 1969-02-01"+ , "1969-2-2 = 1969-02-02"+ , "1969-2-27 = 1969-02-27"+ , "1969-2-28 = 1969-02-28"+ , "1969-2-29 = 1969-02-28"+ , "1969-2-30 = 1969-02-28"+ , "1969-2-31 = 1969-02-28"+ , "1969-2-32 = 1969-02-28"+ , "1969-2-40 = 1969-02-28"+ , "1969-12--7 = 1969-12-01"+ , "1969-12--1 = 1969-12-01"+ , "1969-12-0 = 1969-12-01"+ , "1969-12-1 = 1969-12-01"+ , "1969-12-2 = 1969-12-02"+ , "1969-12-27 = 1969-12-27"+ , "1969-12-28 = 1969-12-28"+ , "1969-12-29 = 1969-12-29"+ , "1969-12-30 = 1969-12-30"+ , "1969-12-31 = 1969-12-31"+ , "1969-12-32 = 1969-12-31"+ , "1969-12-40 = 1969-12-31"+ , "1969-13--7 = 1969-12-01"+ , "1969-13--1 = 1969-12-01"+ , "1969-13-0 = 1969-12-01"+ , "1969-13-1 = 1969-12-01"+ , "1969-13-2 = 1969-12-02"+ , "1969-13-27 = 1969-12-27"+ , "1969-13-28 = 1969-12-28"+ , "1969-13-29 = 1969-12-29"+ , "1969-13-30 = 1969-12-30"+ , "1969-13-31 = 1969-12-31"+ , "1969-13-32 = 1969-12-31"+ , "1969-13-40 = 1969-12-31"+ , "1969-17--7 = 1969-12-01"+ , "1969-17--1 = 1969-12-01"+ , "1969-17-0 = 1969-12-01"+ , "1969-17-1 = 1969-12-01"+ , "1969-17-2 = 1969-12-02"+ , "1969-17-27 = 1969-12-27"+ , "1969-17-28 = 1969-12-28"+ , "1969-17-29 = 1969-12-29"+ , "1969-17-30 = 1969-12-30"+ , "1969-17-31 = 1969-12-31"+ , "1969-17-32 = 1969-12-31"+ , "1969-17-40 = 1969-12-31"+ , "1971--20--7 = 1971-01-01"+ , "1971--20--1 = 1971-01-01"+ , "1971--20-0 = 1971-01-01"+ , "1971--20-1 = 1971-01-01"+ , "1971--20-2 = 1971-01-02"+ , "1971--20-27 = 1971-01-27"+ , "1971--20-28 = 1971-01-28"+ , "1971--20-29 = 1971-01-29"+ , "1971--20-30 = 1971-01-30"+ , "1971--20-31 = 1971-01-31"+ , "1971--20-32 = 1971-01-31"+ , "1971--20-40 = 1971-01-31"+ , "1971--1--7 = 1971-01-01"+ , "1971--1--1 = 1971-01-01"+ , "1971--1-0 = 1971-01-01"+ , "1971--1-1 = 1971-01-01"+ , "1971--1-2 = 1971-01-02"+ , "1971--1-27 = 1971-01-27"+ , "1971--1-28 = 1971-01-28"+ , "1971--1-29 = 1971-01-29"+ , "1971--1-30 = 1971-01-30"+ , "1971--1-31 = 1971-01-31"+ , "1971--1-32 = 1971-01-31"+ , "1971--1-40 = 1971-01-31"+ , "1971-0--7 = 1971-01-01"+ , "1971-0--1 = 1971-01-01"+ , "1971-0-0 = 1971-01-01"+ , "1971-0-1 = 1971-01-01"+ , "1971-0-2 = 1971-01-02"+ , "1971-0-27 = 1971-01-27"+ , "1971-0-28 = 1971-01-28"+ , "1971-0-29 = 1971-01-29"+ , "1971-0-30 = 1971-01-30"+ , "1971-0-31 = 1971-01-31"+ , "1971-0-32 = 1971-01-31"+ , "1971-0-40 = 1971-01-31"+ , "1971-1--7 = 1971-01-01"+ , "1971-1--1 = 1971-01-01"+ , "1971-1-0 = 1971-01-01"+ , "1971-1-1 = 1971-01-01"+ , "1971-1-2 = 1971-01-02"+ , "1971-1-27 = 1971-01-27"+ , "1971-1-28 = 1971-01-28"+ , "1971-1-29 = 1971-01-29"+ , "1971-1-30 = 1971-01-30"+ , "1971-1-31 = 1971-01-31"+ , "1971-1-32 = 1971-01-31"+ , "1971-1-40 = 1971-01-31"+ , "1971-2--7 = 1971-02-01"+ , "1971-2--1 = 1971-02-01"+ , "1971-2-0 = 1971-02-01"+ , "1971-2-1 = 1971-02-01"+ , "1971-2-2 = 1971-02-02"+ , "1971-2-27 = 1971-02-27"+ , "1971-2-28 = 1971-02-28"+ , "1971-2-29 = 1971-02-28"+ , "1971-2-30 = 1971-02-28"+ , "1971-2-31 = 1971-02-28"+ , "1971-2-32 = 1971-02-28"+ , "1971-2-40 = 1971-02-28"+ , "1971-12--7 = 1971-12-01"+ , "1971-12--1 = 1971-12-01"+ , "1971-12-0 = 1971-12-01"+ , "1971-12-1 = 1971-12-01"+ , "1971-12-2 = 1971-12-02"+ , "1971-12-27 = 1971-12-27"+ , "1971-12-28 = 1971-12-28"+ , "1971-12-29 = 1971-12-29"+ , "1971-12-30 = 1971-12-30"+ , "1971-12-31 = 1971-12-31"+ , "1971-12-32 = 1971-12-31"+ , "1971-12-40 = 1971-12-31"+ , "1971-13--7 = 1971-12-01"+ , "1971-13--1 = 1971-12-01"+ , "1971-13-0 = 1971-12-01"+ , "1971-13-1 = 1971-12-01"+ , "1971-13-2 = 1971-12-02"+ , "1971-13-27 = 1971-12-27"+ , "1971-13-28 = 1971-12-28"+ , "1971-13-29 = 1971-12-29"+ , "1971-13-30 = 1971-12-30"+ , "1971-13-31 = 1971-12-31"+ , "1971-13-32 = 1971-12-31"+ , "1971-13-40 = 1971-12-31"+ , "1971-17--7 = 1971-12-01"+ , "1971-17--1 = 1971-12-01"+ , "1971-17-0 = 1971-12-01"+ , "1971-17-1 = 1971-12-01"+ , "1971-17-2 = 1971-12-02"+ , "1971-17-27 = 1971-12-27"+ , "1971-17-28 = 1971-12-28"+ , "1971-17-29 = 1971-12-29"+ , "1971-17-30 = 1971-12-30"+ , "1971-17-31 = 1971-12-31"+ , "1971-17-32 = 1971-12-31"+ , "1971-17-40 = 1971-12-31"+ ]++clipDatesISOWeekDayRef :: [String]+clipDatesISOWeekDayRef =+ [ "1968-W-20--2 = 1968-W01-1"+ , "1968-W-20--1 = 1968-W01-1"+ , "1968-W-20-0 = 1968-W01-1"+ , "1968-W-20-1 = 1968-W01-1"+ , "1968-W-20-4 = 1968-W01-4"+ , "1968-W-20-6 = 1968-W01-6"+ , "1968-W-20-7 = 1968-W01-7"+ , "1968-W-20-8 = 1968-W01-7"+ , "1968-W-20-9 = 1968-W01-7"+ , "1968-W-1--2 = 1968-W01-1"+ , "1968-W-1--1 = 1968-W01-1"+ , "1968-W-1-0 = 1968-W01-1"+ , "1968-W-1-1 = 1968-W01-1"+ , "1968-W-1-4 = 1968-W01-4"+ , "1968-W-1-6 = 1968-W01-6"+ , "1968-W-1-7 = 1968-W01-7"+ , "1968-W-1-8 = 1968-W01-7"+ , "1968-W-1-9 = 1968-W01-7"+ , "1968-W0--2 = 1968-W01-1"+ , "1968-W0--1 = 1968-W01-1"+ , "1968-W0-0 = 1968-W01-1"+ , "1968-W0-1 = 1968-W01-1"+ , "1968-W0-4 = 1968-W01-4"+ , "1968-W0-6 = 1968-W01-6"+ , "1968-W0-7 = 1968-W01-7"+ , "1968-W0-8 = 1968-W01-7"+ , "1968-W0-9 = 1968-W01-7"+ , "1968-W1--2 = 1968-W01-1"+ , "1968-W1--1 = 1968-W01-1"+ , "1968-W1-0 = 1968-W01-1"+ , "1968-W1-1 = 1968-W01-1"+ , "1968-W1-4 = 1968-W01-4"+ , "1968-W1-6 = 1968-W01-6"+ , "1968-W1-7 = 1968-W01-7"+ , "1968-W1-8 = 1968-W01-7"+ , "1968-W1-9 = 1968-W01-7"+ , "1968-W20--2 = 1968-W20-1"+ , "1968-W20--1 = 1968-W20-1"+ , "1968-W20-0 = 1968-W20-1"+ , "1968-W20-1 = 1968-W20-1"+ , "1968-W20-4 = 1968-W20-4"+ , "1968-W20-6 = 1968-W20-6"+ , "1968-W20-7 = 1968-W20-7"+ , "1968-W20-8 = 1968-W20-7"+ , "1968-W20-9 = 1968-W20-7"+ , "1968-W51--2 = 1968-W51-1"+ , "1968-W51--1 = 1968-W51-1"+ , "1968-W51-0 = 1968-W51-1"+ , "1968-W51-1 = 1968-W51-1"+ , "1968-W51-4 = 1968-W51-4"+ , "1968-W51-6 = 1968-W51-6"+ , "1968-W51-7 = 1968-W51-7"+ , "1968-W51-8 = 1968-W51-7"+ , "1968-W51-9 = 1968-W51-7"+ , "1968-W52--2 = 1968-W52-1"+ , "1968-W52--1 = 1968-W52-1"+ , "1968-W52-0 = 1968-W52-1"+ , "1968-W52-1 = 1968-W52-1"+ , "1968-W52-4 = 1968-W52-4"+ , "1968-W52-6 = 1968-W52-6"+ , "1968-W52-7 = 1968-W52-7"+ , "1968-W52-8 = 1968-W52-7"+ , "1968-W52-9 = 1968-W52-7"+ , "1968-W53--2 = 1968-W52-1"+ , "1968-W53--1 = 1968-W52-1"+ , "1968-W53-0 = 1968-W52-1"+ , "1968-W53-1 = 1968-W52-1"+ , "1968-W53-4 = 1968-W52-4"+ , "1968-W53-6 = 1968-W52-6"+ , "1968-W53-7 = 1968-W52-7"+ , "1968-W53-8 = 1968-W52-7"+ , "1968-W53-9 = 1968-W52-7"+ , "1968-W54--2 = 1968-W52-1"+ , "1968-W54--1 = 1968-W52-1"+ , "1968-W54-0 = 1968-W52-1"+ , "1968-W54-1 = 1968-W52-1"+ , "1968-W54-4 = 1968-W52-4"+ , "1968-W54-6 = 1968-W52-6"+ , "1968-W54-7 = 1968-W52-7"+ , "1968-W54-8 = 1968-W52-7"+ , "1968-W54-9 = 1968-W52-7"+ , "1969-W-20--2 = 1969-W01-1"+ , "1969-W-20--1 = 1969-W01-1"+ , "1969-W-20-0 = 1969-W01-1"+ , "1969-W-20-1 = 1969-W01-1"+ , "1969-W-20-4 = 1969-W01-4"+ , "1969-W-20-6 = 1969-W01-6"+ , "1969-W-20-7 = 1969-W01-7"+ , "1969-W-20-8 = 1969-W01-7"+ , "1969-W-20-9 = 1969-W01-7"+ , "1969-W-1--2 = 1969-W01-1"+ , "1969-W-1--1 = 1969-W01-1"+ , "1969-W-1-0 = 1969-W01-1"+ , "1969-W-1-1 = 1969-W01-1"+ , "1969-W-1-4 = 1969-W01-4"+ , "1969-W-1-6 = 1969-W01-6"+ , "1969-W-1-7 = 1969-W01-7"+ , "1969-W-1-8 = 1969-W01-7"+ , "1969-W-1-9 = 1969-W01-7"+ , "1969-W0--2 = 1969-W01-1"+ , "1969-W0--1 = 1969-W01-1"+ , "1969-W0-0 = 1969-W01-1"+ , "1969-W0-1 = 1969-W01-1"+ , "1969-W0-4 = 1969-W01-4"+ , "1969-W0-6 = 1969-W01-6"+ , "1969-W0-7 = 1969-W01-7"+ , "1969-W0-8 = 1969-W01-7"+ , "1969-W0-9 = 1969-W01-7"+ , "1969-W1--2 = 1969-W01-1"+ , "1969-W1--1 = 1969-W01-1"+ , "1969-W1-0 = 1969-W01-1"+ , "1969-W1-1 = 1969-W01-1"+ , "1969-W1-4 = 1969-W01-4"+ , "1969-W1-6 = 1969-W01-6"+ , "1969-W1-7 = 1969-W01-7"+ , "1969-W1-8 = 1969-W01-7"+ , "1969-W1-9 = 1969-W01-7"+ , "1969-W20--2 = 1969-W20-1"+ , "1969-W20--1 = 1969-W20-1"+ , "1969-W20-0 = 1969-W20-1"+ , "1969-W20-1 = 1969-W20-1"+ , "1969-W20-4 = 1969-W20-4"+ , "1969-W20-6 = 1969-W20-6"+ , "1969-W20-7 = 1969-W20-7"+ , "1969-W20-8 = 1969-W20-7"+ , "1969-W20-9 = 1969-W20-7"+ , "1969-W51--2 = 1969-W51-1"+ , "1969-W51--1 = 1969-W51-1"+ , "1969-W51-0 = 1969-W51-1"+ , "1969-W51-1 = 1969-W51-1"+ , "1969-W51-4 = 1969-W51-4"+ , "1969-W51-6 = 1969-W51-6"+ , "1969-W51-7 = 1969-W51-7"+ , "1969-W51-8 = 1969-W51-7"+ , "1969-W51-9 = 1969-W51-7"+ , "1969-W52--2 = 1969-W52-1"+ , "1969-W52--1 = 1969-W52-1"+ , "1969-W52-0 = 1969-W52-1"+ , "1969-W52-1 = 1969-W52-1"+ , "1969-W52-4 = 1969-W52-4"+ , "1969-W52-6 = 1969-W52-6"+ , "1969-W52-7 = 1969-W52-7"+ , "1969-W52-8 = 1969-W52-7"+ , "1969-W52-9 = 1969-W52-7"+ , "1969-W53--2 = 1969-W52-1"+ , "1969-W53--1 = 1969-W52-1"+ , "1969-W53-0 = 1969-W52-1"+ , "1969-W53-1 = 1969-W52-1"+ , "1969-W53-4 = 1969-W52-4"+ , "1969-W53-6 = 1969-W52-6"+ , "1969-W53-7 = 1969-W52-7"+ , "1969-W53-8 = 1969-W52-7"+ , "1969-W53-9 = 1969-W52-7"+ , "1969-W54--2 = 1969-W52-1"+ , "1969-W54--1 = 1969-W52-1"+ , "1969-W54-0 = 1969-W52-1"+ , "1969-W54-1 = 1969-W52-1"+ , "1969-W54-4 = 1969-W52-4"+ , "1969-W54-6 = 1969-W52-6"+ , "1969-W54-7 = 1969-W52-7"+ , "1969-W54-8 = 1969-W52-7"+ , "1969-W54-9 = 1969-W52-7"+ , "2004-W-20--2 = 2004-W01-1"+ , "2004-W-20--1 = 2004-W01-1"+ , "2004-W-20-0 = 2004-W01-1"+ , "2004-W-20-1 = 2004-W01-1"+ , "2004-W-20-4 = 2004-W01-4"+ , "2004-W-20-6 = 2004-W01-6"+ , "2004-W-20-7 = 2004-W01-7"+ , "2004-W-20-8 = 2004-W01-7"+ , "2004-W-20-9 = 2004-W01-7"+ , "2004-W-1--2 = 2004-W01-1"+ , "2004-W-1--1 = 2004-W01-1"+ , "2004-W-1-0 = 2004-W01-1"+ , "2004-W-1-1 = 2004-W01-1"+ , "2004-W-1-4 = 2004-W01-4"+ , "2004-W-1-6 = 2004-W01-6"+ , "2004-W-1-7 = 2004-W01-7"+ , "2004-W-1-8 = 2004-W01-7"+ , "2004-W-1-9 = 2004-W01-7"+ , "2004-W0--2 = 2004-W01-1"+ , "2004-W0--1 = 2004-W01-1"+ , "2004-W0-0 = 2004-W01-1"+ , "2004-W0-1 = 2004-W01-1"+ , "2004-W0-4 = 2004-W01-4"+ , "2004-W0-6 = 2004-W01-6"+ , "2004-W0-7 = 2004-W01-7"+ , "2004-W0-8 = 2004-W01-7"+ , "2004-W0-9 = 2004-W01-7"+ , "2004-W1--2 = 2004-W01-1"+ , "2004-W1--1 = 2004-W01-1"+ , "2004-W1-0 = 2004-W01-1"+ , "2004-W1-1 = 2004-W01-1"+ , "2004-W1-4 = 2004-W01-4"+ , "2004-W1-6 = 2004-W01-6"+ , "2004-W1-7 = 2004-W01-7"+ , "2004-W1-8 = 2004-W01-7"+ , "2004-W1-9 = 2004-W01-7"+ , "2004-W20--2 = 2004-W20-1"+ , "2004-W20--1 = 2004-W20-1"+ , "2004-W20-0 = 2004-W20-1"+ , "2004-W20-1 = 2004-W20-1"+ , "2004-W20-4 = 2004-W20-4"+ , "2004-W20-6 = 2004-W20-6"+ , "2004-W20-7 = 2004-W20-7"+ , "2004-W20-8 = 2004-W20-7"+ , "2004-W20-9 = 2004-W20-7"+ , "2004-W51--2 = 2004-W51-1"+ , "2004-W51--1 = 2004-W51-1"+ , "2004-W51-0 = 2004-W51-1"+ , "2004-W51-1 = 2004-W51-1"+ , "2004-W51-4 = 2004-W51-4"+ , "2004-W51-6 = 2004-W51-6"+ , "2004-W51-7 = 2004-W51-7"+ , "2004-W51-8 = 2004-W51-7"+ , "2004-W51-9 = 2004-W51-7"+ , "2004-W52--2 = 2004-W52-1"+ , "2004-W52--1 = 2004-W52-1"+ , "2004-W52-0 = 2004-W52-1"+ , "2004-W52-1 = 2004-W52-1"+ , "2004-W52-4 = 2004-W52-4"+ , "2004-W52-6 = 2004-W52-6"+ , "2004-W52-7 = 2004-W52-7"+ , "2004-W52-8 = 2004-W52-7"+ , "2004-W52-9 = 2004-W52-7"+ , "2004-W53--2 = 2004-W53-1"+ , "2004-W53--1 = 2004-W53-1"+ , "2004-W53-0 = 2004-W53-1"+ , "2004-W53-1 = 2004-W53-1"+ , "2004-W53-4 = 2004-W53-4"+ , "2004-W53-6 = 2004-W53-6"+ , "2004-W53-7 = 2004-W53-7"+ , "2004-W53-8 = 2004-W53-7"+ , "2004-W53-9 = 2004-W53-7"+ , "2004-W54--2 = 2004-W53-1"+ , "2004-W54--1 = 2004-W53-1"+ , "2004-W54-0 = 2004-W53-1"+ , "2004-W54-1 = 2004-W53-1"+ , "2004-W54-4 = 2004-W53-4"+ , "2004-W54-6 = 2004-W53-6"+ , "2004-W54-7 = 2004-W53-7"+ , "2004-W54-8 = 2004-W53-7"+ , "2004-W54-9 = 2004-W53-7"+ ]
test/main/Test/Calendar/ConvertBack.hs view
@@ -1,6 +1,6 @@-module Test.Calendar.ConvertBack- ( convertBack- ) where+module Test.Calendar.ConvertBack (+ convertBack,+) where import Data.Time.Calendar import Data.Time.Calendar.Julian@@ -10,19 +10,19 @@ 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 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 =
test/main/Test/Calendar/Duration.hs view
@@ -1,6 +1,6 @@-module Test.Calendar.Duration- ( testDuration- ) where+module Test.Calendar.Duration (+ testDuration,+) where import Data.Time.Calendar import Data.Time.Calendar.Julian@@ -14,22 +14,22 @@ testGroup "add diff" [ testProperty "add diff GregorianDurationClip" $ \day1 day2 ->- addGregorianDurationClip (diffGregorianDurationClip day2 day1) day1 == day2+ addGregorianDurationClip (diffGregorianDurationClip day2 day1) day1 == day2 , testProperty "add diff GregorianDurationRollOver" $ \day1 day2 ->- addGregorianDurationRollOver (diffGregorianDurationRollOver day2 day1) day1 == day2+ addGregorianDurationRollOver (diffGregorianDurationRollOver day2 day1) day1 == day2 , testProperty "add diff JulianDurationClip" $ \day1 day2 ->- addJulianDurationClip (diffJulianDurationClip day2 day1) day1 == day2+ addJulianDurationClip (diffJulianDurationClip day2 day1) day1 == day2 , testProperty "add diff JulianDurationRollOver" $ \day1 day2 ->- addJulianDurationRollOver (diffJulianDurationRollOver day2 day1) day1 == day2+ addJulianDurationRollOver (diffJulianDurationRollOver day2 day1) day1 == day2 ] testClip :: (Integer, Int, Int) -> (Integer, Int, Int) -> (Integer, Integer) -> TestTree-testClip (y1, m1, d1) (y2, m2, d2) (em, ed) = let- day1 = fromGregorian y1 m1 d1- day2 = fromGregorian y2 m2 d2- expected = CalendarDiffDays em ed- found = diffGregorianDurationClip day1 day2- in testCase (show day1 ++ " - " ++ show day2) $ assertEqual "" expected found+testClip (y1, m1, d1) (y2, m2, d2) (em, ed) =+ let day1 = fromGregorian y1 m1 d1+ day2 = fromGregorian y2 m2 d2+ expected = CalendarDiffDays em ed+ found = diffGregorianDurationClip day1 day2+ in testCase (show day1 ++ " - " ++ show day2) $ assertEqual "" expected found testDiffs :: TestTree testDiffs =
test/main/Test/Calendar/Easter.hs view
@@ -1,11 +1,10 @@-module Test.Calendar.Easter- ( testEaster- ) where+module Test.Calendar.Easter (+ testEaster,+) where import Data.Time.Calendar import Data.Time.Calendar.Easter import Data.Time.Format- import Test.Calendar.EasterRef import Test.Tasty import Test.Tasty.HUnit@@ -19,20 +18,20 @@ 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]
test/main/Test/Calendar/LongWeekYears.hs view
@@ -1,6 +1,6 @@-module Test.Calendar.LongWeekYears- ( longWeekYears- ) where+module Test.Calendar.LongWeekYears (+ longWeekYears,+) where import Data.Time.Calendar import Data.Time.Calendar.WeekDate@@ -18,12 +18,14 @@ showLongYear year = unwords [ show year ++ ":"- , (if isLeapYear year- then "L"- else " ") ++- (if longYear year- then "*"- else " ")+ , ( if isLeapYear year+ then "L"+ else " "+ )+ ++ ( if longYear year+ then "*"+ else " "+ ) ] longWeekYears :: TestTree
test/main/Test/Calendar/MonthDay.hs view
@@ -1,6 +1,6 @@-module Test.Calendar.MonthDay- ( testMonthDay- ) where+module Test.Calendar.MonthDay (+ testMonthDay,+) where import Data.Time.Calendar.MonthDay import Test.Calendar.MonthDayRef@@ -15,7 +15,7 @@ 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@@ -23,9 +23,10 @@ else "Regular:" yearDays isLeap = map- (\yd -> let- (m, d) = dayOfYearToMonthAndDay isLeap yd- yd' = monthAndDayToDayOfYear isLeap m d- mdtext = show m ++ "-" ++ show d- in showCompare yd mdtext yd')+ ( \yd ->+ let (m, d) = dayOfYearToMonthAndDay isLeap yd+ yd' = monthAndDayToDayOfYear isLeap m d+ mdtext = show m ++ "-" ++ show d+ in showCompare yd mdtext yd'+ ) [-2 .. 369]
+ test/main/Test/Calendar/MonthOfYear.hs view
@@ -0,0 +1,26 @@+module Test.Calendar.MonthOfYear (+ testMonthOfYear,+) where++import Data.Foldable+import Data.Time.Calendar+import Test.Tasty+import Test.Tasty.HUnit++matchMonthOfYear :: MonthOfYear -> Int+matchMonthOfYear m = case m of+ January -> 1+ February -> 2+ March -> 3+ April -> 4+ May -> 5+ June -> 6+ July -> 7+ August -> 8+ September -> 9+ October -> 10+ November -> 11+ December -> 12++testMonthOfYear :: TestTree+testMonthOfYear = testCase "MonthOfYear" $ for_ [1 .. 12] $ \m -> assertEqual (show m) m $ matchMonthOfYear m
test/main/Test/Calendar/Valid.hs view
@@ -1,6 +1,6 @@-module Test.Calendar.Valid- ( testValid- ) where+module Test.Calendar.Valid (+ testValid,+) where import Data.Time import Data.Time.Calendar.Julian@@ -11,39 +11,45 @@ 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)- => String- -> (s -> c)- -> (t -> c)- -> (c -> t)- -> (c -> Maybe t)- -> TestTree+ (Arbitrary s, Show s, Eq c, Show c, Eq t, Show t) =>+ String ->+ (s -> c) ->+ (t -> c) ->+ (c -> t) ->+ (c -> Maybe t) ->+ TestTree validTest name sc toComponents fromComponents fromComponentsValid = testGroup name@@ -52,54 +58,54 @@ ] 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+newtype WYear+ = MkWYear Year deriving (Eq, Show) instance Arbitrary WYear where arbitrary = fmap MkWYear $ choose (-1000, 3000) -newtype WMonthOfYear =- MkWMonthOfYear MonthOfYear+newtype WMonthOfYear+ = MkWMonthOfYear MonthOfYear deriving (Eq, Show) instance Arbitrary WMonthOfYear where arbitrary = fmap MkWMonthOfYear $ choose (-5, 17) -newtype WDayOfMonth =- MkWDayOfMonth DayOfMonth+newtype WDayOfMonth+ = MkWDayOfMonth DayOfMonth deriving (Eq, Show) instance Arbitrary WDayOfMonth where arbitrary = fmap MkWDayOfMonth $ choose (-5, 35) -newtype WDayOfYear =- MkWDayOfYear DayOfYear+newtype WDayOfYear+ = MkWDayOfYear DayOfYear deriving (Eq, Show) instance Arbitrary WDayOfYear where arbitrary = fmap MkWDayOfYear $ choose (-20, 400) -newtype WWeekOfYear =- MkWWeekOfYear WeekOfYear+newtype WWeekOfYear+ = MkWWeekOfYear WeekOfYear deriving (Eq, Show) instance Arbitrary WWeekOfYear where arbitrary = fmap MkWWeekOfYear $ choose (-5, 60) -newtype WDayOfWeek =- MkWDayOfWeek Int+newtype WDayOfWeek+ = MkWDayOfWeek Int deriving (Eq, Show) instance Arbitrary WDayOfWeek where@@ -119,34 +125,34 @@ testGroup "testValid" [ validTest- "Gregorian"- fromYMD- toGregorian- (\(y, m, d) -> fromGregorian y m d)- (\(y, m, d) -> fromGregorianValid y m d)+ "Gregorian"+ fromYMD+ toGregorian+ (\(y, m, d) -> fromGregorian y m d)+ (\(y, m, d) -> fromGregorianValid y m d) , validTest- "OrdinalDate"- fromYD- toOrdinalDate- (\(y, d) -> fromOrdinalDate y d)- (\(y, d) -> fromOrdinalDateValid y d)+ "OrdinalDate"+ fromYD+ toOrdinalDate+ (\(y, d) -> fromOrdinalDate y d)+ (\(y, d) -> fromOrdinalDateValid y d) , validTest- "WeekDate"- fromYWD- toWeekDate- (\(y, w, d) -> fromWeekDate y w d)- (\(y, w, d) -> fromWeekDateValid y w d)+ "WeekDate"+ fromYWD+ toWeekDate+ (\(y, w, d) -> fromWeekDate y w d)+ (\(y, w, d) -> fromWeekDateValid y w d) , validTest- "SundayStartWeek"- fromYWD- toSundayStartWeek- (\(y, w, d) -> fromSundayStartWeek y w d)- (\(y, w, d) -> fromSundayStartWeekValid y w d)+ "SundayStartWeek"+ fromYWD+ toSundayStartWeek+ (\(y, w, d) -> fromSundayStartWeek y w d)+ (\(y, w, d) -> fromSundayStartWeekValid y w d) , validTest- "MondayStartWeek"- fromYWD- toMondayStartWeek- (\(y, w, d) -> fromMondayStartWeek y w d)- (\(y, w, d) -> fromMondayStartWeekValid y w d)+ "MondayStartWeek"+ fromYWD+ toMondayStartWeek+ (\(y, w, d) -> fromMondayStartWeek y w d)+ (\(y, w, d) -> fromMondayStartWeekValid y w d) , validTest "Julian" fromYMD toJulian (\(y, m, d) -> fromJulian y m d) (\(y, m, d) -> fromJulianValid y m d) ]
test/main/Test/Calendar/Week.hs view
@@ -1,14 +1,14 @@-module Test.Calendar.Week- ( testWeek- ) where+module Test.Calendar.Week (+ testWeek,+) where import Data.Time.Calendar import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.WeekDate-import Test.TestUtil+import Test.Arbitrary () import Test.Tasty import Test.Tasty.HUnit-import Test.Arbitrary ()+import Test.TestUtil testDay :: TestTree testDay =@@ -37,56 +37,56 @@ [ nameTest "[Monday .. Sunday]" $ assertEqual "" allDaysOfWeek [Monday .. Sunday] , nameTest "[Wednesday .. Wednesday]" $ assertEqual "" [Wednesday] [Wednesday .. Wednesday] , nameTest "[Sunday .. Saturday]" $- assertEqual "" [Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday] [Sunday .. Saturday]+ assertEqual "" [Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday] [Sunday .. Saturday] , nameTest "[Thursday .. Wednesday]" $- assertEqual "" [Thursday, Friday, Saturday, Sunday, Monday, Tuesday, Wednesday] [Thursday .. Wednesday]+ assertEqual "" [Thursday, Friday, Saturday, Sunday, Monday, Tuesday, Wednesday] [Thursday .. Wednesday] , nameTest "[Tuesday ..]" $- assertEqual- ""- [ Tuesday- , Wednesday- , Thursday- , Friday- , Saturday- , Sunday- , Monday- , Tuesday- , Wednesday- , Thursday- , Friday- , Saturday- , Sunday- , Monday- , Tuesday- ] $- take 15 [Tuesday ..]+ assertEqual+ ""+ [ Tuesday+ , Wednesday+ , Thursday+ , Friday+ , Saturday+ , Sunday+ , Monday+ , Tuesday+ , Wednesday+ , Thursday+ , Friday+ , Saturday+ , Sunday+ , Monday+ , Tuesday+ ]+ $ take 15 [Tuesday ..] , nameTest "[Wednesday, Tuesday ..]" $- assertEqual- ""- [ Wednesday- , Tuesday- , Monday- , Sunday- , Saturday- , Friday- , Thursday- , Wednesday- , Tuesday- , Monday- , Sunday- , Saturday- , Friday- , Thursday- , Wednesday- ] $- take 15 [Wednesday,Tuesday ..]+ assertEqual+ ""+ [ Wednesday+ , Tuesday+ , Monday+ , Sunday+ , Saturday+ , Friday+ , Thursday+ , Wednesday+ , Tuesday+ , Monday+ , Sunday+ , Saturday+ , Friday+ , Thursday+ , Wednesday+ ]+ $ take 15 [Wednesday, Tuesday ..] , nameTest "[Sunday, Friday ..]" $- assertEqual "" [Sunday, Friday, Wednesday, Monday, Saturday, Thursday, Tuesday, Sunday] $- take 8 [Sunday,Friday ..]+ assertEqual "" [Sunday, Friday, Wednesday, Monday, Saturday, Thursday, Tuesday, Sunday] $+ take 8 [Sunday, Friday ..] , nameTest "[Monday,Sunday .. Tuesday]" $- assertEqual "" [Monday, Sunday, Saturday, Friday, Thursday, Wednesday, Tuesday] [Monday,Sunday .. Tuesday]+ assertEqual "" [Monday, Sunday, Saturday, Friday, Thursday, Wednesday, Tuesday] [Monday, Sunday .. Tuesday] , nameTest "[Thursday, Saturday .. Tuesday]" $- assertEqual "" [Thursday, Saturday, Monday, Wednesday, Friday, Sunday, Tuesday] [Thursday,Saturday .. Tuesday]+ assertEqual "" [Thursday, Saturday, Monday, Wednesday, Friday, Sunday, Tuesday] [Thursday, Saturday .. Tuesday] ] testReadShow :: TestTree@@ -99,40 +99,41 @@ 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 = nameTest "diff"- [- nameTest "Friday - Tuesday" $ assertEqual "" 3 $ dayOfWeekDiff Friday Tuesday,- nameTest "Tuesday - Friday" $ assertEqual "" 4 $ dayOfWeekDiff Tuesday Friday,- nameTest "firstDayOfWeekOnAfter_onAfter" prop_firstDayOfWeekOnAfter_onAfter,- nameTest "firstDayOfWeekOnAfter_Day" prop_firstDayOfWeekOnAfter_Day,- nameTest "toFromWeekCalendar" prop_toFromWeekCalendar,- nameTest "weekChanges" prop_weekChanges,- nameTest "weekYearWholeStart" prop_weekYearWholeStart,- nameTest "weekYearMostStart" prop_weekYearMostStart- ]+testDiff =+ nameTest+ "diff"+ [ nameTest "Friday - Tuesday" $ assertEqual "" 3 $ dayOfWeekDiff Friday Tuesday+ , nameTest "Tuesday - Friday" $ assertEqual "" 4 $ dayOfWeekDiff Tuesday Friday+ , nameTest "firstDayOfWeekOnAfter_onAfter" prop_firstDayOfWeekOnAfter_onAfter+ , nameTest "firstDayOfWeekOnAfter_Day" prop_firstDayOfWeekOnAfter_Day+ , nameTest "toFromWeekCalendar" prop_toFromWeekCalendar+ , nameTest "weekChanges" prop_weekChanges+ , nameTest "weekYearWholeStart" prop_weekYearWholeStart+ , nameTest "weekYearMostStart" prop_weekYearMostStart+ ] testWeek :: TestTree testWeek = nameTest "Week" [testDay, testSucc, testPred, testSequences, testReadShow, testDiff]
test/main/Test/Clock/Conversion.hs view
@@ -1,6 +1,6 @@-module Test.Clock.Conversion- ( testClockConversion- ) where+module Test.Clock.Conversion (+ testClockConversion,+) where import Data.Time.Clock import Data.Time.Clock.System@@ -9,17 +9,17 @@ 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+ 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) ]- 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)- ]
test/main/Test/Clock/Resolution.hs view
@@ -1,6 +1,6 @@-module Test.Clock.Resolution- ( testResolutions- ) where+module Test.Clock.Resolution (+ testResolutions,+) where import Control.Concurrent import Data.Fixed@@ -24,7 +24,7 @@ gcdAll = foldr gcd' 0 testResolution :: (Show dt, Real dt) => String -> (at -> at -> dt) -> (dt, IO at) -> TestTree-testResolution name timeDiff (res, getTime) =+testResolution name timeDiff (reportedRes, getTime) = testCase name $ do t0 <- getTime times0 <-@@ -33,31 +33,32 @@ getTime times1 <- repeatN 100 $ -- 100us- do- threadDelay 1 -- 1us- getTime+ do+ threadDelay 1 -- 1us+ getTime times2 <- repeatN 100 $ -- 1ms- do- threadDelay 10 -- 10us- getTime+ do+ threadDelay 10 -- 10us+ getTime times3 <- repeatN 100 $ -- 10ms- do- threadDelay 100 -- 100us- getTime+ do+ threadDelay 100 -- 100us+ getTime times4 <- repeatN 100 $ -- 100ms- do- threadDelay 1000 -- 1ms- getTime+ do+ threadDelay 1000 -- 1ms+ getTime let times = fmap (\t -> timeDiff t t0) $ times0 ++ times1 ++ times2 ++ times3 ++ times4- assertEqual "resolution" res $ gcdAll times+ foundGrid = gcdAll times+ assertBool ("reported resolution: " <> show reportedRes <> ", found: " <> show foundGrid) $ foundGrid <= reportedRes testResolutions :: TestTree testResolutions = testGroup "resolution" $- [testResolution "getCurrentTime" diffUTCTime (realToFrac getTime_resolution, getCurrentTime)] ++- case taiClock of- Just clock -> [testResolution "taiClock" diffAbsoluteTime clock]- Nothing -> []+ [testResolution "getCurrentTime" diffUTCTime (realToFrac getTime_resolution, getCurrentTime)]+ ++ case taiClock of+ Just clock -> [testResolution "taiClock" diffAbsoluteTime clock]+ Nothing -> []
test/main/Test/Clock/TAI.hs view
@@ -1,6 +1,6 @@-module Test.Clock.TAI- ( testTAI- ) where+module Test.Clock.TAI (+ testTAI,+) where import Data.Time import Data.Time.Clock.TAI@@ -19,40 +19,40 @@ 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- assertEqual "dayA" (Just 10) $ sampleLeapSecondMap dayA- assertEqual "dayB" (Just 11) $ sampleLeapSecondMap dayB- , testCase "day length" $ do- assertEqual "dayA" (Just 86401) $ utcDayLength sampleLeapSecondMap dayA- assertEqual "dayB" (Just 86400) $ utcDayLength sampleLeapSecondMap dayB- , 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- "round-trip"- [ testCase "1" $ do- absTime <- assertJust mAbsTime1- utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime- assertEqual "round-trip" utcTime1 utcTime- , testCase "2" $ do- absTime <- assertJust mAbsTime2- utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime- assertEqual "round-trip" utcTime2 utcTime- , testCase "3" $ do- absTime <- assertJust mAbsTime3- utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime- assertEqual "round-trip" utcTime3 utcTime- ]- ]+ 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+ assertEqual "dayA" (Just 86401) $ utcDayLength sampleLeapSecondMap dayA+ assertEqual "dayB" (Just 86400) $ utcDayLength sampleLeapSecondMap dayB+ , 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+ "round-trip"+ [ testCase "1" $ do+ absTime <- assertJust mAbsTime1+ utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime+ assertEqual "round-trip" utcTime1 utcTime+ , testCase "2" $ do+ absTime <- assertJust mAbsTime2+ utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime+ assertEqual "round-trip" utcTime2 utcTime+ , testCase "3" $ do+ absTime <- assertJust mAbsTime3+ utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime+ assertEqual "round-trip" utcTime3 utcTime+ ]+ ]
test/main/Test/Format/Compile.hs view
@@ -1,16 +1,15 @@ -- Tests succeed if module compiles {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Test.Format.Compile- (+module Test.Format.Compile ( ) where import Data.Time -newtype WrappedUTCTime =- MkWrappedUTCTime UTCTime+newtype WrappedUTCTime+ = MkWrappedUTCTime UTCTime deriving (FormatTime, ParseTime) -newtype Wrapped t =- MkWrapped t+newtype Wrapped t+ = MkWrapped t deriving (FormatTime, ParseTime)
test/main/Test/Format/Format.hs view
@@ -1,6 +1,6 @@-module Test.Format.Format- ( testFormat- ) where+module Test.Format.Format (+ testFormat,+) where import Data.Proxy import Data.Time@@ -25,12 +25,13 @@ formats :: [String] formats =- ["%G-W%V-%u", "%U-%w", "%W-%u"] ++- (fmap (\char -> '%' : [char]) chars) ++- (concat $- fmap- (\char -> concat $ fmap (\width -> fmap (\modifier -> "%" ++ [modifier] ++ width ++ [char]) modifiers) widths)- chars)+ ["%G-W%V-%u", "%U-%w", "%W-%u"]+ ++ (fmap (\char -> '%' : [char]) chars)+ ++ ( concat $+ fmap+ (\char -> concat $ fmap (\width -> fmap (\modifier -> "%" ++ [modifier] ++ width ++ [char]) modifiers) widths)+ chars+ ) somestrings :: [String] somestrings = ["", " ", "-", "\n"]@@ -38,8 +39,7 @@ compareExpected :: (Eq t, Show t, ParseTime t) => String -> String -> String -> Proxy t -> TestTree compareExpected testname fmt str proxy = testCase testname $ do- let- found :: ParseTime t => Proxy t -> Maybe t+ let found :: ParseTime t => Proxy t -> Maybe t found _ = parseTimeM False defaultTimeLocale fmt str assertEqual "" Nothing $ found proxy @@ -61,11 +61,11 @@ 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 "uwaA" $ \fmt ->+ 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 =@@ -116,17 +116,17 @@ , testAFormat "%dd %hh %mm %ss %Ess" "0d 0h 0m 0s 0.74s" $ (fromRational $ 0.74 :: NominalDiffTime) , testAFormat "%dd %hh %mm %ss %Ess" "0d 0h 0m 0s -0.74s" $ (fromRational $ negate $ 0.74 :: NominalDiffTime) , testAFormat "%dd %hh %mm %ss %Ess %0Ess" "23d 554h 33262m 1995728s 1995728.21s 1995728.210000000000s" $- (fromRational $ 23 * 86400 + 8528.21 :: NominalDiffTime)+ (fromRational $ 23 * 86400 + 8528.21 :: NominalDiffTime) , testAFormat "%ww%Dd%Hh%Mm%Ss" "-3w-2d-2h-22m-8s" $- (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime)+ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime) , testAFormat "%ww%Dd%Hh%Mm%ESs" "-3w-2d-2h-22m-8.21s" $- (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime)+ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime) , testAFormat "%ww%Dd%Hh%Mm%Ss" "-3w-2d-2h-22m0s" $- (fromRational $ negate $ 23 * 86400 + 8520.21 :: NominalDiffTime)+ (fromRational $ negate $ 23 * 86400 + 8520.21 :: NominalDiffTime) , testAFormat "%ww%Dd%Hh%Mm%ESs" "-3w-2d-2h-22m-0.21s" $- (fromRational $ negate $ 23 * 86400 + 8520.21 :: NominalDiffTime)+ (fromRational $ negate $ 23 * 86400 + 8520.21 :: NominalDiffTime) , testAFormat "%dd %hh %mm %Ess" "-23d -554h -33262m -1995728.21s" $- (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime)+ (fromRational $ negate $ 23 * 86400 + 8528.21 :: NominalDiffTime) , testAFormat "%3Es" "1.200" (1.2 :: NominalDiffTime) , testAFormat "%3ES" "01.200" (1.2 :: NominalDiffTime) , testAFormat "%3ES" "01.200" (61.2 :: NominalDiffTime)@@ -143,15 +143,15 @@ , testAFormat "%dd %hh %mm %ss %Ess" "0d 0h 0m 0s 0.74s" $ (fromRational $ 0.74 :: DiffTime) , testAFormat "%dd %hh %mm %ss %Ess" "0d 0h 0m 0s -0.74s" $ (fromRational $ negate $ 0.74 :: DiffTime) , testAFormat "%dd %hh %mm %ss %Ess %0Ess" "23d 554h 33262m 1995728s 1995728.21s 1995728.210000000000s" $- (fromRational $ 23 * 86400 + 8528.21 :: DiffTime)+ (fromRational $ 23 * 86400 + 8528.21 :: DiffTime) , testAFormat "%ww%Dd%Hh%Mm%Ss" "-3w-2d-2h-22m-8s" $ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime) , testAFormat "%ww%Dd%Hh%Mm%ESs" "-3w-2d-2h-22m-8.21s" $- (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime)+ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime) , testAFormat "%ww%Dd%Hh%Mm%Ss" "-3w-2d-2h-22m0s" $ (fromRational $ negate $ 23 * 86400 + 8520.21 :: DiffTime) , testAFormat "%ww%Dd%Hh%Mm%ESs" "-3w-2d-2h-22m-0.21s" $- (fromRational $ negate $ 23 * 86400 + 8520.21 :: DiffTime)+ (fromRational $ negate $ 23 * 86400 + 8520.21 :: DiffTime) , testAFormat "%dd %hh %mm %Ess" "-23d -554h -33262m -1995728.21s" $- (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime)+ (fromRational $ negate $ 23 * 86400 + 8528.21 :: DiffTime) , testAFormat "%3Es" "1.200" (1.2 :: DiffTime) , testAFormat "%3ES" "01.200" (1.2 :: DiffTime) , testAFormat "%3ES" "01.200" (61.2 :: DiffTime)@@ -177,25 +177,25 @@ [ 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 testFormat = testGroup "testFormat" $- [ testCheckParse- , testDayOfWeek- , testTimeZone- , testNominalDiffTime- , testDiffTime- , testCalenderDiffDays- , testCalenderDiffTime- ]+ [ testCheckParse+ , testDayOfWeek+ , testTimeZone+ , testNominalDiffTime+ , testDiffTime+ , testCalenderDiffDays+ , testCalenderDiffTime+ ]
test/main/Test/Format/ISO8601.hs view
@@ -1,12 +1,13 @@ {-# OPTIONS -fno-warn-orphans #-} -module Test.Format.ISO8601- ( testISO8601- ) where+module Test.Format.ISO8601 (+ testISO8601,+) where import Data.Ratio import Data.Time import Data.Time.Format.ISO8601+import Data.Time.Format.Internal import Test.Arbitrary () import Test.QuickCheck.Property import Test.Tasty@@ -20,22 +21,35 @@ readShowProperty fmt val = case formatShowM fmt val of Nothing -> property Discard- Just str -> let- found = formatParseM fmt str- expected = Just val- in property $- if expected == found- then succeeded- else failed {reason = show str ++ ": expected " ++ (show expected) ++ ", found " ++ (show found)}+ Just str ->+ let found = formatParseM fmt str+ expected = Just val+ in property $+ if expected == found+ then succeeded+ else failed{reason = show str ++ ": expected " ++ (show expected) ++ ", found " ++ (show found)} +class SpecialTestValues a where+ -- | values that should always be tested+ specialTestValues :: [a]++instance {-# OVERLAPPABLE #-} SpecialTestValues a where+ specialTestValues = []++instance SpecialTestValues TimeOfDay where+ specialTestValues = [TimeOfDay 0 0 0, TimeOfDay 24 0 0]++readShowTest :: (Eq a, Show a, Arbitrary a, SpecialTestValues a) => Format a -> [TestTree]+readShowTest fmt = [nameTest "random" $ readShowProperty fmt, nameTest "special" $ fmap (\a -> nameTest (show a) $ readShowProperty fmt a) specialTestValues]+ readBoth :: NameTest t => (FormatExtension -> t) -> [TestTree] readBoth fmts = [nameTest "extended" $ fmts ExtendedFormat, nameTest "basic" $ fmts BasicFormat] -readShowProperties :: (Eq a, Show a, Arbitrary a) => (FormatExtension -> Format a) -> [TestTree]-readShowProperties fmts = readBoth $ \fe -> readShowProperty $ fmts fe+readShowTests :: (Eq a, Show a, Arbitrary a, SpecialTestValues a) => (FormatExtension -> Format a) -> [TestTree]+readShowTests fmts = readBoth $ \fe -> readShowTest $ fmts fe -newtype Durational t =- MkDurational t+newtype Durational t = MkDurational {unDurational :: t}+ deriving (Eq) instance Show t => Show (Durational t) where show (MkDurational t) = show t@@ -47,59 +61,62 @@ 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)+ testReadShowFormat :: TestTree testReadShowFormat = nameTest "read-show format"- [ nameTest "calendarFormat" $ readShowProperties $ calendarFormat- , nameTest "yearMonthFormat" $ readShowProperty $ yearMonthFormat- , nameTest "yearFormat" $ readShowProperty $ yearFormat- , nameTest "centuryFormat" $ readShowProperty $ centuryFormat- , nameTest "expandedCalendarFormat" $ readShowProperties $ expandedCalendarFormat 6- , nameTest "expandedYearMonthFormat" $ readShowProperty $ expandedYearMonthFormat 6- , nameTest "expandedYearFormat" $ readShowProperty $ expandedYearFormat 6- , nameTest "expandedCenturyFormat" $ readShowProperty $ expandedCenturyFormat 4- , nameTest "ordinalDateFormat" $ readShowProperties $ ordinalDateFormat- , nameTest "expandedOrdinalDateFormat" $ readShowProperties $ expandedOrdinalDateFormat 6- , nameTest "weekDateFormat" $ readShowProperties $ weekDateFormat- , nameTest "yearWeekFormat" $ readShowProperties $ yearWeekFormat- , nameTest "expandedWeekDateFormat" $ readShowProperties $ expandedWeekDateFormat 6- , nameTest "expandedYearWeekFormat" $ readShowProperties $ expandedYearWeekFormat 6- , nameTest "timeOfDayFormat" $ readShowProperties $ timeOfDayFormat- , nameTest "hourMinuteFormat" $ readShowProperties $ hourMinuteFormat- , nameTest "hourFormat" $ readShowProperty $ hourFormat- , nameTest "withTimeDesignator" $ readShowProperties $ \fe -> withTimeDesignator $ timeOfDayFormat fe- , nameTest "withUTCDesignator" $ readShowProperties $ \fe -> withUTCDesignator $ timeOfDayFormat fe- , nameTest "timeOffsetFormat" $ readShowProperties $ timeOffsetFormat- , nameTest "timeOfDayAndOffsetFormat" $ readShowProperties $ timeOfDayAndOffsetFormat+ [ nameTest "calendarFormat" $ readShowTests $ calendarFormat+ , nameTest "yearMonthFormat" $ readShowTest $ yearMonthFormat+ , nameTest "yearFormat" $ readShowTest $ yearFormat+ , nameTest "centuryFormat" $ readShowTest $ centuryFormat+ , nameTest "expandedCalendarFormat" $ readShowTests $ expandedCalendarFormat 6+ , nameTest "expandedYearMonthFormat" $ readShowTest $ expandedYearMonthFormat 6+ , nameTest "expandedYearFormat" $ readShowTest $ expandedYearFormat 6+ , nameTest "expandedCenturyFormat" $ readShowTest $ expandedCenturyFormat 4+ , nameTest "ordinalDateFormat" $ readShowTests $ ordinalDateFormat+ , nameTest "expandedOrdinalDateFormat" $ readShowTests $ expandedOrdinalDateFormat 6+ , nameTest "weekDateFormat" $ readShowTests $ weekDateFormat+ , nameTest "yearWeekFormat" $ readShowTests $ yearWeekFormat+ , nameTest "expandedWeekDateFormat" $ readShowTests $ expandedWeekDateFormat 6+ , nameTest "expandedYearWeekFormat" $ readShowTests $ expandedYearWeekFormat 6+ , nameTest "timeOfDayFormat" $ readShowTests $ timeOfDayFormat+ , nameTest "hourMinuteFormat" $ readShowTests $ hourMinuteFormat+ , nameTest "hourFormat" $ readShowTest $ hourFormat+ , nameTest "withTimeDesignator" $ readShowTests $ \fe -> withTimeDesignator $ timeOfDayFormat fe+ , nameTest "withUTCDesignator" $ readShowTests $ \fe -> withUTCDesignator $ timeOfDayFormat fe+ , nameTest "timeOffsetFormat" $ readShowTests $ timeOffsetFormat+ , nameTest "timeOfDayAndOffsetFormat" $ readShowTests $ timeOfDayAndOffsetFormat , nameTest "localTimeFormat" $- readShowProperties $ \fe -> localTimeFormat (calendarFormat fe) (timeOfDayFormat fe)+ readShowTests $ \fe -> localTimeFormat (calendarFormat fe) (timeOfDayFormat fe) , nameTest "zonedTimeFormat" $- readShowProperties $ \fe -> zonedTimeFormat (calendarFormat fe) (timeOfDayFormat fe) fe- , nameTest "utcTimeFormat" $ readShowProperties $ \fe -> utcTimeFormat (calendarFormat fe) (timeOfDayFormat fe)+ readShowTests $ \fe -> zonedTimeFormat (calendarFormat fe) (timeOfDayFormat fe) fe+ , nameTest "utcTimeFormat" $ readShowTests $ \fe -> utcTimeFormat (calendarFormat fe) (timeOfDayFormat fe) , nameTest "dayAndTimeFormat" $- readShowProperties $ \fe -> dayAndTimeFormat (calendarFormat fe) (timeOfDayFormat fe)- , nameTest "timeAndOffsetFormat" $ readShowProperties $ \fe -> timeAndOffsetFormat (timeOfDayFormat fe) fe- , nameTest "durationDaysFormat" $ readShowProperty $ durationDaysFormat- , nameTest "durationTimeFormat" $ readShowProperty $ durationTimeFormat+ 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 (MkDurational t) -> readShowProperty (alternativeDurationDaysFormat fe) t+ readBoth $ \fe -> readShowTest (durationalFormat $ alternativeDurationDaysFormat fe) , nameTest "alternativeDurationTimeFormat" $- readBoth $ \fe (MkDurational t) -> readShowProperty (alternativeDurationTimeFormat fe) t+ readBoth $ \fe -> readShowTest (durationalFormat $ alternativeDurationTimeFormat fe) , nameTest "intervalFormat" $- readShowProperties $ \fe ->- intervalFormat (localTimeFormat (calendarFormat fe) (timeOfDayFormat fe)) durationTimeFormat+ readShowTests $ \fe ->+ intervalFormat (localTimeFormat (calendarFormat fe) (timeOfDayFormat fe)) durationTimeFormat , nameTest "recurringIntervalFormat" $- readShowProperties $ \fe ->- recurringIntervalFormat (localTimeFormat (calendarFormat fe) (timeOfDayFormat fe)) durationTimeFormat+ readShowTests $ \fe ->+ recurringIntervalFormat (localTimeFormat (calendarFormat fe) (timeOfDayFormat fe)) durationTimeFormat ] testShowFormat :: String -> Format t -> String -> t -> TestTree@@ -125,57 +142,61 @@ , testShowFormat "durationTimeFormat" durationTimeFormat "PT1M18.77634S" $ CalendarDiffTime 0 $ 78.77634 , testShowFormat "durationTimeFormat" durationTimeFormat "PT2H1M18.77634S" $ CalendarDiffTime 0 $ 7278.77634 , testShowFormat "durationTimeFormat" durationTimeFormat "P5DT2H1M18.77634S" $- CalendarDiffTime 0 $ 5 * nominalDay + 7278.77634+ CalendarDiffTime 0 $ 5 * nominalDay + 7278.77634 , testShowFormat "durationTimeFormat" durationTimeFormat "P7Y10M5DT2H1M18.77634S" $- CalendarDiffTime 94 $ 5 * nominalDay + 7278.77634+ CalendarDiffTime 94 $ 5 * nominalDay + 7278.77634 , testShowFormat "durationTimeFormat" durationTimeFormat "P7Y10MT2H1M18.77634S" $- CalendarDiffTime 94 $ 7278.77634+ CalendarDiffTime 94 $ 7278.77634 , testShowFormat "durationTimeFormat" durationTimeFormat "P8YT2H1M18.77634S" $ CalendarDiffTime 96 $ 7278.77634 , testShowFormat "alternativeDurationDaysFormat" (alternativeDurationDaysFormat ExtendedFormat) "P0001-00-00" $- CalendarDiffDays 12 0+ CalendarDiffDays 12 0 , testShowFormat "alternativeDurationDaysFormat" (alternativeDurationDaysFormat ExtendedFormat) "P0002-03-29" $- CalendarDiffDays 27 29+ CalendarDiffDays 27 29 , testShowFormat "alternativeDurationDaysFormat" (alternativeDurationDaysFormat ExtendedFormat) "P0561-08-29" $- CalendarDiffDays (561 * 12 + 8) 29+ CalendarDiffDays (561 * 12 + 8) 29 , testShowFormat- "alternativeDurationTimeFormat"- (alternativeDurationTimeFormat ExtendedFormat)- "P0000-00-01T00:00:00" $- CalendarDiffTime 0 86400+ "alternativeDurationTimeFormat"+ (alternativeDurationTimeFormat ExtendedFormat)+ "P0000-00-01T00:00:00"+ $ CalendarDiffTime 0 86400 , testShowFormat- "alternativeDurationTimeFormat"- (alternativeDurationTimeFormat ExtendedFormat)- "P0007-10-05T02:01:18.77634" $- CalendarDiffTime 94 $ 5 * nominalDay + 7278.77634+ "alternativeDurationTimeFormat"+ (alternativeDurationTimeFormat ExtendedFormat)+ "P0007-10-05T02:01:18.77634"+ $ CalendarDiffTime 94 $ 5 * nominalDay + 7278.77634 , testShowFormat- "alternativeDurationTimeFormat"- (alternativeDurationTimeFormat ExtendedFormat)- "P4271-10-05T02:01:18.77634" $- CalendarDiffTime (12 * 4271 + 10) $ 5 * nominalDay + 7278.77634+ "alternativeDurationTimeFormat"+ (alternativeDurationTimeFormat ExtendedFormat)+ "P4271-10-05T02:01:18.77634"+ $ CalendarDiffTime (12 * 4271 + 10) $ 5 * nominalDay + 7278.77634 , testShowFormat "centuryFormat" centuryFormat "02" 2 , testShowFormat "centuryFormat" centuryFormat "21" 21 , testShowFormat- "intervalFormat etc."- (intervalFormat- (localTimeFormat (calendarFormat ExtendedFormat) (timeOfDayFormat ExtendedFormat))- durationTimeFormat)- "2015-06-13T21:13:56/P1Y2M7DT5H33M2.34S"- ( LocalTime (fromGregorian 2015 6 13) (TimeOfDay 21 13 56)- , CalendarDiffTime 14 $ 7 * nominalDay + 5 * 3600 + 33 * 60 + 2.34)+ "intervalFormat etc."+ ( intervalFormat+ (localTimeFormat (calendarFormat ExtendedFormat) (timeOfDayFormat ExtendedFormat))+ durationTimeFormat+ )+ "2015-06-13T21:13:56/P1Y2M7DT5H33M2.34S"+ ( LocalTime (fromGregorian 2015 6 13) (TimeOfDay 21 13 56)+ , CalendarDiffTime 14 $ 7 * nominalDay + 5 * 3600 + 33 * 60 + 2.34+ ) , testShowFormat- "recurringIntervalFormat etc."- (recurringIntervalFormat- (localTimeFormat (calendarFormat ExtendedFormat) (timeOfDayFormat ExtendedFormat))- durationTimeFormat)- "R74/2015-06-13T21:13:56/P1Y2M7DT5H33M2.34S"- ( 74- , LocalTime (fromGregorian 2015 6 13) (TimeOfDay 21 13 56)- , CalendarDiffTime 14 $ 7 * nominalDay + 5 * 3600 + 33 * 60 + 2.34)+ "recurringIntervalFormat etc."+ ( recurringIntervalFormat+ (localTimeFormat (calendarFormat ExtendedFormat) (timeOfDayFormat ExtendedFormat))+ durationTimeFormat+ )+ "R74/2015-06-13T21:13:56/P1Y2M7DT5H33M2.34S"+ ( 74+ , LocalTime (fromGregorian 2015 6 13) (TimeOfDay 21 13 56)+ , CalendarDiffTime 14 $ 7 * nominalDay + 5 * 3600 + 33 * 60 + 2.34+ ) , testShowFormat- "recurringIntervalFormat etc."- (recurringIntervalFormat (calendarFormat ExtendedFormat) durationDaysFormat)- "R74/2015-06-13/P1Y2M7D"- (74, fromGregorian 2015 6 13, CalendarDiffDays 14 7)+ "recurringIntervalFormat etc."+ (recurringIntervalFormat (calendarFormat ExtendedFormat) durationDaysFormat)+ "R74/2015-06-13/P1Y2M7D"+ (74, fromGregorian 2015 6 13, CalendarDiffDays 14 7) , testShowFormat "timeOffsetFormat" iso8601Format "-06:30" (minutesToTimeZone (-390)) , testShowFormat "timeOffsetFormat" iso8601Format "+00:00" (minutesToTimeZone 0) , testShowFormat "timeOffsetFormat" (timeOffsetFormat BasicFormat) "+0000" (minutesToTimeZone 0)@@ -186,31 +207,31 @@ , testShowFormat "timeOffsetFormat" (timeOffsetFormat BasicFormat) "+0135" (minutesToTimeZone 95) , testShowFormat "timeOffsetFormat" (timeOffsetFormat BasicFormat) "-0135" (minutesToTimeZone (-95)) , testShowFormat- "timeOffsetFormat"- (timeOffsetFormat BasicFormat)- "-1100"- (minutesToTimeZone $ negate $ 11 * 60)+ "timeOffsetFormat"+ (timeOffsetFormat BasicFormat)+ "-1100"+ (minutesToTimeZone $ negate $ 11 * 60) , testShowFormat "timeOffsetFormat" (timeOffsetFormat BasicFormat) "+1015" (minutesToTimeZone $ 615) , testShowFormat- "zonedTimeFormat"- iso8601Format- "2024-07-06T08:45:56.553-06:30"- (ZonedTime (LocalTime (fromGregorian 2024 07 06) (TimeOfDay 8 45 56.553)) (minutesToTimeZone (-390)))+ "zonedTimeFormat"+ iso8601Format+ "2024-07-06T08:45:56.553-06:30"+ (ZonedTime (LocalTime (fromGregorian 2024 07 06) (TimeOfDay 8 45 56.553)) (minutesToTimeZone (-390))) , testShowFormat- "zonedTimeFormat"- iso8601Format- "2024-07-06T08:45:56.553+06:30"- (ZonedTime (LocalTime (fromGregorian 2024 07 06) (TimeOfDay 8 45 56.553)) (minutesToTimeZone 390))+ "zonedTimeFormat"+ iso8601Format+ "2024-07-06T08:45:56.553+06:30"+ (ZonedTime (LocalTime (fromGregorian 2024 07 06) (TimeOfDay 8 45 56.553)) (minutesToTimeZone 390)) , testShowFormat- "utcTimeFormat"- iso8601Format- "2024-07-06T08:45:56.553Z"- (UTCTime (fromGregorian 2024 07 06) (timeOfDayToTime $ TimeOfDay 8 45 56.553))+ "utcTimeFormat"+ iso8601Format+ "2024-07-06T08:45:56.553Z"+ (UTCTime (fromGregorian 2024 07 06) (timeOfDayToTime $ TimeOfDay 8 45 56.553)) , testShowFormat- "utcTimeFormat"- iso8601Format- "2028-12-31T23:59:60.9Z"- (UTCTime (fromGregorian 2028 12 31) (timeOfDayToTime $ TimeOfDay 23 59 60.9))+ "utcTimeFormat"+ iso8601Format+ "2028-12-31T23:59:60.9Z"+ (UTCTime (fromGregorian 2028 12 31) (timeOfDayToTime $ TimeOfDay 23 59 60.9)) , testShowFormat "weekDateFormat" (weekDateFormat ExtendedFormat) "1994-W52-7" (fromGregorian 1995 1 1) , testShowFormat "weekDateFormat" (weekDateFormat ExtendedFormat) "1995-W01-1" (fromGregorian 1995 1 2) , testShowFormat "weekDateFormat" (weekDateFormat ExtendedFormat) "1996-W52-7" (fromGregorian 1996 12 29)@@ -221,18 +242,18 @@ , testShowFormat "weekDateFormat" (weekDateFormat ExtendedFormat) "1995-W05-6" (fromGregorian 1995 2 4) , testShowFormat "weekDateFormat" (weekDateFormat BasicFormat) "1995W056" (fromGregorian 1995 2 4) , testShowFormat- "weekDateFormat"- (expandedWeekDateFormat 6 ExtendedFormat)- "+001995-W05-6"- (fromGregorian 1995 2 4)+ "weekDateFormat"+ (expandedWeekDateFormat 6 ExtendedFormat)+ "+001995-W05-6"+ (fromGregorian 1995 2 4) , testShowFormat "weekDateFormat" (expandedWeekDateFormat 6 BasicFormat) "+001995W056" (fromGregorian 1995 2 4) , testShowFormat "ordinalDateFormat" (ordinalDateFormat ExtendedFormat) "1846-235" (fromGregorian 1846 8 23) , testShowFormat "ordinalDateFormat" (ordinalDateFormat BasicFormat) "1844236" (fromGregorian 1844 8 23) , testShowFormat- "ordinalDateFormat"- (expandedOrdinalDateFormat 5 ExtendedFormat)- "+01846-235"- (fromGregorian 1846 8 23)+ "ordinalDateFormat"+ (expandedOrdinalDateFormat 5 ExtendedFormat)+ "+01846-235"+ (fromGregorian 1846 8 23) , testShowFormat "hourMinuteFormat" (hourMinuteFormat ExtendedFormat) "13:17.25" (TimeOfDay 13 17 15) , testShowFormat "hourMinuteFormat" (hourMinuteFormat ExtendedFormat) "01:12.4" (TimeOfDay 1 12 24) , testShowFormat "hourMinuteFormat" (hourMinuteFormat BasicFormat) "1317.25" (TimeOfDay 13 17 15)
test/main/Test/Format/ParseTime.hs view
@@ -1,23 +1,19 @@ {-# OPTIONS -fno-warn-orphans #-} -module Test.Format.ParseTime- ( testParseTime- , test_parse_format- ) where+module Test.Format.ParseTime (+ testParseTime,+ test_parse_format,+) where -#if MIN_VERSION_base(4,11,0)-#else-import Data.Semigroup hiding (option)-#endif import Control.Monad import Data.Char import Data.Maybe import Data.Proxy import Data.Time-import Data.Time.Calendar.OrdinalDate-import Data.Time.Calendar.WeekDate import Data.Time.Calendar.Month+import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.Quarter+import Data.Time.Calendar.WeekDate import Test.Arbitrary () import Test.QuickCheck.Property import Test.Tasty@@ -44,15 +40,15 @@ } 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@@ -69,22 +65,22 @@ 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@@ -133,41 +129,45 @@ extests = testGroup "exhaustive"- ([ makeExhaustiveTest "parse %y" [0 .. 99] parseYY- , makeExhaustiveTest "parse %-C %y 1900s" [0, 1, 50, 99] (parseCYY 19)- , makeExhaustiveTest "parse %-C %y 2000s" [0, 1, 50, 99] (parseCYY 20)- , makeExhaustiveTest "parse %-C %y 1400s" [0, 1, 50, 99] (parseCYY 14)- , makeExhaustiveTest "parse %C %y 0700s" [0, 1, 50, 99] (parseCYY2 7)- , makeExhaustiveTest "parse %-C %y 700s" [0, 1, 50, 99] (parseCYY 7)- , makeExhaustiveTest "parse %-C %y -700s" [0, 1, 50, 99] (parseCYY (-7))- , makeExhaustiveTest "parse %-C %y -70000s" [0, 1, 50, 99] (parseCYY (-70000))- , makeExhaustiveTest "parse %-C %y 10000s" [0, 1, 50, 99] (parseCYY 100)- , makeExhaustiveTest "parse %-C centuries" [20 .. 100] (parseCentury " ")- , makeExhaustiveTest "parse %-C century X" [1, 10, 20, 100] (parseCentury "X")- , makeExhaustiveTest "parse %-C century 2sp" [1, 10, 20, 100] (parseCentury " ")- , makeExhaustiveTest "parse %-C century 5sp" [1, 10, 20, 100] (parseCentury " ")- ] ++- (concat $- fmap- (\y ->- [ (makeExhaustiveTest "parse %Y%m%d" (yearDays y) parseYMD)- , (makeExhaustiveTest "parse %Y %m %d" (yearDays y) parseYearDayD)- , (makeExhaustiveTest "parse %Y %-m %e" (yearDays y) parseYearDayE)- ])- [1, 4, 20, 753, 2000, 2011, 10001, (-1166)]))+ ( [ makeExhaustiveTest "parse %y" [0 .. 99] parseYY+ , makeExhaustiveTest "parse %-C %y 1900s" [0, 1, 50, 99] (parseCYY 19)+ , makeExhaustiveTest "parse %-C %y 2000s" [0, 1, 50, 99] (parseCYY 20)+ , makeExhaustiveTest "parse %-C %y 1400s" [0, 1, 50, 99] (parseCYY 14)+ , makeExhaustiveTest "parse %C %y 0700s" [0, 1, 50, 99] (parseCYY2 7)+ , makeExhaustiveTest "parse %-C %y 700s" [0, 1, 50, 99] (parseCYY 7)+ , makeExhaustiveTest "parse %-C %y -700s" [0, 1, 50, 99] (parseCYY (-7))+ , makeExhaustiveTest "parse %-C %y -70000s" [0, 1, 50, 99] (parseCYY (-70000))+ , makeExhaustiveTest "parse %-C %y 10000s" [0, 1, 50, 99] (parseCYY 100)+ , makeExhaustiveTest "parse %-C centuries" [20 .. 100] (parseCentury " ")+ , makeExhaustiveTest "parse %-C century X" [1, 10, 20, 100] (parseCentury "X")+ , makeExhaustiveTest "parse %-C century 2sp" [1, 10, 20, 100] (parseCentury " ")+ , makeExhaustiveTest "parse %-C century 5sp" [1, 10, 20, 100] (parseCentury " ")+ ]+ ++ ( concat $+ fmap+ ( \y ->+ [ (makeExhaustiveTest "parse %Y%m%d" (yearDays y) parseYMD)+ , (makeExhaustiveTest "parse %Y %m %d" (yearDays y) parseYearDayD)+ , (makeExhaustiveTest "parse %Y %-m %e" (yearDays y) parseYearDayE)+ ]+ )+ [1, 4, 20, 753, 2000, 2011, 10001, (-1166)]+ )+ ) 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. (Eq a, Show a, Read a)- => a- -> String- -> TestTree+ forall a.+ (Eq a, Show a, Read a) =>+ a ->+ String ->+ TestTree readTestsParensSpaces expected target = testGroup target@@ -183,7 +183,6 @@ ] where - readOtherTypesTest :: TestTree readOtherTypesTest = testGroup "read other types" [readTestsParensSpaces (3 :: Integer) "3", readTestsParensSpaces "a" "\"a\""]@@ -193,9 +192,9 @@ testGroup "read times" [ readTestsParensSpaces testDay "1912-07-08"- --readTestsParensSpaces testDay "1912-7-8",- , readTestsParensSpaces testTimeOfDay "08:04:02"- --,readTestsParensSpaces testTimeOfDay "8:4:2"+ , --readTestsParensSpaces testDay "1912-7-8",+ readTestsParensSpaces testTimeOfDay "08:04:02"+ --,readTestsParensSpaces testTimeOfDay "8:4:2" ] where testDay = fromGregorian 1912 7 8@@ -218,8 +217,8 @@ , readsTest [(epoch, " ")] "%m" "01 " , readsTest [(epoch, " ")] " %m" " 01 " , readsTest [(epoch, "")] " %m" " 01"- -- https://ghc.haskell.org/trac/ghc/ticket/9150- , readsTest [(epoch, "")] " %M" " 00"+ , -- https://ghc.haskell.org/trac/ghc/ticket/9150+ readsTest [(epoch, "")] " %M" " 00" , readsTest [(epoch, "")] "%M " "00 " , readsTest [(epoch, "")] "%Q" "" , readsTest [(epoch, " ")] "%Q" " "@@ -231,11 +230,11 @@ ] 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 =@@ -306,17 +305,18 @@ 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@@ -353,29 +353,34 @@ compareResult' :: (Eq a, Show a) => String -> a -> a -> Result compareResult' extra expected found | expected == found = succeeded- | otherwise = failed {reason = "expected " ++ (show expected) ++ ", found " ++ (show found) ++ extra}+ | otherwise = failed{reason = "expected " ++ (show expected) ++ ", found " ++ (show found) ++ extra} compareResult :: (Eq a, Show a) => a -> a -> Result compareResult = compareResult' "" compareParse ::- forall a. (Eq a, Show a, ParseTime a)- => a- -> String- -> String- -> Result+ forall a.+ (Eq a, Show a, ParseTime a) =>+ a ->+ String ->+ String ->+ Result compareParse expected fmt text = compareResult' (", parsing " ++ (show text)) (Just expected) (parse False fmt text) --+ -- * tests for debugging failing cases+ -- 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) --+ -- * show and read+ -- prop_read_show :: (Read a, Show a, Eq a) => a -> Result prop_read_show t = compareResult (Just t) (readMaybe (show t))@@ -387,7 +392,9 @@ prop_read_show_LocalUTC t = compareResult (Just $ localTimeToUTC utc t) (readMaybe (show t)) --+ -- * special show functions+ -- prop_parse_showWeekDate :: Day -> Result prop_parse_showWeekDate d = compareParse d "%G-W%V-%u" (showWeekDate d)@@ -399,19 +406,21 @@ prop_parse_showOrdinalDate d = compareParse d "%Y-%j" (showOrdinalDate d) --+ -- * fromMondayStartWeek and fromSundayStartWeek+ -- 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@@ -435,18 +444,19 @@ -- format t == format (parse (format t)) prop_format_parse_format ::- forall t. (HasFormatCodes t, FormatTime t, ParseTime t)- => Proxy t- -> 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+ forall t.+ (HasFormatCodes t, FormatTime t, ParseTime t) =>+ Proxy t ->+ 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 instance HasFormatCodes Day where allFormatCodes _ = [(False, s) | s <- "DFxYyCBbhmdejfVUW"]@@ -462,8 +472,9 @@ instance HasFormatCodes ZonedTime where allFormatCodes _ =- [(False, s) | s <- "cs"] ++- allFormatCodes (Proxy :: Proxy LocalTime) ++ allFormatCodes (Proxy :: Proxy TimeZone)+ [(False, s) | s <- "cs"]+ ++ allFormatCodes (Proxy :: Proxy LocalTime)+ ++ allFormatCodes (Proxy :: Proxy TimeZone) instance HasFormatCodes UTCTime where allFormatCodes _ = [(False, s) | s <- "cs"] ++ allFormatCodes (Proxy :: Proxy LocalTime)@@ -473,10 +484,12 @@ allFormatCodes _ = allFormatCodes (Proxy :: Proxy LocalTime) --+ -- * crashes in parse+ ---newtype Input =- Input String+newtype Input+ = Input String instance Show Input where show (Input s) = s@@ -493,15 +506,15 @@ prop_no_crash_bad_input :: (Eq t, ParseTime t) => FormatString t -> Input -> Property prop_no_crash_bad_input fs@(FormatString f) (Input s) = property $- case parse False f s of- Nothing -> True- Just t -> t == t `asTypeOf` formatType fs+ case parse False f s of+ Nothing -> True+ Just t -> t == t `asTypeOf` formatType fs -- -- ---newtype FormatString a =- FormatString String+newtype FormatString a+ = FormatString String formatType :: FormatString t -> t formatType _ = undefined@@ -518,7 +531,7 @@ , 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@@ -528,8 +541,8 @@ ] allTypes ::- (forall t. (Eq t, Show t, Arbitrary t, FormatTime t, ParseTime t, HasFormatCodes t) => String -> Proxy t -> r)- -> [r]+ (forall t. (Eq t, Show t, Arbitrary t, FormatTime t, ParseTime t, HasFormatCodes t) => String -> Proxy t -> r) ->+ [r] allTypes f = [ f "Day" (Proxy :: Proxy Day) , f "TimeOfDay" (Proxy :: Proxy TimeOfDay)@@ -541,30 +554,30 @@ ] 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- ]+ (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+ ] parseEmptyTest ::- forall t. ParseTime t- => Proxy t- -> Assertion+ forall t.+ ParseTime t =>+ Proxy t ->+ Assertion parseEmptyTest _ = case parse False "" "" :: Maybe t of Just _ -> return ()@@ -574,12 +587,13 @@ parseEmptyTests = nameTest "parse empty" $ allTypes $ \name p -> nameTest name $ parseEmptyTest p formatParseFormatTests :: TestTree-formatParseFormatTests = nameTest "format_parse_format"- [- localOption (QuickCheckTests 50000) $- nameTest "general" $ allTypes $ \name p -> nameTest name $ prop_format_parse_format p,- nameTest "leapsecond" $ allLeapSecondTypes $ \name t -> nameTest name $ \fc -> prop_format_parse_format Proxy fc t- ]+formatParseFormatTests =+ nameTest+ "format_parse_format"+ [ localOption (QuickCheckTests 50000) $+ nameTest "general" $ allTypes $ \name p -> nameTest name $ prop_format_parse_format p+ , nameTest "leapsecond" $ allLeapSecondTypes $ \name t -> nameTest name $ \fc -> prop_format_parse_format Proxy fc t+ ] badInputTests :: TestTree badInputTests =@@ -590,10 +604,10 @@ , nameTest "LocalTime" $ tgroup (localTimeFormats ++ partialLocalTimeFormats) prop_no_crash_bad_input , nameTest "TimeZone" $ tgroup (timeZoneFormats) prop_no_crash_bad_input , nameTest "ZonedTime" $- tgroup (zonedTimeFormats ++ zonedTimeAlmostFormats ++ partialZonedTimeFormats) prop_no_crash_bad_input+ tgroup (zonedTimeFormats ++ zonedTimeAlmostFormats ++ partialZonedTimeFormats) prop_no_crash_bad_input , nameTest "UTCTime" $ tgroup (utcTimeAlmostFormats ++ partialUTCTimeFormats) prop_no_crash_bad_input , nameTest "UniversalTime" $- tgroup (universalTimeFormats ++ partialUniversalTimeFormats) prop_no_crash_bad_input+ tgroup (universalTimeFormats ++ partialUniversalTimeFormats) prop_no_crash_bad_input ] readShowTests :: TestTree@@ -614,8 +628,8 @@ , nameTest "UniversalTime" (prop_read_show :: UniversalTime -> Result) , nameTest "NominalDiffTime" (prop_read_show :: NominalDiffTime -> Result) , nameTest "DiffTime" (prop_read_show :: DiffTime -> Result)- --nameTest "CalendarDiffDays" (prop_read_show :: CalendarDiffDays -> Result),- --nameTest "CalendarDiffTime" (prop_read_show :: CalendarDiffTime -> Result)+ --nameTest "CalendarDiffDays" (prop_read_show :: CalendarDiffDays -> Result),+ --nameTest "CalendarDiffTime" (prop_read_show :: CalendarDiffTime -> Result) ] parseShowTests :: TestTree@@ -630,24 +644,25 @@ propertyTests :: TestTree propertyTests = localOption (QuickCheckTests 2000) $- nameTest- "properties"- [ readShowTests- , parseShowTests- , nameTest "fromMondayStartWeek" prop_fromMondayStartWeek- , nameTest "fromSundayStartWeek" prop_fromSundayStartWeek- , nameTest "parse_format" $ typedTests prop_parse_format- , nameTest "parse_format_lower" $ typedTests prop_parse_format_lower- , nameTest "parse_format_upper" $ typedTests prop_parse_format_upper- , parseEmptyTests- , formatParseFormatTests- , badInputTests- ]+ nameTest+ "properties"+ [ readShowTests+ , parseShowTests+ , nameTest "fromMondayStartWeek" prop_fromMondayStartWeek+ , nameTest "fromSundayStartWeek" prop_fromSundayStartWeek+ , nameTest "parse_format" $ typedTests prop_parse_format+ , nameTest "parse_format_lower" $ typedTests prop_parse_format_lower+ , nameTest "parse_format_upper" $ typedTests prop_parse_format_upper+ , parseEmptyTests+ , formatParseFormatTests+ , badInputTests+ ] dayFormats :: [FormatString Day] dayFormats =- map FormatString- -- numeric year, month, day+ map+ FormatString+ -- numeric year, month, day [ "%Y-%m-%d" , "%Y%m%d" , "%C%y%m%d"@@ -657,18 +672,18 @@ , "%Y/%d/%m" , "%D %C" , "%F"- -- month names- , "%Y-%B-%d"+ , -- month names+ "%Y-%B-%d" , "%Y-%b-%d" , "%Y-%h-%d" , "%C-%y-%B-%d" , "%C-%y-%b-%d" , "%C-%y-%h-%d"- -- ordinal dates- , "%Y-%j"+ , -- ordinal dates+ "%Y-%j" , "%C-%y-%j"- -- ISO week dates- , "%G-%V-%u"+ , -- ISO week dates+ "%G-%V-%u" , "%G-%V-%a" , "%G-%V-%A" , "%G-%V-%w"@@ -682,8 +697,8 @@ , "%A week %V, %f%g" , "day %V, week %A, %f%g" , "%f%g-W%V-%u"- -- monday and sunday week dates- , "%Y-w%U-%A"+ , -- monday and sunday week dates+ "%Y-w%U-%A" , "%Y-w%W-%A" , "%Y-%A-w%U" , "%Y-%A-w%W"@@ -693,8 +708,9 @@ monthFormats :: [FormatString Month] monthFormats =- map FormatString- -- numeric year, month+ map+ FormatString+ -- numeric year, month [ "%Y-%m" , "%Y%m" , "%C%y%m"@@ -703,8 +719,8 @@ , "%m/%Y" , "%Y/%m" , "%C %y %m"- -- month names- , "%Y-%B"+ , -- month names+ "%Y-%B" , "%Y-%b" , "%Y-%h" , "%C-%y-%B"@@ -714,8 +730,9 @@ timeOfDayFormats :: [FormatString TimeOfDay] timeOfDayFormats =- map FormatString- -- 24 h formats+ map+ FormatString+ -- 24 h formats [ "%H:%M:%S.%q" , "%k:%M:%S.%q" , "%H%M%S.%q"@@ -728,8 +745,8 @@ , "%T%Q" , "%X%Q" , "%R:%S%Q"- -- 12 h formats- , "%I:%M:%S.%q %p"+ , -- 12 h formats+ "%I:%M:%S.%q %p" , "%I:%M:%S.%q %P" , "%l:%M:%S.%q %p" , "%r %q"@@ -747,7 +764,8 @@ zonedTimeFormats :: [FormatString ZonedTime] zonedTimeFormats =- map FormatString+ map+ FormatString [ "%a, %d %b %Y %H:%M:%S.%q %z" , "%a, %d %b %Y %H:%M:%S%Q %z" , "%a, %d %b %Y %H:%M:%S.%q %Z"@@ -768,7 +786,8 @@ calendarDiffTimeFormats :: [FormatString CalendarDiffTime] calendarDiffTimeFormats =- map FormatString+ map+ FormatString [ "%yy%Bm%ww%Dd%Hh%Mm%ESs" , "%bm%ww%Dd%Hh%Mm%ESs" , "%bm%dd%Hh%Mm%ESs"@@ -788,7 +807,9 @@ map FormatString ["%ww%Dd%Hh%Mm%ESs", "%dd%Hh%Mm%ESs", "%hh%Mm%ESs", "%mm%ESs", "%mm%0ESs", "%Ess", "%0Ess"] --+ -- * Formats that do not include all the information+ -- partialDayFormats :: [FormatString Day] partialDayFormats = map FormatString []@@ -801,21 +822,23 @@ partialZonedTimeFormats :: [FormatString ZonedTime] partialZonedTimeFormats =- map FormatString- -- %s does not include second decimals+ map+ FormatString+ -- %s does not include second decimals [ "%s %z"- -- %S does not include second decimals- , "%c"+ , -- %S does not include second decimals+ "%c" , "%a, %d %b %Y %H:%M:%S %Z" ] partialUTCTimeFormats :: [FormatString UTCTime] partialUTCTimeFormats =- map FormatString- -- %s does not include second decimals+ map+ FormatString+ -- %s does not include second decimals [ "%s"- -- %c does not include second decimals- , "%c"+ , -- %c does not include second decimals+ "%c" ] partialUniversalTimeFormats :: [FormatString UniversalTime]@@ -823,8 +846,9 @@ failingPartialDayFormats :: [FormatString Day] failingPartialDayFormats =- map FormatString- -- ISO week dates with two digit year.- -- This can fail in the beginning or the end of a year where- -- the ISO week date year does not match the gregorian year.+ map+ FormatString+ -- ISO week dates with two digit year.+ -- This can fail in the beginning or the end of a year where+ -- the ISO week date year does not match the gregorian year. ["%g-%V-%u", "%g-%V-%a", "%g-%V-%A", "%g-%V-%w", "%A week %V, %g", "day %V, week %A, %g", "%g-W%V-%u"]
test/main/Test/LocalTime/CalendarDiffTime.hs view
@@ -1,6 +1,6 @@-module Test.LocalTime.CalendarDiffTime- ( testCalendarDiffTime- ) where+module Test.LocalTime.CalendarDiffTime (+ testCalendarDiffTime,+) where --import Data.Time.LocalTime import Test.Arbitrary ()@@ -13,5 +13,5 @@ testCalendarDiffTime = testGroup "CalendarDiffTime"- --testReadShow+ --testReadShow []
test/main/Test/LocalTime/Time.hs view
@@ -1,6 +1,6 @@-module Test.LocalTime.Time- ( testTime- ) where+module Test.LocalTime.Time (+ testTime,+) where import Data.Time import Data.Time.Calendar.OrdinalDate@@ -10,44 +10,44 @@ 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 = concat -- days around 1 BCE/1 CE [ concatMap showCal [-678950 .. -678930]- -- days around 1000 CE- , concatMap showCal [-313710 .. -313690]- -- days around MJD zero- , concatMap showCal [-30 .. 30]+ , -- days around 1000 CE+ concatMap showCal [-313710 .. -313690]+ , -- days around MJD zero+ concatMap showCal [-30 .. 30] , showCal 40000 , showCal 50000- -- 1900 not a leap year- , showCal 15078+ , -- 1900 not a leap year+ showCal 15078 , showCal 15079- -- 1980 is a leap year- , showCal 44297+ , -- 1980 is a leap year+ showCal 44297 , showCal 44298 , showCal 44299- -- 1990 not a leap year- , showCal 47950+ , -- 1990 not a leap year+ showCal 47950 , showCal 47951- -- 2000 is a leap year- , showCal 51602+ , -- 2000 is a leap year+ showCal 51602 , showCal 51603 , showCal 51604- -- years 2000 and 2001, plus some slop- , concatMap showCal [51540 .. 52280]+ , -- years 2000 and 2001, plus some slop+ concatMap showCal [51540 .. 52280] ] showUTCTime :: UTCTime -> String@@ -63,10 +63,10 @@ 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 +86,17 @@ ] 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]
test/main/Test/LocalTime/TimeOfDay.hs view
@@ -1,6 +1,6 @@-module Test.LocalTime.TimeOfDay- ( testTimeOfDay- ) where+module Test.LocalTime.TimeOfDay (+ testTimeOfDay,+) where import Data.Time.LocalTime import Test.Arbitrary ()@@ -11,12 +11,12 @@ 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 ]
test/main/Test/LocalTime/TimeRef.hs view
@@ -6,9 +6,10 @@ is64Bit = if toInteger (maxBound :: Int) == toInteger (maxBound :: Int32) then False- else if toInteger (maxBound :: Int) == toInteger (maxBound :: Int64)- then True- else error "unrecognised Int size"+ else+ if toInteger (maxBound :: Int) == toInteger (maxBound :: Int64)+ then True+ else error "unrecognised Int size" testTimeRef :: String testTimeRef =@@ -889,7 +890,7 @@ , "12:34:56.789123456" , "12:34:56.789123456789" , if is64Bit- then "-9223372036854775808:00:00"- else "-2147483648:00:00"+ then "-9223372036854775808:00:00"+ else "-2147483648:00:00" , "" ]
test/main/Test/Types.hs view
@@ -1,4 +1,4 @@-module Test.Types() where+module Test.Types () where import Control.DeepSeq import Data.Data@@ -10,27 +10,43 @@ import Data.Time.Clock.TAI class (Typeable t, Data t, NFData t) => CheckDataInstances t+ class (Typeable t, Data t, NFData t, Eq t) => CheckEqInstances t+ class (Typeable t, Data t, NFData t, Eq t, Ord t) => CheckOrdInstances t+ class (Typeable t, Data t, NFData t, Eq t, Ord t, Ix t, Enum t) => CheckEnumInstances t+ class (Typeable t, Data t, NFData t, Eq t, Ord t, Ix t, Enum t, Bounded t) => CheckBoundedInstances t instance CheckOrdInstances UTCTime+ instance CheckOrdInstances NominalDiffTime instance CheckEnumInstances Day+ instance CheckEnumInstances DayOfWeek+ instance CheckOrdInstances TimeOfDay+ instance CheckOrdInstances LocalTime+ instance CheckOrdInstances TimeZone+ instance CheckDataInstances ZonedTime+ instance CheckEqInstances CalendarDiffDays+ instance CheckEqInstances CalendarDiffTime+ instance CheckEnumInstances Month+ instance CheckEnumInstances Quarter+ instance CheckBoundedInstances QuarterOfYear instance CheckOrdInstances SystemTime instance CheckOrdInstances AbsoluteTime+ instance CheckOrdInstances UniversalTime
test/unix/Test/Format/Format.hs view
@@ -1,8 +1,8 @@ {-# OPTIONS -fno-warn-orphans #-} -module Test.Format.Format- ( testFormat- ) where+module Test.Format.Format (+ testFormat,+) where import Data.Char import Data.Fixed as F@@ -25,59 +25,70 @@ const char *format, int isdst,int gmtoff,time_t t); -}-foreign import ccall unsafe "FormatStuff.h format_time" format_time- :: CString ->- CSize -> CString -> CInt -> CInt -> CString -> CTime -> IO CSize+foreign import ccall unsafe "FormatStuff.h format_time"+ format_time ::+ CString ->+ CSize ->+ CString ->+ CInt ->+ CInt ->+ CString ->+ CTime ->+ IO CSize withBuffer :: Int -> (CString -> IO CSize) -> IO String withBuffer n f = withArray (replicate n 0)- (\buffer -> do- len <- f buffer- peekCStringLen (buffer, fromIntegral len))+ ( \buffer -> do+ len <- f buffer+ peekCStringLen (buffer, fromIntegral len)+ ) unixFormatTime :: String -> TimeZone -> UTCTime -> String unixFormatTime fmt zone time = unsafePerformIO $- withCString- fmt- (\pfmt ->- withCString- (timeZoneName zone)- (\pzonename ->- withBuffer- 100- (\buffer ->- format_time- buffer- 100- pfmt- (if timeZoneSummerOnly zone+ withCString+ fmt+ ( \pfmt ->+ withCString+ (timeZoneName zone)+ ( \pzonename ->+ withBuffer+ 100+ ( \buffer ->+ format_time+ buffer+ 100+ pfmt+ ( if timeZoneSummerOnly zone then 1- else 0)- (fromIntegral (timeZoneMinutes zone * 60))- pzonename- (fromInteger (floor (utcTimeToPOSIXSeconds time))))))+ else 0+ )+ (fromIntegral (timeZoneMinutes zone * 60))+ pzonename+ (fromInteger (floor (utcTimeToPOSIXSeconds time)))+ )+ )+ ) locale :: TimeLocale-locale = defaultTimeLocale {dateTimeFmt = "%a %b %e %H:%M:%S %Y"}+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 mins <- choose (-2000, 2000) dst <- arbitrary hasName <- arbitrary- let- name =+ let name = if hasName then "ZONE" else ""@@ -92,17 +103,16 @@ -- | 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 day <- choose (-25000, 75000) time <- arbitrary- let- -- verify that the created time can fit in the local CTime+ let -- verify that the created time can fit in the local CTime localT = LocalTime (ModifiedJulianDay day) time utcT = localTimeToUTC utc localT secondsInteger = floor (utcTimeToPOSIXSeconds utcT)@@ -135,12 +145,12 @@ 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@@ -159,12 +169,13 @@ formats :: [String] formats =- ["%G-W%V-%u", "%U-%w", "%W-%u"] ++- (do- char <- chars- width <- widths- modifier <- modifiers- return $ "%" ++ modifier ++ width ++ [char])+ ["%G-W%V-%u", "%U-%w", "%W-%u"]+ ++ ( do+ char <- chars+ width <- widths+ modifier <- modifiers+ return $ "%" ++ modifier ++ width ++ [char]+ ) hashformats :: [String] hashformats = do@@ -187,10 +198,10 @@ 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 =@@ -248,6 +259,7 @@ strftimeHasGNUExts = unixFormatTime "%_6Y" utc (UTCTime (fromGregorian 1980 1 1) 0) == " 1980" testFormat :: [TestTree]-testFormat = if strftimeHasGNUExts- then pure $ localOption (QuickCheckTests 10000) $ testGroup "testFormat" $ testCompareFormat ++ testCompareHashFormat ++ testQs- else []+testFormat =+ if strftimeHasGNUExts+ then pure $ localOption (QuickCheckTests 10000) $ testGroup "testFormat" $ testCompareFormat ++ testCompareHashFormat ++ testQs+ else []
test/unix/Test/LocalTime/TimeZone.hs view
@@ -1,6 +1,6 @@-module Test.LocalTime.TimeZone- ( testTimeZone- ) where+module Test.LocalTime.TimeZone (+ testTimeZone,+) where import Data.Time import System.Environment (setEnv)
test/unix/Test/TestUtil.hs view
@@ -41,5 +41,5 @@ assertEqualQC :: (Show a, Eq a) => String -> a -> a -> Result assertEqualQC _name expected found | expected == found = succeeded-assertEqualQC "" expected found = failed {reason = "expected " ++ show expected ++ ", found " ++ show found}-assertEqualQC name expected found = failed {reason = name ++ ": expected " ++ show expected ++ ", found " ++ show found}+assertEqualQC "" expected found = failed{reason = "expected " ++ show expected ++ ", found " ++ show found}+assertEqualQC name expected found = failed{reason = name ++ ": expected " ++ show expected ++ ", found " ++ show found}
time.cabal view
@@ -1,8 +1,8 @@-cabal-version: >=1.10+cabal-version: 3.0 name: time-version: 1.11.1.2+version: 1.12 stability: stable-license: BSD2+license: BSD-2-Clause license-file: LICENSE author: Ashley Yakeley maintainer: <ashley@semantic.org>@@ -13,12 +13,9 @@ category: Time build-type: Configure tested-with:- GHC == 8.0.2,- GHC == 8.2.2,- GHC == 8.4.4,- GHC == 8.6.5, GHC == 8.8.4,- GHC == 8.10.2+ GHC == 8.10.5,+ GHC == 9.0.1 x-follows-version-policy: extra-source-files:@@ -49,11 +46,10 @@ StandaloneDeriving PatternSynonyms ViewPatterns- CPP ghc-options: -Wall -fwarn-tabs c-sources: lib/cbits/HsTime.c build-depends:- base >= 4.9 && < 5,+ base >= 4.13 && < 5, deepseq >= 1.1 if os(windows) build-depends: Win32@@ -110,9 +106,8 @@ install-includes: HsTime.h else- -- # requires cabal 3, see #145, #146- --autogen-includes:- -- HsTimeConfig.h+ autogen-includes:+ HsTimeConfig.h install-includes: HsTime.h HsTimeConfig.h@@ -133,7 +128,7 @@ default-language: Haskell2010 default-extensions: Rank2Types- CPP+ GeneralizedNewtypeDeriving DeriveDataTypeable StandaloneDeriving ExistentialQuantification@@ -147,6 +142,7 @@ base, deepseq, time,+ random, QuickCheck, tasty, tasty-hunit,@@ -171,6 +167,7 @@ Test.Calendar.LongWeekYearsRef Test.Calendar.MonthDay Test.Calendar.MonthDayRef+ Test.Calendar.MonthOfYear Test.Calendar.Valid Test.Calendar.Week Test.Clock.Conversion@@ -193,7 +190,6 @@ default-language: Haskell2010 default-extensions: Rank2Types- CPP DeriveDataTypeable StandaloneDeriving ExistentialQuantification