diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,17 @@ +# Change Log + +## [1.6] + +### Added +- FormatTime, ParseTime, Show and Read instances for UniversalTime +- diffTimeToPicoseconds +- this change log + +### Changed +- Use clock_gettime where available +- Read and Show instances exported in the same module as their types +- Fixed bug in fromSundayStartWeekValid +- Parsing functions now reject invalid dates +- Various documentation fixes + +## [1.5.0.1] diff --git a/configure b/configure --- a/configure +++ b/configure @@ -3434,6 +3434,18 @@ done +for ac_func in clock_gettime +do : + ac_fn_c_check_func "$LINENO" "clock_gettime" "ac_cv_func_clock_gettime" +if test "x$ac_cv_func_clock_gettime" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_CLOCK_GETTIME 1 +_ACEOF + +fi +done + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether struct tm is in sys/time.h or time.h" >&5 $as_echo_n "checking whether struct tm is in sys/time.h or time.h... " >&6; } if ${ac_cv_struct_tm+:} false; then : diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([Haskell time package], [1.4.0.2], [ashley@semantic.org], [time]) +AC_INIT([Haskell time package], [1.6], [ashley@semantic.org], [time]) # Safety check: Ensure that we are in the correct source directory. AC_CONFIG_SRCDIR([lib/include/HsTime.h]) @@ -14,6 +14,8 @@ AC_CHECK_HEADERS([time.h]) AC_CHECK_FUNCS([gmtime_r localtime_r]) + +AC_CHECK_FUNCS([clock_gettime]) AC_STRUCT_TM AC_STRUCT_TIMEZONE diff --git a/lib/Data/Time.hs b/lib/Data/Time.hs --- a/lib/Data/Time.hs +++ b/lib/Data/Time.hs @@ -1,9 +1,9 @@ module Data.Time ( - module Data.Time.Calendar, - module Data.Time.Clock, - module Data.Time.LocalTime, - module Data.Time.Format + module Data.Time.Calendar, + module Data.Time.Clock, + module Data.Time.LocalTime, + module Data.Time.Format ) where import Data.Time.Calendar diff --git a/lib/Data/Time/Calendar.hs b/lib/Data/Time/Calendar.hs --- a/lib/Data/Time/Calendar.hs +++ b/lib/Data/Time/Calendar.hs @@ -1,8 +1,9 @@ module Data.Time.Calendar ( - module Data.Time.Calendar.Days, - module Data.Time.Calendar.Gregorian + module Data.Time.Calendar.Days, + module Data.Time.Calendar.Gregorian ) where import Data.Time.Calendar.Days import Data.Time.Calendar.Gregorian +import Data.Time.Format() diff --git a/lib/Data/Time/Calendar/Days.hs b/lib/Data/Time/Calendar/Days.hs --- a/lib/Data/Time/Calendar/Days.hs +++ b/lib/Data/Time/Calendar/Days.hs @@ -3,8 +3,8 @@ -- #hide module Data.Time.Calendar.Days ( - -- * Days - Day(..),addDays,diffDays + -- * Days + Day(..),addDays,diffDays ) where import Control.DeepSeq @@ -24,51 +24,28 @@ ) instance NFData Day where - rnf (ModifiedJulianDay a) = rnf a + rnf (ModifiedJulianDay a) = rnf a -- necessary because H98 doesn't have "cunning newtype" derivation instance Enum Day where - succ (ModifiedJulianDay a) = ModifiedJulianDay (succ a) - pred (ModifiedJulianDay a) = ModifiedJulianDay (pred a) - toEnum = ModifiedJulianDay . toEnum - fromEnum (ModifiedJulianDay a) = fromEnum a - enumFrom (ModifiedJulianDay a) = fmap ModifiedJulianDay (enumFrom a) - enumFromThen (ModifiedJulianDay a) (ModifiedJulianDay b) = fmap ModifiedJulianDay (enumFromThen a b) - enumFromTo (ModifiedJulianDay a) (ModifiedJulianDay b) = fmap ModifiedJulianDay (enumFromTo a b) - enumFromThenTo (ModifiedJulianDay a) (ModifiedJulianDay b) (ModifiedJulianDay c) = fmap ModifiedJulianDay (enumFromThenTo a b c) + succ (ModifiedJulianDay a) = ModifiedJulianDay (succ a) + pred (ModifiedJulianDay a) = ModifiedJulianDay (pred a) + toEnum = ModifiedJulianDay . toEnum + fromEnum (ModifiedJulianDay a) = fromEnum a + enumFrom (ModifiedJulianDay a) = fmap ModifiedJulianDay (enumFrom a) + enumFromThen (ModifiedJulianDay a) (ModifiedJulianDay b) = fmap ModifiedJulianDay (enumFromThen a b) + enumFromTo (ModifiedJulianDay a) (ModifiedJulianDay b) = fmap ModifiedJulianDay (enumFromTo a b) + enumFromThenTo (ModifiedJulianDay a) (ModifiedJulianDay b) (ModifiedJulianDay c) = fmap ModifiedJulianDay (enumFromThenTo a b c) -- necessary because H98 doesn't have "cunning newtype" derivation instance Ix Day where - range (ModifiedJulianDay a,ModifiedJulianDay b) = fmap ModifiedJulianDay (range (a,b)) - index (ModifiedJulianDay a,ModifiedJulianDay b) (ModifiedJulianDay c) = index (a,b) c - inRange (ModifiedJulianDay a,ModifiedJulianDay b) (ModifiedJulianDay c) = inRange (a,b) c - rangeSize (ModifiedJulianDay a,ModifiedJulianDay b) = rangeSize (a,b) + range (ModifiedJulianDay a,ModifiedJulianDay b) = fmap ModifiedJulianDay (range (a,b)) + index (ModifiedJulianDay a,ModifiedJulianDay b) (ModifiedJulianDay c) = index (a,b) c + inRange (ModifiedJulianDay a,ModifiedJulianDay b) (ModifiedJulianDay c) = inRange (a,b) c + rangeSize (ModifiedJulianDay a,ModifiedJulianDay b) = rangeSize (a,b) addDays :: Integer -> Day -> Day addDays n (ModifiedJulianDay a) = ModifiedJulianDay (a + n) diffDays :: Day -> Day -> Integer diffDays (ModifiedJulianDay a) (ModifiedJulianDay b) = a - b - -{- -instance Show Day where - show (ModifiedJulianDay d) = "MJD " ++ (show d) - --- necessary because H98 doesn't have "cunning newtype" derivation -instance Num Day where - (ModifiedJulianDay a) + (ModifiedJulianDay b) = ModifiedJulianDay (a + b) - (ModifiedJulianDay a) - (ModifiedJulianDay b) = ModifiedJulianDay (a - b) - (ModifiedJulianDay a) * (ModifiedJulianDay b) = ModifiedJulianDay (a * b) - negate (ModifiedJulianDay a) = ModifiedJulianDay (negate a) - abs (ModifiedJulianDay a) = ModifiedJulianDay (abs a) - signum (ModifiedJulianDay a) = ModifiedJulianDay (signum a) - fromInteger = ModifiedJulianDay - -instance Real Day where - toRational (ModifiedJulianDay a) = toRational a - -instance Integral Day where - toInteger (ModifiedJulianDay a) = toInteger a - quotRem (ModifiedJulianDay a) (ModifiedJulianDay b) = (ModifiedJulianDay c,ModifiedJulianDay d) where - (c,d) = quotRem a b --} diff --git a/lib/Data/Time/Calendar/Easter.hs b/lib/Data/Time/Calendar/Easter.hs --- a/lib/Data/Time/Calendar/Easter.hs +++ b/lib/Data/Time/Calendar/Easter.hs @@ -1,12 +1,12 @@ module Data.Time.Calendar.Easter - ( - sundayAfter, - orthodoxPaschalMoon,orthodoxEaster, - gregorianPaschalMoon,gregorianEaster - ) where + ( + sundayAfter, + orthodoxPaschalMoon,orthodoxEaster, + gregorianPaschalMoon,gregorianEaster + ) where -- formulae from Reingold & Dershowitz, _Calendrical Calculations_, ch. 8. - + import Data.Time.Calendar import Data.Time.Calendar.Julian @@ -17,8 +17,8 @@ -- | Given a year, find the Paschal full moon according to Orthodox Christian tradition orthodoxPaschalMoon :: Integer -> Day orthodoxPaschalMoon year = addDays (- shiftedEpact) (fromJulian jyear 4 19) where - shiftedEpact = mod (14 + 11 * (mod year 19)) 30 - jyear = if year > 0 then year else year - 1 + shiftedEpact = mod (14 + 11 * (mod year 19)) 30 + jyear = if year > 0 then year else year - 1 -- | Given a year, find Easter according to Orthodox Christian tradition orthodoxEaster :: Integer -> Day @@ -27,9 +27,9 @@ -- | Given a year, find the Paschal full moon according to the Gregorian method gregorianPaschalMoon :: Integer -> Day 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 - adjustedEpact = if shiftedEpact == 0 || ((shiftedEpact == 1) && (mod year 19 < 10)) then shiftedEpact + 1 else shiftedEpact + century = (div year 100) + 1 + shiftedEpact = mod (14 + 11 * (mod year 19) - (div (3 * century) 4) + (div (5 + 8 * century) 25)) 30 + adjustedEpact = if shiftedEpact == 0 || ((shiftedEpact == 1) && (mod year 19 < 10)) then shiftedEpact + 1 else shiftedEpact -- | Given a year, find Easter according to the Gregorian method gregorianEaster :: Integer -> Day diff --git a/lib/Data/Time/Calendar/Gregorian.hs b/lib/Data/Time/Calendar/Gregorian.hs --- a/lib/Data/Time/Calendar/Gregorian.hs +++ b/lib/Data/Time/Calendar/Gregorian.hs @@ -3,16 +3,16 @@ -- #hide module Data.Time.Calendar.Gregorian ( - -- * Gregorian calendar - toGregorian,fromGregorian,fromGregorianValid,showGregorian,gregorianMonthLength, + -- * Gregorian calendar + toGregorian,fromGregorian,fromGregorianValid,showGregorian,gregorianMonthLength, - -- calendrical arithmetic + -- calendrical arithmetic -- e.g. "one month after March 31st" - addGregorianMonthsClip,addGregorianMonthsRollOver, - addGregorianYearsClip,addGregorianYearsRollOver, + addGregorianMonthsClip,addGregorianMonthsRollOver, + addGregorianYearsClip,addGregorianYearsRollOver, - -- re-exported from OrdinalDate - isLeapYear + -- re-exported from OrdinalDate + isLeapYear ) where import Data.Time.Calendar.MonthDay @@ -23,8 +23,8 @@ -- | convert to proleptic Gregorian calendar. First element of result is year, second month number (1-12), third day (1-31). toGregorian :: Day -> (Integer,Int,Int) toGregorian date = (year,month,day) where - (year,yd) = toOrdinalDate date - (month,day) = dayOfYearToMonthAndDay (isLeapYear year) yd + (year,yd) = toOrdinalDate date + (month,day) = dayOfYearToMonthAndDay (isLeapYear year) yd -- | convert from proleptic Gregorian calendar. First argument is year, second month number (1-12), third day (1-31). -- Invalid values will be clipped to the correct range, month first, then day. @@ -35,13 +35,13 @@ -- Invalid values will return Nothing fromGregorianValid :: Integer -> Int -> Int -> Maybe Day fromGregorianValid year month day = do - doy <- monthAndDayToDayOfYearValid (isLeapYear year) month day - fromOrdinalDateValid year doy + doy <- monthAndDayToDayOfYearValid (isLeapYear year) month day + fromOrdinalDateValid year doy -- | show in ISO 8601 format (yyyy-mm-dd) showGregorian :: Day -> String showGregorian date = (show4 (Just '0') y) ++ "-" ++ (show2 (Just '0') m) ++ "-" ++ (show2 (Just '0') d) where - (y,m,d) = toGregorian date + (y,m,d) = toGregorian date -- | The number of days in a given month according to the proleptic Gregorian calendar. First argument is year, second is month. gregorianMonthLength :: Integer -> Int -> Int @@ -52,20 +52,20 @@ addGregorianMonths :: Integer -> Day -> (Integer,Int,Int) addGregorianMonths n day = (y',m',d) where - (y,m,d) = toGregorian day - (y',m') = rolloverMonths (y,fromIntegral m + n) + (y,m,d) = toGregorian day + (y',m') = rolloverMonths (y,fromIntegral m + n) -- | Add months, with days past the last day of the month clipped to the last day. -- For instance, 2005-01-30 + 1 month = 2005-02-28. addGregorianMonthsClip :: Integer -> Day -> Day addGregorianMonthsClip n day = fromGregorian y m d where - (y,m,d) = addGregorianMonths n day + (y,m,d) = addGregorianMonths n day -- | Add months, with days past the last day of the month rolling over to the next month. -- For instance, 2005-01-30 + 1 month = 2005-03-02. addGregorianMonthsRollOver :: Integer -> Day -> Day addGregorianMonthsRollOver n day = addDays (fromIntegral d - 1) (fromGregorian y m 1) where - (y,m,d) = addGregorianMonths n day + (y,m,d) = addGregorianMonths n day -- | Add years, matching month and day, with Feb 29th clipped to Feb 28th if necessary. -- For instance, 2004-02-29 + 2 years = 2006-02-28. @@ -79,4 +79,4 @@ -- orphan instance instance Show Day where - show = showGregorian + show = showGregorian diff --git a/lib/Data/Time/Calendar/Julian.hs b/lib/Data/Time/Calendar/Julian.hs --- a/lib/Data/Time/Calendar/Julian.hs +++ b/lib/Data/Time/Calendar/Julian.hs @@ -1,13 +1,13 @@ module Data.Time.Calendar.Julian ( - module Data.Time.Calendar.JulianYearDay, + module Data.Time.Calendar.JulianYearDay, - toJulian,fromJulian,fromJulianValid,showJulian,julianMonthLength, + toJulian,fromJulian,fromJulianValid,showJulian,julianMonthLength, - -- calendrical arithmetic + -- calendrical arithmetic -- e.g. "one month after March 31st" - addJulianMonthsClip,addJulianMonthsRollOver, - addJulianYearsClip,addJulianYearsRollOver + addJulianMonthsClip,addJulianMonthsRollOver, + addJulianYearsClip,addJulianYearsRollOver ) where import Data.Time.Calendar.MonthDay @@ -18,8 +18,8 @@ -- | convert to proleptic Julian calendar. First element of result is year, second month number (1-12), third day (1-31). toJulian :: Day -> (Integer,Int,Int) toJulian date = (year,month,day) where - (year,yd) = toJulianYearAndDay date - (month,day) = dayOfYearToMonthAndDay (isJulianLeapYear year) yd + (year,yd) = toJulianYearAndDay date + (month,day) = dayOfYearToMonthAndDay (isJulianLeapYear year) yd -- | convert from proleptic Julian calendar. First argument is year, second month number (1-12), third day (1-31). -- Invalid values will be clipped to the correct range, month first, then day. @@ -30,13 +30,13 @@ -- Invalid values will return Nothing. fromJulianValid :: Integer -> Int -> Int -> Maybe Day fromJulianValid year month day = do - doy <- monthAndDayToDayOfYearValid (isJulianLeapYear year) month day - fromJulianYearAndDayValid year doy + doy <- monthAndDayToDayOfYearValid (isJulianLeapYear year) month day + fromJulianYearAndDayValid year doy -- | show in ISO 8601 format (yyyy-mm-dd) showJulian :: Day -> String showJulian date = (show4 (Just '0') y) ++ "-" ++ (show2 (Just '0') m) ++ "-" ++ (show2 (Just '0') d) where - (y,m,d) = toJulian date + (y,m,d) = toJulian date -- | The number of days in a given month according to the proleptic Julian calendar. First argument is year, second is month. julianMonthLength :: Integer -> Int -> Int @@ -47,20 +47,20 @@ addJulianMonths :: Integer -> Day -> (Integer,Int,Int) addJulianMonths n day = (y',m',d) where - (y,m,d) = toJulian day - (y',m') = rolloverMonths (y,fromIntegral m + n) + (y,m,d) = toJulian day + (y',m') = rolloverMonths (y,fromIntegral m + n) -- | Add months, with days past the last day of the month clipped to the last day. -- For instance, 2005-01-30 + 1 month = 2005-02-28. addJulianMonthsClip :: Integer -> Day -> Day addJulianMonthsClip n day = fromJulian y m d where - (y,m,d) = addJulianMonths n day + (y,m,d) = addJulianMonths n day -- | Add months, with days past the last day of the month rolling over to the next month. -- For instance, 2005-01-30 + 1 month = 2005-03-02. addJulianMonthsRollOver :: Integer -> Day -> Day addJulianMonthsRollOver n day = addDays (fromIntegral d - 1) (fromJulian y m 1) where - (y,m,d) = addJulianMonths n day + (y,m,d) = addJulianMonths n day -- | Add years, matching month and day, with Feb 29th clipped to Feb 28th if necessary. -- For instance, 2004-02-29 + 2 years = 2006-02-28. diff --git a/lib/Data/Time/Calendar/JulianYearDay.hs b/lib/Data/Time/Calendar/JulianYearDay.hs --- a/lib/Data/Time/Calendar/JulianYearDay.hs +++ b/lib/Data/Time/Calendar/JulianYearDay.hs @@ -1,9 +1,9 @@ -- #hide module Data.Time.Calendar.JulianYearDay - ( - -- * Year and day format - module Data.Time.Calendar.JulianYearDay - ) where + ( + -- * Year and day format + module Data.Time.Calendar.JulianYearDay + ) where import Data.Time.Calendar.Days import Data.Time.Calendar.Private @@ -12,34 +12,34 @@ -- second is the day of the year, with 1 for Jan 1, and 365 (or 366 in leap years) for Dec 31. toJulianYearAndDay :: Day -> (Integer,Int) toJulianYearAndDay (ModifiedJulianDay mjd) = (year,yd) where - a = mjd + 678577 - quad = div a 1461 - d = mod a 1461 - y = min (div d 365) 3 - yd = fromInteger (d - (y * 365) + 1) - year = quad * 4 + y + 1 + a = mjd + 678577 + quad = div a 1461 + d = mod a 1461 + y = min (div d 365) 3 + yd = fromInteger (d - (y * 365) + 1) + year = quad * 4 + y + 1 -- | convert from proleptic Julian year and day format. -- Invalid day numbers will be clipped to the correct range (1 to 365 or 366). fromJulianYearAndDay :: Integer -> Int -> Day fromJulianYearAndDay year day = ModifiedJulianDay mjd where - y = year - 1 - mjd = (fromIntegral (clip 1 (if isJulianLeapYear year then 366 else 365) day)) + (365 * y) + (div y 4) - 678578 + y = year - 1 + mjd = (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 fromJulianYearAndDayValid :: Integer -> Int -> Maybe Day fromJulianYearAndDayValid year day = do - day' <- clipValid 1 (if isJulianLeapYear year then 366 else 365) day - let - y = year - 1 - mjd = (fromIntegral day') + (365 * y) + (div y 4) - 678578 - return (ModifiedJulianDay mjd) + day' <- clipValid 1 (if isJulianLeapYear year then 366 else 365) day + let + y = year - 1 + mjd = (fromIntegral day') + (365 * y) + (div y 4) - 678578 + return (ModifiedJulianDay mjd) -- | show in proleptic Julian year and day format (yyyy-ddd) showJulianYearAndDay :: Day -> String showJulianYearAndDay date = (show4 (Just '0') y) ++ "-" ++ (show3 (Just '0') d) where - (y,d) = toJulianYearAndDay date + (y,d) = toJulianYearAndDay date -- | Is this year a leap year according to the proleptic Julian calendar? isJulianLeapYear :: Integer -> Bool diff --git a/lib/Data/Time/Calendar/MonthDay.hs b/lib/Data/Time/Calendar/MonthDay.hs --- a/lib/Data/Time/Calendar/MonthDay.hs +++ b/lib/Data/Time/Calendar/MonthDay.hs @@ -1,7 +1,7 @@ module Data.Time.Calendar.MonthDay - ( - monthAndDayToDayOfYear,monthAndDayToDayOfYearValid,dayOfYearToMonthAndDay,monthLength - ) where + ( + monthAndDayToDayOfYear,monthAndDayToDayOfYearValid,dayOfYearToMonthAndDay,monthLength + ) where import Data.Time.Calendar.Private @@ -9,22 +9,22 @@ -- First arg is leap year flag monthAndDayToDayOfYear :: Bool -> Int -> Int -> Int monthAndDayToDayOfYear isLeap month day = (div (367 * month'' - 362) 12) + k + day' where - month' = clip 1 12 month - day' = fromIntegral (clip 1 (monthLength' isLeap month') day) - month'' = fromIntegral month' - k = if month' <= 2 then 0 else if isLeap then -1 else -2 + month' = clip 1 12 month + day' = fromIntegral (clip 1 (monthLength' isLeap month') day) + month'' = fromIntegral month' + k = if month' <= 2 then 0 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 monthAndDayToDayOfYearValid :: Bool -> Int -> Int -> Maybe Int monthAndDayToDayOfYearValid isLeap month day = do - month' <- clipValid 1 12 month - day' <- clipValid 1 (monthLength' isLeap month') day - let - day'' = fromIntegral day' - month'' = fromIntegral month' - k = if month' <= 2 then 0 else if isLeap then -1 else -2 - return ((div (367 * month'' - 362) 12) + k + day'') + month' <- clipValid 1 12 month + day' <- clipValid 1 (monthLength' isLeap month') day + let + day'' = fromIntegral day' + month'' = fromIntegral month' + k = if month' <= 2 then 0 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. -- First arg is leap year flag @@ -44,6 +44,6 @@ monthLength' isLeap month' = (monthLengths isLeap) !! (month' - 1) monthLengths :: Bool -> [Int] -monthLengths isleap = - [31,if isleap then 29 else 28,31,30,31,30,31,31,30,31,30,31] - --J F M A M J J A S O N D +monthLengths isleap = + [31,if isleap then 29 else 28,31,30,31,30,31,31,30,31,30,31] + --J F M A M J J A S O N D diff --git a/lib/Data/Time/Calendar/OrdinalDate.hs b/lib/Data/Time/Calendar/OrdinalDate.hs --- a/lib/Data/Time/Calendar/OrdinalDate.hs +++ b/lib/Data/Time/Calendar/OrdinalDate.hs @@ -8,38 +8,38 @@ -- second is the day of the year, with 1 for Jan 1, and 365 (or 366 in leap years) for Dec 31. toOrdinalDate :: Day -> (Integer,Int) toOrdinalDate (ModifiedJulianDay mjd) = (year,yd) where - a = mjd + 678575 - quadcent = div a 146097 - b = mod a 146097 - cent = min (div b 36524) 3 - c = b - (cent * 36524) - quad = div c 1461 - d = mod c 1461 - y = min (div d 365) 3 - yd = fromInteger (d - (y * 365) + 1) - year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 + a = mjd + 678575 + quadcent = div a 146097 + b = mod a 146097 + cent = min (div b 36524) 3 + c = b - (cent * 36524) + quad = div c 1461 + d = mod c 1461 + y = min (div d 365) 3 + yd = fromInteger (d - (y * 365) + 1) + year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 -- | convert from ISO 8601 Ordinal Date format. -- Invalid day numbers will be clipped to the correct range (1 to 365 or 366). fromOrdinalDate :: Integer -> Int -> Day fromOrdinalDate year day = ModifiedJulianDay mjd 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 + 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 -- | convert from ISO 8601 Ordinal Date format. -- Invalid day numbers return Nothing fromOrdinalDateValid :: Integer -> Int -> Maybe Day fromOrdinalDateValid year day = do - day' <- clipValid 1 (if isLeapYear year then 366 else 365) day - let - y = year - 1 - mjd = (fromIntegral day') + (365 * y) + (div y 4) - (div y 100) + (div y 400) - 678576 - return (ModifiedJulianDay mjd) + day' <- clipValid 1 (if isLeapYear year then 366 else 365) day + let + y = year - 1 + mjd = (fromIntegral day') + (365 * y) + (div y 4) - (div y 100) + (div y 400) - 678576 + return (ModifiedJulianDay mjd) -- | show in ISO 8601 Ordinal Date format (yyyy-ddd) showOrdinalDate :: Day -> String showOrdinalDate date = (show4 (Just '0') y) ++ "-" ++ (show3 (Just '0') d) where - (y,d) = toOrdinalDate date + (y,d) = toOrdinalDate date -- | Is this year a leap year according to the proleptic Gregorian calendar? isLeapYear :: Integer -> Bool @@ -50,78 +50,121 @@ -- Monday is 1, Sunday is 7 (as \"%u\" in 'Data.Time.Format.formatTime'). mondayStartWeek :: Day -> (Int,Int) mondayStartWeek date = (fromInteger ((div d 7) - (div k 7)),fromInteger (mod d 7) + 1) where - yd = snd (toOrdinalDate date) - d = (toModifiedJulianDay date) + 2 - k = d - (toInteger yd) + yd = snd (toOrdinalDate date) + d = (toModifiedJulianDay date) + 2 + k = d - (toInteger yd) -- | Get the number of the Sunday-starting week in the year and the day of the week. -- 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'). -- Sunday is 0, Saturday is 6 (as \"%w\" in 'Data.Time.Format.formatTime'). sundayStartWeek :: Day -> (Int,Int) sundayStartWeek date =(fromInteger ((div d 7) - (div k 7)),fromInteger (mod d 7)) where - yd = snd (toOrdinalDate date) - d = (toModifiedJulianDay date) + 3 - k = d - (toInteger yd) + yd = snd (toOrdinalDate date) + d = (toModifiedJulianDay date) + 3 + k = d - (toInteger yd) -- | The inverse of 'mondayStartWeek'. Get a 'Day' given the year, -- the number of the Monday-starting week, and the day of the week. --- The first Monday is the first day of week 1, any earlier days in the year +-- 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 :: Integer -- ^ Year. - -> Int -- ^ Monday-starting week number. - -> Int -- ^ Day of week. + -> Int -- ^ 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 y w d = ModifiedJulianDay (firstDay + yd) - where yd = firstMonday + 7 * toInteger (w-1) + toInteger d - 1 - -- first day of the year - firstDay = toModifiedJulianDay (fromOrdinalDate y 1) - -- 0-based year day of first monday of the year - firstMonday = (5 - firstDay) `mod` 7 +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 :: Integer -- ^ Year. - -> Int -- ^ Monday-starting week number. - -> Int -- ^ Day of week. + -> Int -- ^ 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 fromMondayStartWeekValid year w d = do - d' <- clipValid 1 7 d - -- first day of the year - let firstDay = toModifiedJulianDay (fromOrdinalDate year 1) - -- 0-based year day of first monday of the year - let firstMonday = (5 - firstDay) `mod` 7 - let yd = firstMonday + 7 * toInteger (w-1) + toInteger d' - yd' <- clipValid 1 (if isLeapYear year then 366 else 365) yd - return (ModifiedJulianDay (firstDay - 1 + yd')) + d' <- clipValid 1 7 d + let + -- first day of the year + firstDay = fromOrdinalDate year 1 + -- 0-based week of year + zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7 + + -- 0-based week number + zbWeek = w - 1 + + -- 0-based day of week + zbDay = d' - 1 + + -- 0-based day in year + zbYearDay = zbFirstMonday + 7 * toInteger zbWeek + toInteger zbDay + + zbYearDay' <- clipValid 0 (if isLeapYear year then 365 else 364) zbYearDay + return $ addDays zbYearDay' firstDay + -- | The inverse of 'sundayStartWeek'. Get a 'Day' given the year and -- the number of the day of a Sunday-starting week. --- The first Sunday is the first day of week 1, any earlier days in the +-- 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 :: Integer -- ^ Year. - -> Int -- ^ Sunday-starting week number. + -> Int -- ^ 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 y w d = ModifiedJulianDay (firstDay + yd) - where yd = firstSunday + 7 * toInteger (w-1) + toInteger d - -- first day of the year - firstDay = toModifiedJulianDay (fromOrdinalDate y 1) - -- 0-based year day of first sunday of the year - firstSunday = (4 - firstDay) `mod` 7 +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 :: Integer -- ^ Year. - -> Int -- ^ Monday-starting week number. - -> Int -- ^ Day of week. - -- Monday is 1, Sunday is 7 (as \"%u\" in 'Data.Time.Format.formatTime'). + -> Int -- ^ 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 -fromSundayStartWeekValid year w d = do - d' <- clipValid 1 7 d - -- first day of the year - let firstDay = toModifiedJulianDay (fromOrdinalDate year 1) - -- 0-based year day of first sunday of the year - let firstMonday = (4 - firstDay) `mod` 7 - let yd = firstMonday + 7 * toInteger (w-1) + toInteger d' - yd' <- clipValid 1 (if isLeapYear year then 366 else 365) yd - return (ModifiedJulianDay (firstDay - 1 + yd')) +fromSundayStartWeekValid year w d = do + d' <- clipValid 0 6 d + let + -- first day of the year + firstDay = fromOrdinalDate year 1 + -- 0-based week of year + zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7 + + -- 0-based week number + zbWeek = w - 1 + + -- 0-based day of week + zbDay = d' + + -- 0-based day in year + zbYearDay = zbFirstSunday + 7 * toInteger zbWeek + toInteger zbDay + + zbYearDay' <- clipValid 0 (if isLeapYear year then 365 else 364) zbYearDay + return $ addDays zbYearDay' firstDay diff --git a/lib/Data/Time/Calendar/Private.hs b/lib/Data/Time/Calendar/Private.hs --- a/lib/Data/Time/Calendar/Private.hs +++ b/lib/Data/Time/Calendar/Private.hs @@ -21,7 +21,7 @@ showPaddedMin _ Nothing i = show i showPaddedMin pl opt i | i < 0 = '-':(showPaddedMin pl opt (negate i)) showPaddedMin pl (Just c) i = - let s = show i in + let s = show i in padN (pl - (length s)) c s show2 :: (Num t,Ord t,Show t) => NumericPadOption -> t -> String diff --git a/lib/Data/Time/Calendar/WeekDate.hs b/lib/Data/Time/Calendar/WeekDate.hs --- a/lib/Data/Time/Calendar/WeekDate.hs +++ b/lib/Data/Time/Calendar/WeekDate.hs @@ -10,43 +10,43 @@ -- The first week of a year is the first week to contain at least four days in the corresponding Gregorian year. toWeekDate :: Day -> (Integer,Int,Int) toWeekDate date@(ModifiedJulianDay mjd) = (y1,fromInteger (w1 + 1),fromInteger d_mod_7 + 1) where - (d_div_7, d_mod_7) = d `divMod` 7 - (y0,yd) = toOrdinalDate date - d = mjd + 2 - foo :: Integer -> Integer - foo y = bar (toModifiedJulianDay (fromOrdinalDate y 6)) - bar k = d_div_7 - k `div` 7 - (y1,w1) = case bar (d - toInteger yd + 4) of - -1 -> (y0 - 1, foo (y0 - 1)) - 52 -> if foo (y0 + 1) == 0 - then (y0 + 1, 0) - else (y0, 52) - w0 -> (y0, w0) - + (d_div_7, d_mod_7) = d `divMod` 7 + (y0,yd) = toOrdinalDate date + d = mjd + 2 + foo :: Integer -> Integer + foo y = bar (toModifiedJulianDay (fromOrdinalDate y 6)) + bar k = d_div_7 - k `div` 7 + (y1,w1) = case bar (d - toInteger yd + 4) of + -1 -> (y0 - 1, foo (y0 - 1)) + 52 -> if foo (y0 + 1) == 0 + then (y0 + 1, 0) + else (y0, 52) + w0 -> (y0, w0) + -- | 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. fromWeekDate :: Integer -> Int -> Int -> Day fromWeekDate y w d = ModifiedJulianDay (k - (mod k 7) + (toInteger (((clip 1 (if longYear then 53 else 52) w) * 7) + (clip 1 7 d))) - 10) where - k = toModifiedJulianDay (fromOrdinalDate y 6) - longYear = case toWeekDate (fromOrdinalDate y 365) of - (_,53,_) -> True - _ -> False + k = toModifiedJulianDay (fromOrdinalDate y 6) + longYear = case toWeekDate (fromOrdinalDate y 365) of + (_,53,_) -> True + _ -> False -- | 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. fromWeekDateValid :: Integer -> Int -> Int -> Maybe Day fromWeekDateValid y w d = do - d' <- clipValid 1 7 d - let - longYear = case toWeekDate (fromOrdinalDate y 365) of - (_,53,_) -> True - _ -> False - w' <- clipValid 1 (if longYear then 53 else 52) w - let - k = toModifiedJulianDay (fromOrdinalDate y 6) - return (ModifiedJulianDay (k - (mod k 7) + (toInteger ((w' * 7) + d')) - 10)) + d' <- clipValid 1 7 d + let + longYear = case toWeekDate (fromOrdinalDate y 365) of + (_,53,_) -> True + _ -> False + w' <- clipValid 1 (if longYear then 53 else 52) w + let + k = toModifiedJulianDay (fromOrdinalDate y 6) + return (ModifiedJulianDay (k - (mod k 7) + (toInteger ((w' * 7) + d')) - 10)) -- | show in ISO 8601 Week Date format as yyyy-Www-d (e.g. \"2006-W46-3\"). showWeekDate :: Day -> String showWeekDate date = (show4 (Just '0') y) ++ "-W" ++ (show2 (Just '0') w) ++ "-" ++ (show d) where - (y,w,d) = toWeekDate date + (y,w,d) = toWeekDate date diff --git a/lib/Data/Time/Clock.hs b/lib/Data/Time/Clock.hs --- a/lib/Data/Time/Clock.hs +++ b/lib/Data/Time/Clock.hs @@ -1,18 +1,15 @@ -- | Types and functions for UTC and UT1 module Data.Time.Clock ( - module Data.Time.Clock.Scale, - module Data.Time.Clock.UTC, - module Data.Time.Clock.UTCDiff, - module Data.Time.Clock + module Data.Time.Clock.Scale, + module Data.Time.Clock.UTC, + module Data.Time.Clock.UTCDiff, + getCurrentTime ) where import Data.Time.Clock.Scale import Data.Time.Clock.UTCDiff import Data.Time.Clock.UTC import Data.Time.Clock.POSIX -import Control.Monad - --- | Get the current UTC time from the system clock. -getCurrentTime :: IO UTCTime -getCurrentTime = liftM posixSecondsToUTCTime getPOSIXTime +import Data.Time.Format.Parse() +import Data.Time.LocalTime() diff --git a/lib/Data/Time/Clock/CTimespec.hsc b/lib/Data/Time/Clock/CTimespec.hsc new file mode 100644 --- /dev/null +++ b/lib/Data/Time/Clock/CTimespec.hsc @@ -0,0 +1,41 @@ +-- #hide +module Data.Time.Clock.CTimespec where + +#include "HsTimeConfig.h" + +#if !defined(mingw32_HOST_OS) && HAVE_CLOCK_GETTIME + +#if __GLASGOW_HASKELL__ >= 709 +import Foreign +#else +import Foreign.Safe +#endif +import Foreign.C + +#include + +data CTimespec = MkCTimespec CTime CLong + +instance Storable CTimespec where + sizeOf _ = #{size struct timespec} + alignment _ = alignment (undefined :: CLong) + peek p = do + s <- #{peek struct timespec, tv_sec } p + ns <- #{peek struct timespec, tv_nsec} p + return (MkCTimespec s ns) + poke p (MkCTimespec s ns) = do + #{poke struct timespec, tv_sec } p s + #{poke struct timespec, tv_nsec} p ns + +foreign import ccall unsafe "time.h clock_gettime" + clock_gettime :: #{type clockid_t} -> Ptr CTimespec -> IO CInt + +-- | Get the current POSIX time from the system clock. +getCTimespec :: IO CTimespec +getCTimespec = alloca (\ptspec -> do + throwErrnoIfMinus1_ "clock_gettime" $ + clock_gettime #{const CLOCK_REALTIME} ptspec + peek ptspec + ) + +#endif diff --git a/lib/Data/Time/Clock/CTimeval.hs b/lib/Data/Time/Clock/CTimeval.hs --- a/lib/Data/Time/Clock/CTimeval.hs +++ b/lib/Data/Time/Clock/CTimeval.hs @@ -4,7 +4,7 @@ #ifndef mingw32_HOST_OS -- All Unix-specific, this -#if __GLASGOW_HASKELL__ >= 709 +#if __GLASGOW_HASKELL__ >= 709 || __GLASGOW_HASKELL__ < 702 import Foreign #else import Foreign.Safe @@ -14,23 +14,23 @@ data CTimeval = MkCTimeval CLong CLong instance Storable CTimeval where - sizeOf _ = (sizeOf (undefined :: CLong)) * 2 - alignment _ = alignment (undefined :: CLong) - peek p = do - s <- peekElemOff (castPtr p) 0 - mus <- peekElemOff (castPtr p) 1 - return (MkCTimeval s mus) - poke p (MkCTimeval s mus) = do - pokeElemOff (castPtr p) 0 s - pokeElemOff (castPtr p) 1 mus + sizeOf _ = (sizeOf (undefined :: CLong)) * 2 + alignment _ = alignment (undefined :: CLong) + peek p = do + s <- peekElemOff (castPtr p) 0 + mus <- peekElemOff (castPtr p) 1 + return (MkCTimeval s mus) + poke p (MkCTimeval s mus) = do + pokeElemOff (castPtr p) 0 s + pokeElemOff (castPtr p) 1 mus foreign import ccall unsafe "time.h gettimeofday" gettimeofday :: Ptr CTimeval -> Ptr () -> IO CInt -- | Get the current POSIX time from the system clock. getCTimeval :: IO CTimeval getCTimeval = with (MkCTimeval 0 0) (\ptval -> do - throwErrnoIfMinus1_ "gettimeofday" $ gettimeofday ptval nullPtr - peek ptval - ) + throwErrnoIfMinus1_ "gettimeofday" $ gettimeofday ptval nullPtr + peek ptval + ) #endif diff --git a/lib/Data/Time/Clock/POSIX.hs b/lib/Data/Time/Clock/POSIX.hs --- a/lib/Data/Time/Clock/POSIX.hs +++ b/lib/Data/Time/Clock/POSIX.hs @@ -2,7 +2,7 @@ -- Most people won't need this module. module Data.Time.Clock.POSIX ( - posixDayLength,POSIXTime,posixSecondsToUTCTime,utcTimeToPOSIXSeconds,getPOSIXTime + posixDayLength,POSIXTime,posixSecondsToUTCTime,utcTimeToPOSIXSeconds,getPOSIXTime,getCurrentTime ) where import Data.Time.Clock.UTC @@ -10,9 +10,14 @@ import Data.Fixed import Control.Monad +#include "HsTimeConfig.h" + #ifdef mingw32_HOST_OS -import Data.Word ( Word64) +import Data.Word ( Word64) import System.Win32.Time +#elif HAVE_CLOCK_GETTIME +import Data.Time.Clock.CTimespec +import Foreign.C.Types (CTime(..)) #else import Data.Time.Clock.CTimeval #endif @@ -22,7 +27,7 @@ posixDayLength = 86400 -- | POSIX time is the nominal time since 1970-01-01 00:00 UTC --- +-- -- To convert from a 'Foreign.C.CTime' or 'System.Posix.EpochTime', use 'realToFrac'. -- type POSIXTime = NominalDiffTime @@ -32,7 +37,7 @@ posixSecondsToUTCTime :: POSIXTime -> UTCTime posixSecondsToUTCTime i = let - (d,t) = divMod' i posixDayLength + (d,t) = divMod' i posixDayLength in UTCTime (addDays d unixEpochDay) (realToFrac t) utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime @@ -55,6 +60,15 @@ win32_epoch_adjust :: Word64 win32_epoch_adjust = 116444736000000000 +#elif HAVE_CLOCK_GETTIME + +-- Use hi-res POSIX time +ctimespecToPosixSeconds :: CTimespec -> POSIXTime +ctimespecToPosixSeconds (MkCTimespec (CTime s) ns) = + (fromIntegral s) + (fromIntegral ns) / 1000000000 + +getPOSIXTime = liftM ctimespecToPosixSeconds getCTimespec + #else -- Use POSIX time @@ -64,3 +78,7 @@ getPOSIXTime = liftM ctimevalToPosixSeconds getCTimeval #endif + +-- | Get the current UTC time from the system clock. +getCurrentTime :: IO UTCTime +getCurrentTime = liftM posixSecondsToUTCTime getPOSIXTime diff --git a/lib/Data/Time/Clock/Scale.hs b/lib/Data/Time/Clock/Scale.hs --- a/lib/Data/Time/Clock/Scale.hs +++ b/lib/Data/Time/Clock/Scale.hs @@ -1,16 +1,20 @@ +#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} +#endif {-# OPTIONS -fno-warn-unused-imports #-} #include "HsConfigure.h" -- #hide module Data.Time.Clock.Scale ( - -- * Universal Time - -- | Time as measured by the earth. - UniversalTime(..), + -- * Universal Time + -- | Time as measured by the earth. + UniversalTime(..), - -- * Absolute intervals - DiffTime, - secondsToDiffTime, picosecondsToDiffTime + -- * Absolute intervals + DiffTime, + secondsToDiffTime, + picosecondsToDiffTime, + diffTimeToPicoseconds, ) where import Control.DeepSeq @@ -33,7 +37,7 @@ -- necessary because H98 doesn't have "cunning newtype" derivation instance NFData UniversalTime where - rnf (ModJulianDate a) = rnf a + rnf (ModJulianDate a) = rnf a -- | This is a length of time, as measured by a clock. -- Conversion functions will treat it as seconds. @@ -55,37 +59,37 @@ -- necessary because H98 doesn't have "cunning newtype" derivation instance Enum DiffTime where - succ (MkDiffTime a) = MkDiffTime (succ a) - pred (MkDiffTime a) = MkDiffTime (pred a) - toEnum = MkDiffTime . toEnum - fromEnum (MkDiffTime a) = fromEnum a - enumFrom (MkDiffTime a) = fmap MkDiffTime (enumFrom a) - enumFromThen (MkDiffTime a) (MkDiffTime b) = fmap MkDiffTime (enumFromThen a b) - enumFromTo (MkDiffTime a) (MkDiffTime b) = fmap MkDiffTime (enumFromTo a b) - enumFromThenTo (MkDiffTime a) (MkDiffTime b) (MkDiffTime c) = fmap MkDiffTime (enumFromThenTo a b c) + succ (MkDiffTime a) = MkDiffTime (succ a) + pred (MkDiffTime a) = MkDiffTime (pred a) + toEnum = MkDiffTime . toEnum + fromEnum (MkDiffTime a) = fromEnum a + enumFrom (MkDiffTime a) = fmap MkDiffTime (enumFrom a) + enumFromThen (MkDiffTime a) (MkDiffTime b) = fmap MkDiffTime (enumFromThen a b) + enumFromTo (MkDiffTime a) (MkDiffTime b) = fmap MkDiffTime (enumFromTo a b) + enumFromThenTo (MkDiffTime a) (MkDiffTime b) (MkDiffTime c) = fmap MkDiffTime (enumFromThenTo a b c) instance Show DiffTime where - show (MkDiffTime t) = (showFixed True t) ++ "s" + show (MkDiffTime t) = (showFixed True t) ++ "s" -- necessary because H98 doesn't have "cunning newtype" derivation instance Num DiffTime where - (MkDiffTime a) + (MkDiffTime b) = MkDiffTime (a + b) - (MkDiffTime a) - (MkDiffTime b) = MkDiffTime (a - b) - (MkDiffTime a) * (MkDiffTime b) = MkDiffTime (a * b) - negate (MkDiffTime a) = MkDiffTime (negate a) - abs (MkDiffTime a) = MkDiffTime (abs a) - signum (MkDiffTime a) = MkDiffTime (signum a) - fromInteger i = MkDiffTime (fromInteger i) + (MkDiffTime a) + (MkDiffTime b) = MkDiffTime (a + b) + (MkDiffTime a) - (MkDiffTime b) = MkDiffTime (a - b) + (MkDiffTime a) * (MkDiffTime b) = MkDiffTime (a * b) + negate (MkDiffTime a) = MkDiffTime (negate a) + abs (MkDiffTime a) = MkDiffTime (abs a) + signum (MkDiffTime a) = MkDiffTime (signum a) + fromInteger i = MkDiffTime (fromInteger i) -- necessary because H98 doesn't have "cunning newtype" derivation instance Real DiffTime where - toRational (MkDiffTime a) = toRational a + toRational (MkDiffTime a) = toRational a -- necessary because H98 doesn't have "cunning newtype" derivation instance Fractional DiffTime where - (MkDiffTime a) / (MkDiffTime b) = MkDiffTime (a / b) - recip (MkDiffTime a) = MkDiffTime (recip a) - fromRational r = MkDiffTime (fromRational r) + (MkDiffTime a) / (MkDiffTime b) = MkDiffTime (a / b) + recip (MkDiffTime a) = MkDiffTime (recip a) + fromRational r = MkDiffTime (fromRational r) -- necessary because H98 doesn't have "cunning newtype" derivation instance RealFrac DiffTime where @@ -101,10 +105,13 @@ -- | Create a 'DiffTime' from a number of picoseconds. picosecondsToDiffTime :: Integer -> DiffTime -picosecondsToDiffTime x = fromRational (x % 1000000000000) +picosecondsToDiffTime x = MkDiffTime (MkFixed x) +-- | Get the number of picoseconds in a 'DiffTime'. +diffTimeToPicoseconds :: DiffTime -> Integer +diffTimeToPicoseconds (MkDiffTime (MkFixed x)) = x + {-# RULES "realToFrac/DiffTime->Pico" realToFrac = \ (MkDiffTime ps) -> ps "realToFrac/Pico->DiffTime" realToFrac = MkDiffTime #-} - diff --git a/lib/Data/Time/Clock/TAI.hs b/lib/Data/Time/Clock/TAI.hs --- a/lib/Data/Time/Clock/TAI.hs +++ b/lib/Data/Time/Clock/TAI.hs @@ -3,16 +3,16 @@ -- | TAI and leap-second tables for converting to UTC: most people won't need this module. module Data.Time.Clock.TAI ( - -- TAI arithmetic - AbsoluteTime,taiEpoch,addAbsoluteTime,diffAbsoluteTime, + -- TAI arithmetic + AbsoluteTime,taiEpoch,addAbsoluteTime,diffAbsoluteTime, - -- leap-second table type - LeapSecondTable, + -- leap-second table type + LeapSecondTable, - -- conversion between UTC and TAI with table - utcDayLength,utcToTAITime,taiToUTCTime, + -- conversion between UTC and TAI with table + utcDayLength,utcToTAITime,taiToUTCTime, - parseTAIUTCDATFile + parseTAIUTCDATFile ) where import Data.Time.LocalTime @@ -37,10 +37,10 @@ ) instance NFData AbsoluteTime where - rnf (MkAbsoluteTime a) = rnf a + rnf (MkAbsoluteTime a) = rnf a instance Show AbsoluteTime where - show t = show (utcToLocalTime utc (taiToUTCTime (const 0) t)) ++ " TAI" -- ugly, but standard apparently + show t = show (utcToLocalTime utc (taiToUTCTime (const 0) t)) ++ " TAI" -- ugly, but standard apparently -- | The epoch of TAI, which is 1858-11-17 00:00:00 TAI. taiEpoch :: AbsoluteTime @@ -63,80 +63,80 @@ utcDayLength table day = realToFrac (86400 + (table (addDays 1 day)) - (table day)) dayStart :: LeapSecondTable -> Day -> AbsoluteTime -dayStart table day = MkAbsoluteTime (realToFrac ((toModifiedJulianDay day) * 86400 + (table day))) +dayStart table day = MkAbsoluteTime (realToFrac ((toModifiedJulianDay day) * 86400 + (table day))) utcToTAITime :: LeapSecondTable -> UTCTime -> AbsoluteTime utcToTAITime table (UTCTime day dtime) = MkAbsoluteTime (t + dtime) where - MkAbsoluteTime t = dayStart table day + MkAbsoluteTime t = dayStart table day taiToUTCTime :: LeapSecondTable -> AbsoluteTime -> UTCTime taiToUTCTime table abstime = stable (ModifiedJulianDay (div' (unAbsoluteTime abstime) 86400)) where - stable day = if (day == day') then UTCTime day dtime else stable day' where - dayt = dayStart table day - dtime = diffAbsoluteTime abstime dayt - day' = addDays (div' dtime (utcDayLength table day)) day + stable day = if (day == day') then UTCTime day dtime else stable day' where + dayt = dayStart table day + dtime = diffAbsoluteTime abstime dayt + day' = addDays (div' dtime (utcDayLength table day)) day -- | Parse the contents of a tai-utc.dat file. -- This does not do any kind of validation and will return a bad table for input -- not in the correct format. parseTAIUTCDATFile :: String -> LeapSecondTable parseTAIUTCDATFile ss = offsetlist 0 (parse (lines ss)) where - offsetlist :: Integer -> [(Day,Integer)] -> LeapSecondTable - offsetlist i [] _ = i - offsetlist i ((d0,_):_) d | d < d0 = i - offsetlist _ ((_,i0):xx) d = offsetlist i0 xx d - - parse :: [String] -> [(Day,Integer)] - parse [] = [] - parse (a:as) = let - ps = parse as - in case matchLine a of - Just di -> di:ps - Nothing -> ps - - matchLine :: String -> Maybe (Day,Integer) - matchLine s = do - check0S s - (d,s') <- findJD s - i <- findOffset s' - return (d,i) - - -- a bit fragile - check0S :: String -> Maybe () - check0S "X 0.0 S" = Just () - check0S [] = Nothing - check0S (_:cs) = check0S cs - - findJD :: String -> Maybe (Day,String) - findJD ('=':'J':'D':s) = do - d <- getInteger '5' s - return (ModifiedJulianDay (d - 2400000),s) - findJD [] = Nothing - findJD (_:cs) = findJD cs - - findOffset :: String -> Maybe Integer - findOffset ('T':'A':'I':'-':'U':'T':'C':'=':s) = getInteger '0' s - findOffset [] = Nothing - findOffset (_:cs) = findOffset cs - - getInteger :: Char -> String -> Maybe Integer - getInteger p s = do - digits <- getDigits p s - fromDigits 0 digits - - getDigits :: Char -> String -> Maybe String - getDigits p (' ':s) = getDigits p s - getDigits p (c:cs) | c >= '0' && c <= '9' = do - s <- getDigits p cs - return (c:s) - getDigits p ('.':p1:_) = if p == p1 then Just [] else Nothing - getDigits _ _ = Nothing - - - fromDigits :: Integer -> String -> Maybe Integer - fromDigits i [] = Just i - fromDigits i (c:cs) | c >= '0' && c <= '9' = fromDigits ((i * 10) + (fromIntegral ((fromEnum c) - (fromEnum '0')))) cs - fromDigits _ _ = Nothing + offsetlist :: Integer -> [(Day,Integer)] -> LeapSecondTable + offsetlist i [] _ = i + offsetlist i ((d0,_):_) d | d < d0 = i + offsetlist _ ((_,i0):xx) d = offsetlist i0 xx d + + parse :: [String] -> [(Day,Integer)] + parse [] = [] + parse (a:as) = let + ps = parse as + in case matchLine a of + Just di -> di:ps + Nothing -> ps + + matchLine :: String -> Maybe (Day,Integer) + matchLine s = do + check0S s + (d,s') <- findJD s + i <- findOffset s' + return (d,i) + + -- a bit fragile + check0S :: String -> Maybe () + check0S "X 0.0 S" = Just () + check0S [] = Nothing + check0S (_:cs) = check0S cs + + findJD :: String -> Maybe (Day,String) + findJD ('=':'J':'D':s) = do + d <- getInteger '5' s + return (ModifiedJulianDay (d - 2400000),s) + findJD [] = Nothing + findJD (_:cs) = findJD cs + + findOffset :: String -> Maybe Integer + findOffset ('T':'A':'I':'-':'U':'T':'C':'=':s) = getInteger '0' s + findOffset [] = Nothing + findOffset (_:cs) = findOffset cs + + getInteger :: Char -> String -> Maybe Integer + getInteger p s = do + digits <- getDigits p s + fromDigits 0 digits + + getDigits :: Char -> String -> Maybe String + getDigits p (' ':s) = getDigits p s + getDigits p (c:cs) | c >= '0' && c <= '9' = do + s <- getDigits p cs + return (c:s) + getDigits p ('.':p1:_) = if p == p1 then Just [] else Nothing + getDigits _ _ = Nothing + + + fromDigits :: Integer -> String -> Maybe Integer + fromDigits i [] = Just i + fromDigits i (c:cs) | c >= '0' && c <= '9' = fromDigits ((i * 10) + (fromIntegral ((fromEnum c) - (fromEnum '0')))) cs + fromDigits _ _ = Nothing -- typical line format: -- 1972 JAN 1 =JD 2441317.5 TAI-UTC= 10.0 S + (MJD - 41317.) X 0.0 S diff --git a/lib/Data/Time/Clock/UTC.hs b/lib/Data/Time/Clock/UTC.hs --- a/lib/Data/Time/Clock/UTC.hs +++ b/lib/Data/Time/Clock/UTC.hs @@ -1,19 +1,21 @@ {-# OPTIONS -fno-warn-unused-imports #-} +#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} +#endif #include "HsConfigure.h" -- #hide module Data.Time.Clock.UTC ( - -- * 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. - -- No table of these corrections is provided, as any program compiled with it would become - -- out of date in six months. - -- - -- If you don't care about leap seconds, use UTCTime and NominalDiffTime for your clock calculations, - -- and you'll be fine. - UTCTime(..),NominalDiffTime + -- * 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. + -- No table of these corrections is provided, as any program compiled with it would become + -- out of date in six months. + -- + -- If you don't care about leap seconds, use UTCTime and NominalDiffTime for your clock calculations, + -- and you'll be fine. + UTCTime(..),NominalDiffTime ) where import Control.DeepSeq @@ -29,10 +31,10 @@ -- 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 { - -- | the day - utctDay :: Day, - -- | the time from midnight, 0 <= t < 86401s (because of leap-seconds) - utctDayTime :: DiffTime + -- | the day + utctDay :: Day, + -- | the time from midnight, 0 <= t < 86401s (because of leap-seconds) + utctDayTime :: DiffTime } #if LANGUAGE_DeriveDataTypeable #if LANGUAGE_Rank2Types @@ -43,15 +45,15 @@ #endif instance NFData UTCTime where - rnf (UTCTime d t) = d `deepseq` t `deepseq` () + rnf (UTCTime d t) = d `deepseq` t `deepseq` () instance Eq UTCTime where - (UTCTime da ta) == (UTCTime db tb) = (da == db) && (ta == tb) + (UTCTime da ta) == (UTCTime db tb) = (da == db) && (ta == tb) instance Ord UTCTime where - compare (UTCTime da ta) (UTCTime db tb) = case (compare da db) of - EQ -> compare ta tb - cmp -> cmp + compare (UTCTime da ta) (UTCTime db tb) = case (compare da db) of + EQ -> compare ta tb + cmp -> cmp -- | This is a length of time, as measured by UTC. -- Conversion functions will treat it as seconds. @@ -74,46 +76,46 @@ rnf ndt = seq ndt () instance Enum NominalDiffTime where - succ (MkNominalDiffTime a) = MkNominalDiffTime (succ a) - pred (MkNominalDiffTime a) = MkNominalDiffTime (pred a) - toEnum = MkNominalDiffTime . toEnum - fromEnum (MkNominalDiffTime a) = fromEnum a - enumFrom (MkNominalDiffTime a) = fmap MkNominalDiffTime (enumFrom a) - enumFromThen (MkNominalDiffTime a) (MkNominalDiffTime b) = fmap MkNominalDiffTime (enumFromThen a b) - enumFromTo (MkNominalDiffTime a) (MkNominalDiffTime b) = fmap MkNominalDiffTime (enumFromTo a b) - enumFromThenTo (MkNominalDiffTime a) (MkNominalDiffTime b) (MkNominalDiffTime c) = fmap MkNominalDiffTime (enumFromThenTo a b c) + succ (MkNominalDiffTime a) = MkNominalDiffTime (succ a) + pred (MkNominalDiffTime a) = MkNominalDiffTime (pred a) + toEnum = MkNominalDiffTime . toEnum + fromEnum (MkNominalDiffTime a) = fromEnum a + enumFrom (MkNominalDiffTime a) = fmap MkNominalDiffTime (enumFrom a) + enumFromThen (MkNominalDiffTime a) (MkNominalDiffTime b) = fmap MkNominalDiffTime (enumFromThen a b) + enumFromTo (MkNominalDiffTime a) (MkNominalDiffTime b) = fmap MkNominalDiffTime (enumFromTo a b) + enumFromThenTo (MkNominalDiffTime a) (MkNominalDiffTime b) (MkNominalDiffTime c) = fmap MkNominalDiffTime (enumFromThenTo a b c) instance Show NominalDiffTime where - show (MkNominalDiffTime t) = (showFixed True t) ++ "s" + show (MkNominalDiffTime t) = (showFixed True t) ++ "s" -- necessary because H98 doesn't have "cunning newtype" derivation instance Num NominalDiffTime where - (MkNominalDiffTime a) + (MkNominalDiffTime b) = MkNominalDiffTime (a + b) - (MkNominalDiffTime a) - (MkNominalDiffTime b) = MkNominalDiffTime (a - b) - (MkNominalDiffTime a) * (MkNominalDiffTime b) = MkNominalDiffTime (a * b) - negate (MkNominalDiffTime a) = MkNominalDiffTime (negate a) - abs (MkNominalDiffTime a) = MkNominalDiffTime (abs a) - signum (MkNominalDiffTime a) = MkNominalDiffTime (signum a) - fromInteger i = MkNominalDiffTime (fromInteger i) + (MkNominalDiffTime a) + (MkNominalDiffTime b) = MkNominalDiffTime (a + b) + (MkNominalDiffTime a) - (MkNominalDiffTime b) = MkNominalDiffTime (a - b) + (MkNominalDiffTime a) * (MkNominalDiffTime b) = MkNominalDiffTime (a * b) + negate (MkNominalDiffTime a) = MkNominalDiffTime (negate a) + abs (MkNominalDiffTime a) = MkNominalDiffTime (abs a) + signum (MkNominalDiffTime a) = MkNominalDiffTime (signum a) + fromInteger i = MkNominalDiffTime (fromInteger i) -- necessary because H98 doesn't have "cunning newtype" derivation instance Real NominalDiffTime where - toRational (MkNominalDiffTime a) = toRational a + toRational (MkNominalDiffTime a) = toRational a -- necessary because H98 doesn't have "cunning newtype" derivation instance Fractional NominalDiffTime where - (MkNominalDiffTime a) / (MkNominalDiffTime b) = MkNominalDiffTime (a / b) - recip (MkNominalDiffTime a) = MkNominalDiffTime (recip a) - fromRational r = MkNominalDiffTime (fromRational r) + (MkNominalDiffTime a) / (MkNominalDiffTime b) = MkNominalDiffTime (a / b) + recip (MkNominalDiffTime a) = MkNominalDiffTime (recip a) + fromRational r = MkNominalDiffTime (fromRational r) -- necessary because H98 doesn't have "cunning newtype" derivation instance RealFrac NominalDiffTime where - properFraction (MkNominalDiffTime a) = (i,MkNominalDiffTime f) where - (i,f) = properFraction a - truncate (MkNominalDiffTime a) = truncate a - round (MkNominalDiffTime a) = round a - ceiling (MkNominalDiffTime a) = ceiling a - floor (MkNominalDiffTime a) = floor a + properFraction (MkNominalDiffTime a) = (i,MkNominalDiffTime f) where + (i,f) = properFraction a + truncate (MkNominalDiffTime a) = truncate a + round (MkNominalDiffTime a) = round a + ceiling (MkNominalDiffTime a) = ceiling a + floor (MkNominalDiffTime a) = floor a {-# RULES "realToFrac/DiffTime->NominalDiffTime" realToFrac = \ dt -> MkNominalDiffTime (realToFrac dt) @@ -122,4 +124,3 @@ "realToFrac/NominalDiffTime->Pico" realToFrac = \ (MkNominalDiffTime ps) -> ps "realToFrac/Pico->NominalDiffTime" realToFrac = MkNominalDiffTime #-} - diff --git a/lib/Data/Time/Format.hs b/lib/Data/Time/Format.hs --- a/lib/Data/Time/Format.hs +++ b/lib/Data/Time/Format.hs @@ -1,17 +1,22 @@ module Data.Time.Format - ( - -- * UNIX-style formatting - NumericPadOption,FormatTime(..),formatTime, - module Data.Time.Format.Parse - ) where + ( + -- * UNIX-style formatting + NumericPadOption,FormatTime(..),formatTime, + module Data.Time.Format.Parse + ) where import Data.Time.Format.Parse -import Data.Time.LocalTime + +import Data.Time.LocalTime.TimeZone +import Data.Time.LocalTime.TimeOfDay +import Data.Time.LocalTime.LocalTime +import Data.Time.Calendar.Days +import Data.Time.Calendar.Gregorian import Data.Time.Calendar.WeekDate import Data.Time.Calendar.OrdinalDate -import Data.Time.Calendar import Data.Time.Calendar.Private -import Data.Time.Clock +import Data.Time.Clock.Scale +import Data.Time.Clock.UTC import Data.Time.Clock.POSIX import Data.Maybe @@ -20,15 +25,15 @@ -- class FormatTime t where - formatCharacter :: Char -> Maybe (TimeLocale -> Maybe NumericPadOption -> t -> String) + formatCharacter :: Char -> Maybe (TimeLocale -> Maybe NumericPadOption -> t -> String) formatChar :: (FormatTime t) => Char -> TimeLocale -> Maybe NumericPadOption -> t -> String formatChar '%' _ _ _ = "%" formatChar 't' _ _ _ = "\t" formatChar 'n' _ _ _ = "\n" formatChar c locale mpado t = case (formatCharacter c) of - Just f -> f locale mpado t - _ -> "" + Just f -> f locale mpado t + _ -> "" -- | Substitute various time-related information for each %-code in the string, as per 'formatCharacter'. -- @@ -58,11 +63,11 @@ -- -- [@%Z@] timezone name -- --- For 'LocalTime' (and 'ZonedTime' and 'UTCTime'): +-- For 'LocalTime' (and 'ZonedTime' and 'UTCTime' and 'UniversalTime'): -- -- [@%c@] as 'dateTimeFmt' @locale@ (e.g. @%a %b %e %H:%M:%S %Z %Y@) -- --- For 'TimeOfDay' (and 'LocalTime' and 'ZonedTime' and 'UTCTime'): +-- For 'TimeOfDay' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'): -- -- [@%R@] same as @%H:%M@ -- @@ -96,11 +101,11 @@ -- For 'UTCTime' and 'ZonedTime': -- -- [@%s@] number of whole seconds since the Unix epoch. For times before --- the Unix epoch, this is a negative number. Note that in @%s.%q@ and @%s%Q@ +-- the Unix epoch, this is a negative number. Note that in @%s.%q@ and @%s%Q@ -- the decimals are positive, not negative. For example, 0.9 seconds -- before the Unix epoch is formatted as @-1.1@ with @%s%Q@. -- --- For 'Day' (and 'LocalTime' and 'ZonedTime' and 'UTCTime'): +-- For 'Day' (and 'LocalTime' and 'ZonedTime' and 'UTCTime' and 'UniversalTime'): -- -- [@%D@] same as @%m\/%d\/%y@ -- @@ -108,7 +113,7 @@ -- -- [@%x@] as 'dateFmt' @locale@ (e.g. @%m\/%d\/%y@) -- --- [@%Y@] year, no padding. Note @%0y@ and @%_y@ pad to four chars +-- [@%Y@] year, no padding. Note @%0Y@ and @%_Y@ pad to four chars -- -- [@%y@] year of century, 0-padded to two chars, @00@ - @99@ -- @@ -156,91 +161,94 @@ formatTime locale (c:cs) t = c:(formatTime locale cs t) instance FormatTime LocalTime where - formatCharacter 'c' = Just (\locale _ -> formatTime locale (dateTimeFmt locale)) - formatCharacter c = case (formatCharacter c) of - Just f -> Just (\locale mpado dt -> f locale mpado (localDay dt)) - Nothing -> case (formatCharacter c) of - Just f -> Just (\locale mpado dt -> f locale mpado (localTimeOfDay dt)) - Nothing -> Nothing + formatCharacter 'c' = Just (\locale _ -> formatTime locale (dateTimeFmt locale)) + formatCharacter c = case (formatCharacter c) of + Just f -> Just (\locale mpado dt -> f locale mpado (localDay dt)) + Nothing -> case (formatCharacter c) of + Just f -> Just (\locale mpado dt -> f locale mpado (localTimeOfDay dt)) + Nothing -> Nothing instance FormatTime TimeOfDay where - -- Aggregate - formatCharacter 'R' = Just (\locale _ -> formatTime locale "%H:%M") - formatCharacter 'T' = Just (\locale _ -> formatTime locale "%H:%M:%S") - formatCharacter 'X' = Just (\locale _ -> formatTime locale (timeFmt locale)) - formatCharacter 'r' = Just (\locale _ -> formatTime locale (time12Fmt locale)) - -- AM/PM - formatCharacter 'P' = Just (\locale _ day -> map toLower ((if (todHour day) < 12 then fst else snd) (amPm locale))) - formatCharacter 'p' = Just (\locale _ day -> (if (todHour day) < 12 then fst else snd) (amPm locale)) - -- Hour - formatCharacter 'H' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . todHour) - formatCharacter 'I' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\h -> (mod (h - 1) 12) + 1) . todHour) - formatCharacter 'k' = Just (\_ opt -> (show2 (fromMaybe (Just ' ') opt)) . todHour) - formatCharacter 'l' = Just (\_ opt -> (show2 (fromMaybe (Just ' ') opt)) . (\h -> (mod (h - 1) 12) + 1) . todHour) - -- Minute - formatCharacter 'M' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . todMin) - -- Second - formatCharacter 'S' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt) :: Int -> String) . truncate . todSec) - formatCharacter 'q' = Just (\_ _ -> drop 1 . dropWhile (/='.') . showFixed False . todSec) - formatCharacter 'Q' = Just (\_ _ -> dropWhile (/='.') . showFixed True . todSec) + -- Aggregate + formatCharacter 'R' = Just (\locale _ -> formatTime locale "%H:%M") + formatCharacter 'T' = Just (\locale _ -> formatTime locale "%H:%M:%S") + formatCharacter 'X' = Just (\locale _ -> formatTime locale (timeFmt locale)) + formatCharacter 'r' = Just (\locale _ -> formatTime locale (time12Fmt locale)) + -- AM/PM + formatCharacter 'P' = Just (\locale _ day -> map toLower ((if (todHour day) < 12 then fst else snd) (amPm locale))) + formatCharacter 'p' = Just (\locale _ day -> (if (todHour day) < 12 then fst else snd) (amPm locale)) + -- Hour + formatCharacter 'H' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . todHour) + formatCharacter 'I' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\h -> (mod (h - 1) 12) + 1) . todHour) + formatCharacter 'k' = Just (\_ opt -> (show2 (fromMaybe (Just ' ') opt)) . todHour) + formatCharacter 'l' = Just (\_ opt -> (show2 (fromMaybe (Just ' ') opt)) . (\h -> (mod (h - 1) 12) + 1) . todHour) + -- Minute + formatCharacter 'M' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . todMin) + -- Second + formatCharacter 'S' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt) :: Int -> String) . truncate . todSec) + formatCharacter 'q' = Just (\_ _ -> drop 1 . dropWhile (/='.') . showFixed False . todSec) + formatCharacter 'Q' = Just (\_ _ -> dropWhile (/='.') . showFixed True . todSec) - -- Default - formatCharacter _ = Nothing + -- Default + formatCharacter _ = Nothing instance FormatTime ZonedTime where - formatCharacter 'c' = Just (\locale _ -> formatTime locale (dateTimeFmt locale)) - formatCharacter 's' = Just (\_ _ zt -> show (floor (utcTimeToPOSIXSeconds (zonedTimeToUTC zt)) :: Integer)) - formatCharacter c = case (formatCharacter c) of - Just f -> Just (\locale mpado dt -> f locale mpado (zonedTimeToLocalTime dt)) - Nothing -> case (formatCharacter c) of - Just f -> Just (\locale mpado dt -> f locale mpado (zonedTimeZone dt)) - Nothing -> Nothing + formatCharacter 'c' = Just (\locale _ -> formatTime locale (dateTimeFmt locale)) + formatCharacter 's' = Just (\_ _ zt -> show (floor (utcTimeToPOSIXSeconds (zonedTimeToUTC zt)) :: Integer)) + formatCharacter c = case (formatCharacter c) of + Just f -> Just (\locale mpado dt -> f locale mpado (zonedTimeToLocalTime dt)) + Nothing -> case (formatCharacter c) of + Just f -> Just (\locale mpado dt -> f locale mpado (zonedTimeZone dt)) + Nothing -> Nothing instance FormatTime TimeZone where - formatCharacter 'z' = Just (\_ opt -> timeZoneOffsetString' (fromMaybe (Just '0') opt)) - formatCharacter 'Z' = + formatCharacter 'z' = Just (\_ opt -> timeZoneOffsetString' (fromMaybe (Just '0') opt)) + formatCharacter 'Z' = Just (\_ opt z -> let n = timeZoneName z in if null n then timeZoneOffsetString' (fromMaybe (Just '0') opt) z else n) - formatCharacter _ = Nothing + formatCharacter _ = Nothing instance FormatTime Day where - -- Aggregate - formatCharacter 'D' = Just (\locale _ -> formatTime locale "%m/%d/%y") - formatCharacter 'F' = Just (\locale _ -> formatTime locale "%Y-%m-%d") - formatCharacter 'x' = Just (\locale _ -> formatTime locale (dateFmt locale)) + -- Aggregate + formatCharacter 'D' = Just (\locale _ -> formatTime locale "%m/%d/%y") + formatCharacter 'F' = Just (\locale _ -> formatTime locale "%Y-%m-%d") + formatCharacter 'x' = Just (\locale _ -> formatTime locale (dateFmt locale)) - -- Year Count - formatCharacter 'Y' = Just (\_ opt -> (show4 (fromMaybe Nothing opt)) . fst . toOrdinalDate) - formatCharacter 'y' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . mod100 . fst . toOrdinalDate) - formatCharacter 'C' = Just (\_ opt -> (show2 (fromMaybe Nothing opt)) . div100 . fst . toOrdinalDate) - -- Month of Year - formatCharacter 'B' = Just (\locale _ -> fst . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian) - formatCharacter 'b' = Just (\locale _ -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian) - formatCharacter 'h' = Just (\locale _ -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian) - formatCharacter 'm' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\(_,m,_) -> m) . toGregorian) - -- Day of Month - formatCharacter 'd' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\(_,_,d) -> d) . toGregorian) - formatCharacter 'e' = Just (\_ opt -> (show2 (fromMaybe (Just ' ') opt)) . (\(_,_,d) -> d) . toGregorian) - -- Day of Year - formatCharacter 'j' = Just (\_ opt -> (show3 (fromMaybe (Just '0') opt)) . snd . toOrdinalDate) + -- Year Count + formatCharacter 'Y' = Just (\_ opt -> (show4 (fromMaybe Nothing opt)) . fst . toOrdinalDate) + formatCharacter 'y' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . mod100 . fst . toOrdinalDate) + formatCharacter 'C' = Just (\_ opt -> (show2 (fromMaybe Nothing opt)) . div100 . fst . toOrdinalDate) + -- Month of Year + formatCharacter 'B' = Just (\locale _ -> fst . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian) + formatCharacter 'b' = Just (\locale _ -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian) + formatCharacter 'h' = Just (\locale _ -> snd . (\(_,m,_) -> (months locale) !! (m - 1)) . toGregorian) + formatCharacter 'm' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\(_,m,_) -> m) . toGregorian) + -- Day of Month + formatCharacter 'd' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\(_,_,d) -> d) . toGregorian) + formatCharacter 'e' = Just (\_ opt -> (show2 (fromMaybe (Just ' ') opt)) . (\(_,_,d) -> d) . toGregorian) + -- Day of Year + formatCharacter 'j' = Just (\_ opt -> (show3 (fromMaybe (Just '0') opt)) . snd . toOrdinalDate) - -- ISO 8601 Week Date - formatCharacter 'G' = Just (\_ opt -> (show4 (fromMaybe Nothing opt)) . (\(y,_,_) -> y) . toWeekDate) - formatCharacter 'g' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . mod100 . (\(y,_,_) -> y) . toWeekDate) - formatCharacter 'f' = Just (\_ opt -> (show2 (fromMaybe Nothing opt)) . div100 . (\(y,_,_) -> y) . toWeekDate) + -- ISO 8601 Week Date + formatCharacter 'G' = Just (\_ opt -> (show4 (fromMaybe Nothing opt)) . (\(y,_,_) -> y) . toWeekDate) + formatCharacter 'g' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . mod100 . (\(y,_,_) -> y) . toWeekDate) + formatCharacter 'f' = Just (\_ opt -> (show2 (fromMaybe Nothing opt)) . div100 . (\(y,_,_) -> y) . toWeekDate) - formatCharacter 'V' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\(_,w,_) -> w) . toWeekDate) - formatCharacter 'u' = Just (\_ _ -> show . (\(_,_,d) -> d) . toWeekDate) + formatCharacter 'V' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . (\(_,w,_) -> w) . toWeekDate) + formatCharacter 'u' = Just (\_ _ -> show . (\(_,_,d) -> d) . toWeekDate) - -- Day of week - formatCharacter 'a' = Just (\locale _ -> snd . ((wDays locale) !!) . snd . sundayStartWeek) - formatCharacter 'A' = Just (\locale _ -> fst . ((wDays locale) !!) . snd . sundayStartWeek) - formatCharacter 'U' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . fst . sundayStartWeek) - formatCharacter 'w' = Just (\_ _ -> show . snd . sundayStartWeek) - formatCharacter 'W' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . fst . mondayStartWeek) - - -- Default - formatCharacter _ = Nothing + -- Day of week + formatCharacter 'a' = Just (\locale _ -> snd . ((wDays locale) !!) . snd . sundayStartWeek) + formatCharacter 'A' = Just (\locale _ -> fst . ((wDays locale) !!) . snd . sundayStartWeek) + formatCharacter 'U' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . fst . sundayStartWeek) + formatCharacter 'w' = Just (\_ _ -> show . snd . sundayStartWeek) + formatCharacter 'W' = Just (\_ opt -> (show2 (fromMaybe (Just '0') opt)) . fst . mondayStartWeek) + -- Default + formatCharacter _ = Nothing + instance FormatTime UTCTime where - formatCharacter c = fmap (\f locale mpado t -> f locale mpado (utcToZonedTime utc t)) (formatCharacter c) + formatCharacter c = fmap (\f locale mpado t -> f locale mpado (utcToZonedTime utc t)) (formatCharacter c) + +instance FormatTime UniversalTime where + formatCharacter c = fmap (\f locale mpado t -> f locale mpado (ut1ToLocalTime 0 t)) (formatCharacter c) diff --git a/lib/Data/Time/Format/Locale.hs b/lib/Data/Time/Format/Locale.hs --- a/lib/Data/Time/Format/Locale.hs +++ b/lib/Data/Time/Format/Locale.hs @@ -11,7 +11,8 @@ ) where -import Data.Time.LocalTime +import Data.Time.LocalTime.TimeZone + data TimeLocale = TimeLocale { -- |full and abbreviated week days, starting with Sunday diff --git a/lib/Data/Time/Format/Parse.hs b/lib/Data/Time/Format/Parse.hs --- a/lib/Data/Time/Format/Parse.hs +++ b/lib/Data/Time/Format/Parse.hs @@ -14,12 +14,18 @@ module Data.Time.Format.Locale ) where +import Text.Read(readMaybe) import Data.Time.Clock.POSIX -import Data.Time.Clock -import Data.Time.Calendar +import Data.Time.Clock.Scale +import Data.Time.Clock.UTC +import Data.Time.Calendar.Days +import Data.Time.Calendar.Gregorian import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.WeekDate -import Data.Time.LocalTime +import Data.Time.Calendar.Private(clipValid) +import Data.Time.LocalTime.TimeZone +import Data.Time.LocalTime.TimeOfDay +import Data.Time.LocalTime.LocalTime #if LANGUAGE_Rank2Types import Control.Monad @@ -62,7 +68,7 @@ buildTime :: TimeLocale -- ^ The time locale. -> [(Char,String)] -- ^ Pairs of format characters and the -- corresponding part of the input. - -> t + -> Maybe t #if LANGUAGE_Rank2Types -- | Parses a time value given a format string. @@ -138,7 +144,11 @@ TimeLocale -- ^ Time locale. -> String -- ^ Format string -> ReadP t -readPOnlyTime l f = liftM (buildTime l) (parseInput l (parseFormat l f)) +readPOnlyTime l f = do + mt <- liftM (buildTime l) (parseInput l (parseFormat l f)) + case mt of + Just t -> return t + Nothing -> pfail {-# DEPRECATED parseTime "use \"parseTimeM True\" instead" #-} parseTime :: ParseTime t => @@ -316,91 +326,194 @@ data WeekType = ISOWeek | SundayWeek | MondayWeek instance ParseTime Day where - buildTime l = buildDay . concatMap (uncurry f) - where - f c x = - case c of - -- %C: century (all but the last two digits of the year), 00 - 99 - 'C' -> [Century (read x)] - -- %f century (all but the last two digits of the year), 00 - 99 - 'f' -> [Century (read x)] - -- %Y: year - 'Y' -> let y = read x in [Century (y `div` 100), CenturyYear (y `mod` 100)] - -- %G: year for Week Date format - 'G' -> let y = read x in [Century (y `div` 100), CenturyYear (y `mod` 100)] - -- %y: last two digits of year, 00 - 99 - 'y' -> [CenturyYear (read x)] - -- %g: last two digits of year for Week Date format, 00 - 99 - 'g' -> [CenturyYear (read x)] - -- %B: month name, long form (fst from months locale), January - December - 'B' -> [YearMonth (1 + fromJust (elemIndex (up x) (map (up . fst) (months l))))] - -- %b: month name, short form (snd from months locale), Jan - Dec - 'b' -> [YearMonth (1 + fromJust (elemIndex (up x) (map (up . snd) (months l))))] - -- %m: month of year, leading 0 as needed, 01 - 12 - 'm' -> [YearMonth (read x)] - -- %d: day of month, leading 0 as needed, 01 - 31 - 'd' -> [MonthDay (read x)] - -- %e: day of month, leading space as needed, 1 - 31 - 'e' -> [MonthDay (read x)] - -- %V: week for Week Date format, 01 - 53 - 'V' -> [YearWeek ISOWeek (read x)] - -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 01 - 53 - 'U' -> [YearWeek SundayWeek (read x)] - -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 01 - 53 - 'W' -> [YearWeek MondayWeek (read x)] - -- %u: day for Week Date format, 1 - 7 - 'u' -> [WeekDay (read x)] - -- %a: day of week, short form (snd from wDays locale), Sun - Sat - 'a' -> [WeekDay (1 + (fromJust (elemIndex (up x) (map (up . snd) (wDays l))) + 6) `mod` 7)] - -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday - 'A' -> [WeekDay (1 + (fromJust (elemIndex (up x) (map (up . fst) (wDays l))) + 6) `mod` 7)] - -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday) - 'w' -> [WeekDay (((read x + 6) `mod` 7) + 1)] - -- %j: day of year for Ordinal Date format, 001 - 366 - 'j' -> [YearDay (read x)] - _ -> [] + buildTime l = let - buildDay cs = rest cs - where - y = let + -- 'Nothing' indicates a parse failure, + -- while 'Just []' means no information + f :: Char -> String -> Maybe [DayComponent] + f c x = let + ra :: (Read a) => Maybe a + ra = readMaybe x + + zeroBasedListIndex :: [String] -> Maybe Int + zeroBasedListIndex ss = elemIndex (up x) $ fmap up 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 [Century a] + -- %f century (all but the last two digits of the year), 00 - 99 + 'f' -> do + a <- ra + return [Century a] + -- %Y: year + 'Y' -> do + a <- ra + return [Century (a `div` 100), CenturyYear (a `mod` 100)] + -- %G: year for Week Date format + 'G' -> do + a <- ra + return [Century (a `div` 100), CenturyYear (a `mod` 100)] + -- %y: last two digits of year, 00 - 99 + 'y' -> do + a <- ra + return [CenturyYear a] + -- %g: last two digits of year for Week Date format, 00 - 99 + 'g' -> do + a <- ra + return [CenturyYear a] + -- %B: month name, long form (fst from months locale), January - December + 'B' -> do + a <- oneBasedListIndex $ fmap fst $ months l + return [YearMonth a] + -- %b: month name, short form (snd from months locale), Jan - Dec + 'b' -> do + a <- oneBasedListIndex $ fmap snd $ months l + return [YearMonth a] + -- %m: month of year, leading 0 as needed, 01 - 12 + 'm' -> do + raw <- ra + a <- clipValid 1 12 raw + return [YearMonth a] + -- %d: day of month, leading 0 as needed, 01 - 31 + 'd' -> do + raw <- ra + a <- clipValid 1 31 raw + return [MonthDay a] + -- %e: day of month, leading space as needed, 1 - 31 + 'e' -> do + raw <- ra + a <- clipValid 1 31 raw + return [MonthDay a] + -- %V: week for Week Date format, 01 - 53 + 'V' -> do + raw <- ra + a <- clipValid 1 53 raw + return [YearWeek ISOWeek a] + -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53 + 'U' -> do + raw <- ra + a <- clipValid 0 53 raw + return [YearWeek SundayWeek a] + -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53 + 'W' -> do + raw <- ra + a <- clipValid 0 53 raw + return [YearWeek MondayWeek a] + -- %u: day for Week Date format, 1 - 7 + 'u' -> do + raw <- ra + a <- clipValid 1 7 raw + return [WeekDay a] + -- %a: day of week, short form (snd from wDays locale), Sun - Sat + 'a' -> do + a' <- zeroBasedListIndex $ fmap snd $ wDays l + let a = if a' == 0 then 7 else a' + return [WeekDay a] + -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday + 'A' -> do + a' <- zeroBasedListIndex $ fmap fst $ wDays l + let a = if a' == 0 then 7 else a' + return [WeekDay a] + -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday) + 'w' -> do + raw <- ra + a' <- clipValid 0 6 raw + let a = if a' == 0 then 7 else a' + return [WeekDay a] + -- %j: day of year for Ordinal Date format, 001 - 366 + 'j' -> do + raw <- ra + a <- clipValid 1 366 raw + return [YearDay a] + -- unrecognised, pass on to other parsers + _ -> return [] + + buildDay :: [DayComponent] -> Maybe Day + buildDay cs = let + safeLast x xs = last (x:xs) + y = let d = safeLast 70 [x | CenturyYear x <- cs] c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs] - in 100 * c + d + in 100 * c + d + rest (YearMonth m:_) = let + d = safeLast 1 [x | MonthDay x <- cs] + in fromGregorianValid y m d + rest (YearDay d:_) = fromOrdinalDateValid y d + rest (YearWeek wt w:_) = let + d = safeLast 4 [x | WeekDay 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 [YearMonth 1] - rest (YearMonth m:_) = let d = safeLast 1 [x | MonthDay x <- cs] - in fromGregorian y m d - rest (YearDay d:_) = fromOrdinalDate y d - rest (YearWeek wt w:_) = let d = safeLast 4 [x | WeekDay x <- cs] - in case wt of - ISOWeek -> fromWeekDate y w d - SundayWeek -> fromSundayStartWeek y w (d `mod` 7) - MondayWeek -> fromMondayStartWeek y w d - rest (_:xs) = rest xs - rest [] = rest [YearMonth 1] + in rest cs - safeLast x xs = last (x:xs) + in \pairs -> do + components <- mapM (uncurry f) pairs + buildDay $ concat components +mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a +mfoldl f = let + mf ma b = do + a <- ma + f a b + in foldl mf + instance ParseTime TimeOfDay where - buildTime l = foldl f midnight - where - f t@(TimeOfDay h m s) (c,x) = - case c of - 'P' -> if up x == fst (amPm l) then am else pm - 'p' -> if up x == fst (amPm l) then am else pm - 'H' -> TimeOfDay (read x) m s - 'I' -> TimeOfDay (read x) m s - 'k' -> TimeOfDay (read x) m s - 'l' -> TimeOfDay (read x) m s - 'M' -> TimeOfDay h (read x) s - 'S' -> TimeOfDay h m (fromInteger (read x)) - 'q' -> TimeOfDay h m (mkPico (truncate s) (read x)) - 'Q' -> if null x then t - else let ps = read $ take 12 $ rpad 12 '0' $ drop 1 x - in TimeOfDay h m (mkPico (truncate s) ps) - _ -> t - where am = TimeOfDay (h `mod` 12) m s - pm = TimeOfDay (if h < 12 then h + 12 else h) m s + buildTime l = let + f t@(TimeOfDay h m s) (c,x) = let + ra :: (Read a) => Maybe a + ra = readMaybe x + getAmPm = let + upx = up 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 + a <- ra + return $ TimeOfDay a m s + 'I' -> do + a <- ra + return $ TimeOfDay a m s + 'k' -> do + a <- ra + return $ TimeOfDay a m s + 'l' -> do + a <- ra + return $ TimeOfDay a m s + 'M' -> do + a <- ra + return $ TimeOfDay h a s + 'S' -> do + a <- ra + return $ TimeOfDay h m (fromInteger a) + 'q' -> do + a <- ra + return $ TimeOfDay h m (mkPico (truncate s) a) + 'Q' -> if null x then Just t else do + ps <- readMaybe $ take 12 $ rpad 12 '0' $ drop 1 x + return $ TimeOfDay h m (mkPico (truncate s) ps) + _ -> Just t + + in mfoldl f (Just midnight) + rpad :: Int -> a -> [a] -> [a] rpad n c xs = xs ++ replicate (n - length xs) c @@ -408,7 +521,7 @@ mkPico i f = fromInteger i + fromRational (f % 1000000000000) instance ParseTime LocalTime where - buildTime l xs = LocalTime (buildTime l xs) (buildTime l xs) + buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs) enumDiff :: (Enum a) => a -> a -> Int enumDiff a b = (fromEnum a) - (fromEnum b) @@ -422,48 +535,63 @@ getMilZoneHours 'Z' = Just 0 getMilZoneHours _ = Nothing +getMilZone :: Char -> Maybe TimeZone +getMilZone c = let + yc = toUpper c + in do + hours <- getMilZoneHours yc + return $ TimeZone (hours * 60) False [yc] + +getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone +getKnownTimeZone locale x = find (\tz -> up x == timeZoneName tz) (knownTimeZones locale) + instance ParseTime TimeZone where - buildTime l = foldl f (minutesToTimeZone 0) - where - f t@(TimeZone offset dst name) (c,x) = - case c of - 'z' -> zone - 'Z' | null x -> t - | isAlpha (head x) -> let y = up x in - case find (\tz -> y == timeZoneName tz) (knownTimeZones l) of - Just tz -> tz - Nothing -> case y of - [yc] | Just hours <- getMilZoneHours yc -> TimeZone (hours * 60) False y - _ -> TimeZone offset dst y - | otherwise -> zone - _ -> t - where zone = TimeZone (readTzOffset x) dst name + buildTime l = let + f (TimeZone _ dst name) ('z',x) | Just offset <- readTzOffset x = TimeZone offset dst name + f t ('Z',"") = t + f _ ('Z',x) | Just zone <- getKnownTimeZone l x = zone + f _ ('Z',[c]) | Just zone <- getMilZone c = zone + f (TimeZone offset dst _) ('Z',x) | isAlpha (head x) = TimeZone offset dst (up x) + f (TimeZone _ dst name) ('Z',x) | Just offset <- readTzOffset x = TimeZone offset dst name + f t _ = t + in Just . foldl f (minutesToTimeZone 0) -readTzOffset :: String -> Int -readTzOffset str = - 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 - _ -> 0 - where calc s h1 h2 m1 m2 = sign * (60 * h + m) - where sign = if s == '-' then -1 else 1 - h = read [h1,h2] - m = read [m1,m2] +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 + instance ParseTime ZonedTime where - buildTime l xs = foldl f (ZonedTime (buildTime l xs) (buildTime l xs)) xs - where - f t@(ZonedTime (LocalTime _ tod) z) (c,x) = - case c of - 's' -> let s = fromInteger (read x) - (_,ps) = properFraction (todSec tod) :: (Integer,Pico) - s' = s + fromRational (toRational ps) - in utcToZonedTime z (posixSecondsToUTCTime s') - _ -> t + 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 - buildTime l = zonedTimeToUTC . buildTime l + buildTime l xs = zonedTimeToUTC <$> buildTime l xs +instance ParseTime UniversalTime where + buildTime l xs = localTimeToUT1 0 <$> buildTime l xs + -- * Read instances for time package types #if LANGUAGE_Rank2Types @@ -485,5 +613,7 @@ instance Read UTCTime where readsPrec n s = [ (zonedTimeToUTC t, r) | (t,r) <- readsPrec n s ] -#endif +instance Read UniversalTime where + readsPrec n s = [ (localTimeToUT1 0 t, r) | (t,r) <- readsPrec n s ] +#endif diff --git a/lib/Data/Time/LocalTime.hs b/lib/Data/Time/LocalTime.hs --- a/lib/Data/Time/LocalTime.hs +++ b/lib/Data/Time/LocalTime.hs @@ -1,10 +1,11 @@ module Data.Time.LocalTime ( - module Data.Time.LocalTime.TimeZone, - module Data.Time.LocalTime.TimeOfDay, - module Data.Time.LocalTime.LocalTime + module Data.Time.LocalTime.TimeZone, + module Data.Time.LocalTime.TimeOfDay, + module Data.Time.LocalTime.LocalTime ) where +import Data.Time.Format() import Data.Time.LocalTime.TimeZone import Data.Time.LocalTime.TimeOfDay import Data.Time.LocalTime.LocalTime diff --git a/lib/Data/Time/LocalTime/LocalTime.hs b/lib/Data/Time/LocalTime/LocalTime.hs --- a/lib/Data/Time/LocalTime/LocalTime.hs +++ b/lib/Data/Time/LocalTime/LocalTime.hs @@ -4,19 +4,25 @@ -- #hide module Data.Time.LocalTime.LocalTime ( - -- * Local Time - LocalTime(..), + -- * Local Time + LocalTime(..), - -- converting UTC and UT1 times to LocalTime - utcToLocalTime,localTimeToUTC,ut1ToLocalTime,localTimeToUT1, - - ZonedTime(..),utcToZonedTime,zonedTimeToUTC,getZonedTime,utcToLocalZonedTime + -- converting UTC and UT1 times to LocalTime + utcToLocalTime,localTimeToUTC,ut1ToLocalTime,localTimeToUT1, + + ZonedTime(..),utcToZonedTime,zonedTimeToUTC,getZonedTime,utcToLocalZonedTime ) where import Data.Time.LocalTime.TimeOfDay import Data.Time.LocalTime.TimeZone -import Data.Time.Calendar -import Data.Time.Clock +import Data.Time.Calendar.Days +import Data.Time.Calendar.Gregorian + +import Data.Time.Clock.Scale +import Data.Time.Clock.UTCDiff +import Data.Time.Clock.UTC +import Data.Time.Clock.POSIX + import Control.DeepSeq import Data.Typeable #if LANGUAGE_Rank2Types @@ -28,8 +34,8 @@ -- Conversion of this (as local civil time) to UTC depends on the time zone. -- Conversion of this (as local mean time) to UT1 depends on the longitude. data LocalTime = LocalTime { - localDay :: Day, - localTimeOfDay :: TimeOfDay + localDay :: Day, + localTimeOfDay :: TimeOfDay } deriving (Eq,Ord #if LANGUAGE_DeriveDataTypeable #if LANGUAGE_Rank2Types @@ -41,36 +47,40 @@ ) instance NFData LocalTime where - rnf (LocalTime d t) = d `deepseq` t `deepseq` () + rnf (LocalTime d t) = d `deepseq` t `deepseq` () instance Show LocalTime where - show (LocalTime d t) = (showGregorian d) ++ " " ++ (show t) + show (LocalTime d t) = (showGregorian d) ++ " " ++ (show t) -- | show a UTC time in a given time zone as a LocalTime utcToLocalTime :: TimeZone -> UTCTime -> LocalTime utcToLocalTime tz (UTCTime day dt) = LocalTime (addDays i day) tod where - (i,tod) = utcToLocalTimeOfDay tz (timeToTimeOfDay dt) + (i,tod) = utcToLocalTimeOfDay tz (timeToTimeOfDay dt) -- | find out what UTC time a given LocalTime in a given time zone is localTimeToUTC :: TimeZone -> LocalTime -> UTCTime localTimeToUTC tz (LocalTime day tod) = UTCTime (addDays i day) (timeOfDayToTime todUTC) where - (i,todUTC) = localToUTCTimeOfDay tz tod + (i,todUTC) = localToUTCTimeOfDay tz tod -- | 1st arg is observation meridian in degrees, positive is East ut1ToLocalTime :: Rational -> UniversalTime -> LocalTime ut1ToLocalTime long (ModJulianDate date) = LocalTime (ModifiedJulianDay localMJD) (dayFractionToTimeOfDay localToDOffset) where - localTime = date + long / 360 :: Rational - localMJD = floor localTime - localToDOffset = localTime - (fromIntegral localMJD) + localTime = date + long / 360 :: Rational + localMJD = floor localTime + localToDOffset = localTime - (fromIntegral localMJD) -- | 1st arg is observation meridian in degrees, positive is East localTimeToUT1 :: Rational -> LocalTime -> UniversalTime localTimeToUT1 long (LocalTime (ModifiedJulianDay localMJD) tod) = ModJulianDate ((fromIntegral localMJD) + (timeOfDayToDayFraction tod) - (long / 360)) +-- orphan instance +instance Show UniversalTime where + show t = show (ut1ToLocalTime 0 t) + -- | A local time together with a TimeZone. data ZonedTime = ZonedTime { - zonedTimeToLocalTime :: LocalTime, - zonedTimeZone :: TimeZone + zonedTimeToLocalTime :: LocalTime, + zonedTimeZone :: TimeZone } #if LANGUAGE_DeriveDataTypeable #if LANGUAGE_Rank2Types @@ -81,7 +91,7 @@ #endif instance NFData ZonedTime where - rnf (ZonedTime lt z) = lt `deepseq` z `deepseq` () + rnf (ZonedTime lt z) = lt `deepseq` z `deepseq` () utcToZonedTime :: TimeZone -> UTCTime -> ZonedTime utcToZonedTime zone time = ZonedTime (utcToLocalTime zone time) zone @@ -90,20 +100,20 @@ zonedTimeToUTC (ZonedTime t zone) = localTimeToUTC zone t instance Show ZonedTime where - show (ZonedTime t zone) = show t ++ " " ++ show zone + show (ZonedTime t zone) = show t ++ " " ++ show zone -- orphan instance instance Show UTCTime where - show t = show (utcToZonedTime utc t) + show t = show (utcToZonedTime utc t) getZonedTime :: IO ZonedTime getZonedTime = do - t <- getCurrentTime - zone <- getTimeZone t - return (utcToZonedTime zone t) + t <- getCurrentTime + zone <- getTimeZone t + return (utcToZonedTime zone t) -- | utcToLocalZonedTime :: UTCTime -> IO ZonedTime utcToLocalZonedTime t = do - zone <- getTimeZone t - return (utcToZonedTime zone t) + zone <- getTimeZone t + return (utcToZonedTime zone t) diff --git a/lib/Data/Time/LocalTime/TimeOfDay.hs b/lib/Data/Time/LocalTime/TimeOfDay.hs --- a/lib/Data/Time/LocalTime/TimeOfDay.hs +++ b/lib/Data/Time/LocalTime/TimeOfDay.hs @@ -3,16 +3,16 @@ -- #hide module Data.Time.LocalTime.TimeOfDay ( - -- * Time of day - TimeOfDay(..),midnight,midday,makeTimeOfDayValid, - utcToLocalTimeOfDay,localToUTCTimeOfDay, - timeToTimeOfDay,timeOfDayToTime, - dayFractionToTimeOfDay,timeOfDayToDayFraction + -- * Time of day + TimeOfDay(..),midnight,midday,makeTimeOfDayValid, + utcToLocalTimeOfDay,localToUTCTimeOfDay, + timeToTimeOfDay,timeOfDayToTime, + dayFractionToTimeOfDay,timeOfDayToDayFraction ) where import Data.Time.LocalTime.TimeZone import Data.Time.Calendar.Private -import Data.Time.Clock +import Data.Time.Clock.Scale import Control.DeepSeq import Data.Typeable import Data.Fixed @@ -22,13 +22,13 @@ -- | Time of day as represented in hour, minute and second (with picoseconds), typically used to express local time of day. data TimeOfDay = TimeOfDay { - -- | 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 + -- | 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 #if LANGUAGE_DeriveDataTypeable #if LANGUAGE_Rank2Types @@ -40,7 +40,7 @@ ) instance NFData TimeOfDay where - rnf (TimeOfDay h m s) = h `deepseq` m `deepseq` s `seq` () -- FIXME: Data.Fixed had no NFData instances yet at time of writing + rnf (TimeOfDay h m s) = h `deepseq` m `deepseq` s `seq` () -- FIXME: Data.Fixed had no NFData instances yet at time of writing -- | Hour zero midnight :: TimeOfDay @@ -51,20 +51,20 @@ midday = TimeOfDay 12 0 0 instance Show TimeOfDay where - show (TimeOfDay h m s) = (show2 (Just '0') h) ++ ":" ++ (show2 (Just '0') m) ++ ":" ++ (show2Fixed (Just '0') s) + show (TimeOfDay h m s) = (show2 (Just '0') h) ++ ":" ++ (show2 (Just '0') m) ++ ":" ++ (show2Fixed (Just '0') s) makeTimeOfDayValid :: Int -> Int -> Pico -> Maybe TimeOfDay makeTimeOfDayValid h m s = do - _ <- clipValid 0 23 h - _ <- clipValid 0 59 m - _ <- clipValid 0 60.999999999999 s - return (TimeOfDay h m s) + _ <- clipValid 0 23 h + _ <- clipValid 0 59 m + _ <- clipValid 0 60.999999999999 s + return (TimeOfDay h m s) -- | Convert a ToD in UTC to a ToD in some timezone, together with a day adjustment. utcToLocalTimeOfDay :: TimeZone -> TimeOfDay -> (Integer,TimeOfDay) utcToLocalTimeOfDay zone (TimeOfDay h m s) = (fromIntegral (div h' 24),TimeOfDay (mod h' 24) (mod m' 60) s) where - m' = m + timeZoneMinutes zone - h' = h + (div m' 60) + m' = m + timeZoneMinutes zone + h' = h + (div m' 60) -- | Convert a ToD in some timezone to a ToD in UTC, together with a day adjustment. localToUTCTimeOfDay :: TimeZone -> TimeOfDay -> (Integer,TimeOfDay) @@ -78,11 +78,11 @@ timeToTimeOfDay :: DiffTime -> TimeOfDay timeToTimeOfDay dt | dt >= posixDayLength = TimeOfDay 23 59 (60 + (realToFrac (dt - posixDayLength))) timeToTimeOfDay dt = TimeOfDay (fromInteger h) (fromInteger m) s where - s' = realToFrac dt - s = mod' s' 60 - m' = div' s' 60 - m = mod' m' 60 - h = div' m' 60 + s' = realToFrac dt + s = mod' s' 60 + m' = div' s' 60 + m = mod' m' 60 + h = div' m' 60 -- | Find out how much time since midnight a given TimeOfDay is. timeOfDayToTime :: TimeOfDay -> DiffTime diff --git a/lib/Data/Time/LocalTime/TimeZone.hs b/lib/Data/Time/LocalTime/TimeZone.hs --- a/lib/Data/Time/LocalTime/TimeZone.hs +++ b/lib/Data/Time/LocalTime/TimeZone.hs @@ -5,19 +5,19 @@ -- #hide module Data.Time.LocalTime.TimeZone ( - -- * Time zones - TimeZone(..),timeZoneOffsetString,timeZoneOffsetString',minutesToTimeZone,hoursToTimeZone,utc, + -- * Time zones + TimeZone(..),timeZoneOffsetString,timeZoneOffsetString',minutesToTimeZone,hoursToTimeZone,utc, - -- getting the locale time zone - getTimeZone,getCurrentTimeZone + -- getting the locale time zone + getTimeZone,getCurrentTimeZone ) where --import System.Time.Calendar.Format import Data.Time.Calendar.Private -import Data.Time.Clock import Data.Time.Clock.POSIX +import Data.Time.Clock.UTC -#if __GLASGOW_HASKELL__ >= 709 +#if __GLASGOW_HASKELL__ >= 709 || __GLASGOW_HASKELL__ < 702 import Foreign #else import Foreign.Safe @@ -31,12 +31,12 @@ -- | A TimeZone is a whole number of minutes offset from UTC, together with a name and a \"just for summer\" flag. data TimeZone = TimeZone { - -- | 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 + -- | 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 #if LANGUAGE_DeriveDataTypeable #if LANGUAGE_Rank2Types @@ -46,7 +46,7 @@ ) instance NFData TimeZone where - rnf (TimeZone m so n) = m `deepseq` so `deepseq` n `deepseq` () + rnf (TimeZone m so n) = m `deepseq` so `deepseq` n `deepseq` () -- | Create a nameless non-summer timezone for this number of minutes minutesToTimeZone :: Int -> TimeZone @@ -69,8 +69,8 @@ timeZoneOffsetString = timeZoneOffsetString' (Just '0') instance Show TimeZone where - show zone@(TimeZone _ _ "") = timeZoneOffsetString zone - show (TimeZone _ _ name) = name + show zone@(TimeZone _ _ "") = timeZoneOffsetString zone + show (TimeZone _ _ name) = name -- | The UTC time zone utc :: TimeZone @@ -85,15 +85,15 @@ -- | Get the local time-zone for a given time (varying as per summertime adjustments) getTimeZone :: UTCTime -> IO TimeZone getTimeZone time = with 0 (\pdst -> with nullPtr (\pcname -> do - secs <- get_current_timezone_seconds (posixToCTime (utcTimeToPOSIXSeconds time)) 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) - )) + secs <- get_current_timezone_seconds (posixToCTime (utcTimeToPOSIXSeconds time)) 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) + )) -- | Get the current time-zone getCurrentTimeZone :: IO TimeZone diff --git a/lib/include/HsTimeConfig.h b/lib/include/HsTimeConfig.h --- a/lib/include/HsTimeConfig.h +++ b/lib/include/HsTimeConfig.h @@ -1,6 +1,9 @@ /* 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 diff --git a/lib/include/HsTimeConfig.h.in b/lib/include/HsTimeConfig.h.in --- a/lib/include/HsTimeConfig.h.in +++ b/lib/include/HsTimeConfig.h.in @@ -1,5 +1,8 @@ /* lib/include/HsTimeConfig.h.in. Generated from configure.ac by autoheader. */ +/* Define to 1 if you have the `clock_gettime' function. */ +#undef HAVE_CLOCK_GETTIME + /* Define to 1 if you have the declaration of `altzone', and to 0 if you don't. */ #undef HAVE_DECL_ALTZONE diff --git a/test/Test/AddDays.hs b/test/Test/AddDays.hs --- a/test/Test/AddDays.hs +++ b/test/Test/AddDays.hs @@ -6,35 +6,35 @@ days ::[Day] days = - [ - fromGregorian 2005 2 28, - fromGregorian 2004 2 29, - fromGregorian 2004 1 31, - fromGregorian 2004 12 31, - fromGregorian 2005 7 1, - fromGregorian 2005 4 21, - fromGregorian 2005 6 30 - ] + [ + fromGregorian 2005 2 28, + fromGregorian 2004 2 29, + fromGregorian 2004 1 31, + fromGregorian 2004 12 31, + fromGregorian 2005 7 1, + fromGregorian 2005 4 21, + fromGregorian 2005 6 30 + ] increments :: [Integer] increments = [-10,-4,-1,0,1,7,83] adders :: [(String,Integer -> Day -> Day)] adders = - [ - ("day",addDays), - ("month (clip)",addGregorianMonthsClip), - ("month (roll over)",addGregorianMonthsRollOver), - ("year (clip)",addGregorianYearsClip), - ("year (roll over)",addGregorianYearsRollOver) - ] + [ + ("day",addDays), + ("month (clip)",addGregorianMonthsClip), + ("month (roll over)",addGregorianMonthsRollOver), + ("year (clip)",addGregorianYearsClip), + ("year (roll over)",addGregorianYearsRollOver) + ] resultDays :: [String] resultDays = do - (aname,adder) <- adders - increment <- increments - day <- days - return ((showGregorian day) ++ " + " ++ (show increment) ++ " * " ++ aname ++ " = " ++ showGregorian (adder increment day)) + (aname,adder) <- adders + increment <- increments + day <- days + return ((showGregorian day) ++ " + " ++ (show increment) ++ " * " ++ aname ++ " = " ++ showGregorian (adder increment day)) addDaysTest :: Test addDaysTest = pureTest "addDays" $ diff --git a/test/Test/ClipDates.hs b/test/Test/ClipDates.hs --- a/test/Test/ClipDates.hs +++ b/test/Test/ClipDates.hs @@ -31,16 +31,16 @@ clipDates :: Test clipDates = pureTest "clipDates" $ - let - yad = unlines $ map yearAndDay $ + let + yad = unlines $ map yearAndDay $ tupleUp2 [1968,1969,1971] [-4,0,1,200,364,365,366,367,700] - - greg = unlines $ map gregorian $ + + greg = unlines $ 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] - iso = unlines $ map iSOWeekDay $ + iso = unlines $ map iSOWeekDay $ tupleUp3 [1968,1969,2004] [-20,-1,0,1,20,51,52,53,54] [-2,-1,0,1,4,6,7,8,9] - in diff clipDatesRef $ + in diff clipDatesRef $ concat [ "YearAndDay\n", yad, "Gregorian\n", greg, "ISOWeekDay\n", iso ] diff --git a/test/Test/ClipDatesRef.hs b/test/Test/ClipDatesRef.hs --- a/test/Test/ClipDatesRef.hs +++ b/test/Test/ClipDatesRef.hs @@ -2,7 +2,7 @@ clipDatesRef :: String clipDatesRef = - unlines + unlines [ "YearAndDay" , "1968--4 = 1968-001" , "1968-0 = 1968-001" diff --git a/test/Test/ConvertBack.hs b/test/Test/ConvertBack.hs --- a/test/Test/ConvertBack.hs +++ b/test/Test/ConvertBack.hs @@ -7,23 +7,23 @@ import Test.TestUtil 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 +checkDay encodeDay decodeDay decodeDayValid day = let + st = encodeDay day + day' = decodeDay st + mday' = decodeDayValid st - a = if day /= day' - then unwords [ show day, "-> " + a = if day /= day' + then unwords [ show day, "-> " , show st, "-> " , show day' , "(diff", show (diffDays day' day) ++ ")" ] - else "" + else "" - b = if Just day /= mday' - then unwords [show day, "->", show st, "->", show mday'] - else "" + b = if Just day /= mday' + then unwords [show day, "->", show st, "->", show mday'] + else "" in a ++ b - + checkers :: [Day -> String] checkers = [ checkDay toOrdinalDate (\(y,d) -> fromOrdinalDate y d) (\(y,d) -> fromOrdinalDateValid y d) @@ -33,7 +33,7 @@ days :: [Day] days = [ModifiedJulianDay 50000 .. ModifiedJulianDay 50200] ++ - (fmap (\year -> (fromGregorian year 1 4)) [1980..2000]) + (fmap (\year -> (fromGregorian year 1 4)) [1980..2000]) convertBack :: Test convertBack = pureTest "convertBack" $ diff --git a/test/Test/LongWeekYears.hs b/test/Test/LongWeekYears.hs --- a/test/Test/LongWeekYears.hs +++ b/test/Test/LongWeekYears.hs @@ -7,8 +7,8 @@ longYear :: Integer -> Bool longYear year = case toWeekDate (fromGregorian year 12 31) of - (_,53,_) -> True - _ -> False + (_,53,_) -> True + _ -> False showLongYear :: Integer -> String showLongYear year diff --git a/test/Test/TAI_UTC_DAT.hs b/test/Test/TAI_UTC_DAT.hs --- a/test/Test/TAI_UTC_DAT.hs +++ b/test/Test/TAI_UTC_DAT.hs @@ -2,7 +2,7 @@ taiUTC_DAT :: String taiUTC_DAT = - unlines + unlines [ "1961 JAN 1 =JD 2437300.5 TAI-UTC= 1.4228180 S + (MJD - 37300.) X 0.001296 S" , "1961 AUG 1 =JD 2437512.5 TAI-UTC= 1.3728180 S + (MJD - 37300.) X 0.001296 S" , "1962 JAN 1 =JD 2437665.5 TAI-UTC= 1.8458580 S + (MJD - 37665.) X 0.0011232S" diff --git a/test/Test/TestCalendars.hs b/test/Test/TestCalendars.hs --- a/test/Test/TestCalendars.hs +++ b/test/Test/TestCalendars.hs @@ -8,23 +8,23 @@ showers :: [(String,Day -> String)] showers = [ - ("MJD",show . toModifiedJulianDay), - ("Gregorian",showGregorian), - ("Julian",showJulian), - ("ISO 8601",showWeekDate) - ] + ("MJD",show . toModifiedJulianDay), + ("Gregorian",showGregorian), + ("Julian",showJulian), + ("ISO 8601",showWeekDate) + ] days :: [Day] days = [ - fromGregorian 0 12 31, - fromJulian 1752 9 2, - fromGregorian 1752 9 14, - fromGregorian 2005 1 23 - ] + fromGregorian 0 12 31, + fromJulian 1752 9 2, + fromGregorian 1752 9 14, + fromGregorian 2005 1 23 + ] testCalendars :: Test testCalendars = pureTest "testCalendars" $ diff testCalendarsRef $ unlines $ map (\d -> showShowers d) days where - showShowers day = + showShowers day = concatMap (\(nm,shower) -> unwords [" ==", nm, shower day]) showers diff --git a/test/Test/TestEaster.hs b/test/Test/TestEaster.hs --- a/test/Test/TestEaster.hs +++ b/test/Test/TestEaster.hs @@ -18,7 +18,7 @@ showWithWDay = formatTime defaultTimeLocale "%F %A" testEaster :: Test -testEaster = pureTest "testEaster" $ let +testEaster = pureTest "testEaster" $ let ds = unlines $ map (\day -> unwords [ showWithWDay day, "->" , showWithWDay (sundayAfter day)]) days diff --git a/test/Test/TestFormat.hs b/test/Test/TestFormat.hs --- a/test/Test/TestFormat.hs +++ b/test/Test/TestFormat.hs @@ -11,29 +11,29 @@ import Test.TestUtil {- - size_t format_time ( - char *s, size_t maxsize, - const char *format, - int isdst,int gmtoff,time_t t); + size_t format_time ( + char *s, size_t maxsize, + const char *format, + int isdst,int gmtoff,time_t t); -} foreign import ccall unsafe "TestFormatStuff.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) - ) + len <- f buffer + peekCStringLen (buffer,fromIntegral len) + ) unixFormatTime :: String -> TimeZone -> UTCTime -> IO String unixFormatTime fmt zone time = 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 (truncate (utcTimeToPOSIXSeconds time))) - ) - )) + withBuffer 100 (\buffer -> format_time buffer 100 pfmt + (if timeZoneSummerOnly zone then 1 else 0) + (fromIntegral (timeZoneMinutes zone * 60)) + pzonename + (fromInteger (truncate (utcTimeToPOSIXSeconds time))) + ) + )) locale :: TimeLocale locale = defaultTimeLocale {dateTimeFmt = "%a %b %e %H:%M:%S %Y"} @@ -67,7 +67,7 @@ times :: [UTCTime] times = [baseTime0] ++ (fmap getDay [0..23]) ++ (fmap getDay [0..100]) ++ - (fmap getYearP1 years) ++ (fmap getYearP2 years) ++ (fmap getYearP3 years) ++ (fmap getYearP4 years) + (fmap getYearP1 years) ++ (fmap getYearP2 years) ++ (fmap getYearP3 years) ++ (fmap getYearP4 years) padN :: Int -> Char -> String -> String padN n _ s | n <= (length s) = s @@ -144,10 +144,10 @@ class (ParseTime t) => TestParse t where expectedParse :: String -> String -> Maybe t - expectedParse "%Z" "" = Just (buildTime defaultTimeLocale []) - expectedParse "%_Z" "" = Just (buildTime defaultTimeLocale []) - expectedParse "%-Z" "" = Just (buildTime defaultTimeLocale []) - expectedParse "%0Z" "" = Just (buildTime defaultTimeLocale []) + expectedParse "%Z" "" = buildTime defaultTimeLocale [] + expectedParse "%_Z" "" = buildTime defaultTimeLocale [] + expectedParse "%-Z" "" = buildTime defaultTimeLocale [] + expectedParse "%0Z" "" = buildTime defaultTimeLocale [] expectedParse _ _ = Nothing instance TestParse Day diff --git a/test/Test/TestFormatStuff.c b/test/Test/TestFormatStuff.c --- a/test/Test/TestFormatStuff.c +++ b/test/Test/TestFormatStuff.c @@ -1,15 +1,15 @@ #include "TestFormatStuff.h" size_t format_time ( - char* buffer, size_t maxsize, - const char* format, - int isdst,int gmtoff,char* zonename,time_t t) + char* buffer, size_t maxsize, + const char* format, + int isdst,int gmtoff,char* zonename,time_t t) { - t += gmtoff; - struct tm tmd; - gmtime_r(&t,&tmd); - tmd.tm_isdst = isdst; - tmd.tm_gmtoff = gmtoff; - tmd.tm_zone = zonename; - return strftime(buffer,maxsize,format,&tmd); + t += gmtoff; + struct tm tmd; + gmtime_r(&t,&tmd); + tmd.tm_isdst = isdst; + tmd.tm_gmtoff = gmtoff; + tmd.tm_zone = zonename; + return strftime(buffer,maxsize,format,&tmd); } diff --git a/test/Test/TestFormatStuff.h b/test/Test/TestFormatStuff.h --- a/test/Test/TestFormatStuff.h +++ b/test/Test/TestFormatStuff.h @@ -1,6 +1,6 @@ #include size_t format_time ( - char *s, size_t maxsize, - const char *format, - int isdst,int gmtoff,char* zonename,time_t t); + char *s, size_t maxsize, + const char *format, + int isdst,int gmtoff,char* zonename,time_t t); diff --git a/test/Test/TestMonthDay.hs b/test/Test/TestMonthDay.hs --- a/test/Test/TestMonthDay.hs +++ b/test/Test/TestMonthDay.hs @@ -13,8 +13,8 @@ diff testMonthDayRef $ concat $ map (\isL -> unlines (leap isL : yearDays isL)) [False,True] where leap isLeap = if isLeap then "Leap:" else "Regular:" - yearDays isLeap = - map (\yd -> let + yearDays isLeap = + map (\yd -> let (m,d) = dayOfYearToMonthAndDay isLeap yd yd' = monthAndDayToDayOfYear isLeap m d mdtext = show m ++ "-" ++ show d diff --git a/test/Test/TestParseDAT.hs b/test/Test/TestParseDAT.hs --- a/test/Test/TestParseDAT.hs +++ b/test/Test/TestParseDAT.hs @@ -8,38 +8,38 @@ tods :: [TimeOfDay] tods = [ - TimeOfDay 0 0 0, - TimeOfDay 0 0 0.5, - TimeOfDay 0 0 1, - TimeOfDay 0 0 1.5, - TimeOfDay 0 0 2, - TimeOfDay 23 59 28, - TimeOfDay 23 59 28.5, - TimeOfDay 23 59 29, - TimeOfDay 23 59 29.5, - TimeOfDay 23 59 30, - TimeOfDay 23 59 30.5, - TimeOfDay 23 59 31, - TimeOfDay 23 59 31.5, - TimeOfDay 23 59 32, - TimeOfDay 23 59 59, - TimeOfDay 23 59 59.5, - TimeOfDay 23 59 60, - TimeOfDay 23 59 60.5 - ] + TimeOfDay 0 0 0, + TimeOfDay 0 0 0.5, + TimeOfDay 0 0 1, + TimeOfDay 0 0 1.5, + TimeOfDay 0 0 2, + TimeOfDay 23 59 28, + TimeOfDay 23 59 28.5, + TimeOfDay 23 59 29, + TimeOfDay 23 59 29.5, + TimeOfDay 23 59 30, + TimeOfDay 23 59 30.5, + TimeOfDay 23 59 31, + TimeOfDay 23 59 31.5, + TimeOfDay 23 59 32, + TimeOfDay 23 59 59, + TimeOfDay 23 59 59.5, + TimeOfDay 23 59 60, + TimeOfDay 23 59 60.5 + ] times :: [LocalTime] times = - fmap (LocalTime (fromGregorian 1998 04 02)) tods ++ - fmap (LocalTime (fromGregorian 1998 12 30)) tods ++ - fmap (LocalTime (fromGregorian 1998 12 31)) tods ++ - fmap (LocalTime (fromGregorian 1999 01 01)) tods ++ - fmap (LocalTime (fromGregorian 1999 01 02)) tods + fmap (LocalTime (fromGregorian 1998 04 02)) tods ++ + fmap (LocalTime (fromGregorian 1998 12 30)) tods ++ + fmap (LocalTime (fromGregorian 1998 12 31)) tods ++ + fmap (LocalTime (fromGregorian 1999 01 01)) tods ++ + fmap (LocalTime (fromGregorian 1999 01 02)) tods testParseDAT :: Test testParseDAT = pureTest "testParseDAT" $ diff testParseDAT_Ref parseDAT where - parseDAT = - let lst = parseTAIUTCDATFile taiUTC_DAT in + parseDAT = + let lst = parseTAIUTCDATFile taiUTC_DAT in unlines $ map (\lt -> let diff --git a/test/Test/TestParseTime.hs b/test/Test/TestParseTime.hs --- a/test/Test/TestParseTime.hs +++ b/test/Test/TestParseTime.hs @@ -11,7 +11,7 @@ import Data.Time.Calendar.WeekDate import Data.Time.Clock.POSIX import Test.QuickCheck hiding (Result,reason) -import Test.QuickCheck.Property hiding (result) +import Test.QuickCheck.Property import Test.TestUtil hiding (Result) ntest :: Int @@ -286,6 +286,13 @@ instance CoArbitrary UTCTime where coarbitrary t = coarbitrary (truncate (utcTimeToPOSIXSeconds t) :: Integer) +instance Arbitrary UniversalTime where + arbitrary = liftM (\n -> ModJulianDate $ n % k) $ choose (-313698 * k, 2973483 * k) where -- 1000-01-1 to 9999-12-31 + k = 86400 + +instance CoArbitrary UniversalTime where + coarbitrary (ModJulianDate d) = coarbitrary d + -- missing from the time package instance Eq ZonedTime where ZonedTime t1 tz1 == ZonedTime t2 tz2 = t1 == t2 && tz1 == tz2 @@ -438,7 +445,8 @@ ("prop_read_show LocalTime", property (prop_read_show :: LocalTime -> Result)), ("prop_read_show TimeZone", property (prop_read_show :: TimeZone -> Result)), ("prop_read_show ZonedTime", property (prop_read_show :: ZonedTime -> Result)), - ("prop_read_show UTCTime", property (prop_read_show :: UTCTime -> Result))] + ("prop_read_show UTCTime", property (prop_read_show :: UTCTime -> Result)), + ("prop_read_show UniversalTime", property (prop_read_show :: UniversalTime -> Result))] ++ [("prop_parse_showWeekDate", property prop_parse_showWeekDate), ("prop_parse_showGregorian", property prop_parse_showGregorian), ("prop_parse_showOrdinalDate", property prop_parse_showOrdinalDate)] @@ -449,6 +457,7 @@ ++ map (prop_parse_format_named "TimeZone") timeZoneFormats ++ map (prop_parse_format_named "ZonedTime") zonedTimeFormats ++ map (prop_parse_format_named "UTCTime") utcTimeFormats + ++ map (prop_parse_format_named "UniversalTime") universalTimeFormats ++ map (prop_parse_format_upper_named "Day") dayFormats ++ map (prop_parse_format_upper_named "TimeOfDay") timeOfDayFormats @@ -456,6 +465,7 @@ ++ map (prop_parse_format_upper_named "TimeZone") timeZoneFormats ++ map (prop_parse_format_upper_named "ZonedTime") zonedTimeFormats ++ map (prop_parse_format_upper_named "UTCTime") utcTimeFormats + ++ map (prop_parse_format_upper_named "UniversalTime") universalTimeFormats ++ map (prop_parse_format_lower_named "Day") dayFormats ++ map (prop_parse_format_lower_named "TimeOfDay") timeOfDayFormats @@ -463,12 +473,14 @@ ++ map (prop_parse_format_lower_named "TimeZone") timeZoneFormats ++ map (prop_parse_format_lower_named "ZonedTime") zonedTimeFormats ++ map (prop_parse_format_lower_named "UTCTime") utcTimeFormats + ++ map (prop_parse_format_lower_named "UniversalTime") universalTimeFormats ++ map (prop_format_parse_format_named "Day") partialDayFormats ++ map (prop_format_parse_format_named "TimeOfDay") partialTimeOfDayFormats ++ map (prop_format_parse_format_named "LocalTime") partialLocalTimeFormats ++ map (prop_format_parse_format_named "ZonedTime") partialZonedTimeFormats ++ map (prop_format_parse_format_named "UTCTime") partialUTCTimeFormats + ++ map (prop_format_parse_format_named "UniversalTime") partialUniversalTimeFormats ++ map (prop_no_crash_bad_input_named "Day") (dayFormats ++ partialDayFormats ++ failingPartialDayFormats) ++ map (prop_no_crash_bad_input_named "TimeOfDay") (timeOfDayFormats ++ partialTimeOfDayFormats) @@ -476,6 +488,7 @@ ++ map (prop_no_crash_bad_input_named "TimeZone") (timeZoneFormats) ++ map (prop_no_crash_bad_input_named "ZonedTime") (zonedTimeFormats ++ partialZonedTimeFormats) ++ map (prop_no_crash_bad_input_named "UTCTime") (utcTimeFormats ++ partialUTCTimeFormats) + ++ map (prop_no_crash_bad_input_named "UniversalTime") (universalTimeFormats ++ partialUniversalTimeFormats) @@ -528,6 +541,9 @@ utcTimeFormats = map FormatString ["%s.%q","%s%Q"] +universalTimeFormats :: [FormatString UniversalTime] +universalTimeFormats = map FormatString [] + -- -- * Formats that do not include all the information -- @@ -561,6 +577,10 @@ -- %c does not include second decimals "%c" ] + +partialUniversalTimeFormats :: [FormatString UniversalTime] +partialUniversalTimeFormats = map FormatString + [ ] -- diff --git a/test/Test/TestTime.hs b/test/Test/TestTime.hs --- a/test/Test/TestTime.hs +++ b/test/Test/TestTime.hs @@ -12,26 +12,26 @@ (y,m,d) = toGregorian date date' = fromGregorian y m d in concat [ show mjd ++ "=" - ++ showGregorian date ++ "=" + ++ showGregorian date ++ "=" ++ showOrdinalDate date ++ "=" ++ showWeekDate date ++ "\n" , if date == date' - then "" + then "" else "=" ++ (show $ toModifiedJulianDay date') ++ "!" ] testCal :: String testCal = concat -- days around 1 BCE/1 CE - [ concatMap showCal [-678950 .. -678930] + [ concatMap showCal [-678950 .. -678930] -- days around 1000 CE - , concatMap showCal [-313710 .. -313690] + , concatMap showCal [-313710 .. -313690] -- days around MJD zero - , concatMap showCal [-30..30] + , concatMap showCal [-30..30] , showCal 40000 , showCal 50000 @@ -73,10 +73,10 @@ = let lsMineCal = utcToLocalTime myzone leapSec1998 lsMine = localTimeToUTC myzone lsMineCal in unlines [ showCal 51178 - , show leapSec1998Cal - , showUTCTime leapSec1998 - , show lsMineCal - , showUTCTime lsMine ] + , show leapSec1998Cal + , showUTCTime leapSec1998 + , show lsMineCal + , showUTCTime lsMine ] neglong :: Rational neglong = -120 diff --git a/test/Test/TestTimeRef.hs b/test/Test/TestTimeRef.hs --- a/test/Test/TestTimeRef.hs +++ b/test/Test/TestTimeRef.hs @@ -1,7 +1,7 @@ module Test.TestTimeRef where testTimeRef :: String -testTimeRef = +testTimeRef = unlines [ "-678950=-0001-12-23=-0001-357=-0001-W51-4" ,"-678949=-0001-12-24=-0001-358=-0001-W51-5" diff --git a/test/Test/TestTimeZone.hs b/test/Test/TestTimeZone.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestTimeZone.hs @@ -0,0 +1,17 @@ +{-# OPTIONS -Wall -Werror #-} + +module Test.TestTimeZone where + +import Data.Time +import System.Posix.Env (putEnv) +import Test.TestUtil + +testTimeZone :: Test +testTimeZone = ioTest "getTimeZone respects TZ env var" $ do + putEnv "TZ=UTC+0" + zone1 <- getTimeZone epoch + putEnv "TZ=EST+5" + zone2 <- getTimeZone epoch + return $ diff False (zone1 == zone2) + where + epoch = UTCTime (ModifiedJulianDay 0) 0 diff --git a/test/Test/TestValid.hs b/test/Test/TestValid.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestValid.hs @@ -0,0 +1,61 @@ +module Test.TestValid where + +import Data.Time +import Data.Time.Calendar.OrdinalDate +import Data.Time.Calendar.WeekDate +import Data.Time.Calendar.Julian +import Test.QuickCheck hiding (Result,reason) +import Test.QuickCheck.Property +import Test.TestUtil hiding (Result) + + +validResult :: (Eq c,Show c,Eq t,Show t) => + Bool -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> c -> Result +validResult valid toComponents fromComponents fromComponentsValid c = let + 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 c,Eq c,Show c,Eq t,Show t) => + String -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> Test +validTest name toComponents fromComponents fromComponentsValid = testGroup name + [ + testProperty "valid" $ property $ validResult True toComponents fromComponents fromComponentsValid, + testProperty "invalid" $ property $ validResult False toComponents fromComponents fromComponentsValid + ] + +toSundayStartWeek :: Day -> (Integer,Int,Int) +toSundayStartWeek day = let + (y,_) = toOrdinalDate day + (m,d) = sundayStartWeek day + in (y,m,d) + +toMondayStartWeek :: Day -> (Integer,Int,Int) +toMondayStartWeek day = let + (y,_) = toOrdinalDate day + (m,d) = mondayStartWeek day + in (y,m,d) + +testValid :: Test +testValid = testGroup "testValid" + [ + validTest "Gregorian" toGregorian (\(y,m,d) -> fromGregorian y m d) (\(y,m,d) -> fromGregorianValid y m d), + validTest "OrdinalDate" toOrdinalDate (\(y,d) -> fromOrdinalDate y d) (\(y,d) -> fromOrdinalDateValid y d), + validTest "WeekDate" toWeekDate (\(y,m,d) -> fromWeekDate y m d) (\(y,m,d) -> fromWeekDateValid y m d), + validTest "SundayStartWeek" toSundayStartWeek (\(y,m,d) -> fromSundayStartWeek y m d) (\(y,m,d) -> fromSundayStartWeekValid y m d), + validTest "MondayStartWeek" toMondayStartWeek (\(y,m,d) -> fromMondayStartWeek y m d) (\(y,m,d) -> fromMondayStartWeekValid y m d), + validTest "Julian" toJulian (\(y,m,d) -> fromJulian y m d) (\(y,m,d) -> fromJulianValid y m d) + ] diff --git a/test/Test/Tests.hs b/test/Test/Tests.hs --- a/test/Test/Tests.hs +++ b/test/Test/Tests.hs @@ -14,6 +14,7 @@ import Test.TestParseTime import Test.TestTime import Test.TestTimeZone +import Test.TestValid tests :: [Test] tests = [ addDaysTest @@ -27,4 +28,5 @@ , testParseDAT , testParseTime , testTime - , testTimeZone ] + , testTimeZone + , testValid ] diff --git a/time.cabal b/time.cabal --- a/time.cabal +++ b/time.cabal @@ -1,5 +1,5 @@ name: time -version: 1.5.0.1 +version: 1.6 stability: stable license: BSD3 license-file: LICENSE @@ -11,10 +11,11 @@ description: A time library category: System build-type: Configure -cabal-version: >=1.14 +cabal-version: >=1.10 x-follows-version-policy: extra-source-files: + changelog.md aclocal.m4 configure.ac configure @@ -30,15 +31,11 @@ lib/include/HsTimeConfig.h source-repository head - type: git - location: https://github.com/haskell/time + type: git + location: https://github.com/haskell/time library hs-source-dirs: lib - build-depends: - base >= 4.4 && < 5, - deepseq >= 1.1 - ghc-options: -Wall default-language: Haskell2010 if impl(ghc) default-extensions: @@ -50,6 +47,10 @@ if impl(hugs) default-extensions: Rank2Types cpp-options: -DLANGUAGE_Rank2Types + ghc-options: -Wall -fwarn-tabs + build-depends: + base >= 4.3 && < 5, + deepseq >= 1.1 if os(windows) build-depends: Win32 exposed-modules: @@ -75,6 +76,7 @@ Data.Time.Clock.Scale, Data.Time.Clock.UTC, Data.Time.Clock.CTimeval, + Data.Time.Clock.CTimespec, Data.Time.Clock.UTCDiff, Data.Time.LocalTime.TimeZone, Data.Time.LocalTime.TimeOfDay, @@ -91,16 +93,18 @@ HsTimeConfig.h test-suite ShowDefaultTZAbbreviations - hs-source-dirs: test type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs build-depends: base, - time == 1.5.0.1 + time == 1.6 main-is: ShowDefaultTZAbbreviations.hs test-suite tests - hs-source-dirs: test type: exitcode-stdio-1.0 + hs-source-dirs: test default-language: Haskell2010 default-extensions: Rank2Types @@ -112,12 +116,12 @@ FlexibleInstances UndecidableInstances ScopedTypeVariables - ghc-options: -Wall + ghc-options: -Wall -fwarn-tabs c-sources: test/Test/TestFormatStuff.c build-depends: base, deepseq, - time == 1.5.0.1, + time == 1.6, QuickCheck >= 2.5.1, test-framework >= 0.8, test-framework-quickcheck2 >= 0.3, @@ -138,6 +142,8 @@ Test.TestEasterRef Test.TestCalendars Test.TestCalendarsRef + Test.TestTimeZone + Test.TestValid Test.LongWeekYears Test.LongWeekYearsRef Test.ConvertBack @@ -146,4 +152,3 @@ Test.AddDays Test.AddDaysRef Test.TestUtil -