Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • Haskell-mouse/time
1 result
Show changes
Hide whitespace changes
Inline Side-by-side
Showing
with 722 additions and 658 deletions
lib/Data/Time/Calendar/OrdinalDate.hs
View file @ baab563e
...@@ -67,7 +67,8 @@ fromOrdinalDateValid year day = do ...@@ -67,7 +67,8 @@ fromOrdinalDateValid year day = do
else 365 else 365
) )
day day
let y = year - 1 let
y = year - 1
mjd = (fromIntegral day') + (365 * y) + (div y 4) - (div y 100) + (div y 400) - 678576 mjd = (fromIntegral day') + (365 * y) + (div y 4) - (div y 100) + (div y 400) - 678576
return (ModifiedJulianDay mjd) return (ModifiedJulianDay mjd)
...@@ -114,18 +115,18 @@ fromMondayStartWeek :: ...@@ -114,18 +115,18 @@ fromMondayStartWeek ::
-- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime'). -- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime').
Int -> Int ->
Day Day
fromMondayStartWeek year w d = fromMondayStartWeek year w d = let
let -- first day of the year -- first day of the year
firstDay = fromOrdinalDate year 1 firstDay = fromOrdinalDate year 1
-- 0-based year day of first monday of the year -- 0-based year day of first monday of the year
zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7 zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7
-- 0-based week of year -- 0-based week of year
zbWeek = w - 1 zbWeek = w - 1
-- 0-based day of week -- 0-based day of week
zbDay = d - 1 zbDay = d - 1
-- 0-based day in year -- 0-based day in year
zbYearDay = zbFirstMonday + 7 * toInteger zbWeek + toInteger zbDay zbYearDay = zbFirstMonday + 7 * toInteger zbWeek + toInteger zbDay
in addDays zbYearDay firstDay in addDays zbYearDay firstDay
fromMondayStartWeekValid :: fromMondayStartWeekValid ::
-- | Year. -- | Year.
...@@ -138,7 +139,8 @@ fromMondayStartWeekValid :: ...@@ -138,7 +139,8 @@ fromMondayStartWeekValid ::
Maybe Day Maybe Day
fromMondayStartWeekValid year w d = do fromMondayStartWeekValid year w d = do
d' <- clipValid 1 7 d d' <- clipValid 1 7 d
let -- first day of the year let
-- first day of the year
firstDay = fromOrdinalDate year 1 firstDay = fromOrdinalDate year 1
-- 0-based week of year -- 0-based week of year
zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7 zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7
...@@ -171,18 +173,18 @@ fromSundayStartWeek :: ...@@ -171,18 +173,18 @@ fromSundayStartWeek ::
-- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime'). -- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime').
Int -> Int ->
Day Day
fromSundayStartWeek year w d = fromSundayStartWeek year w d = let
let -- first day of the year -- first day of the year
firstDay = fromOrdinalDate year 1 firstDay = fromOrdinalDate year 1
-- 0-based year day of first monday of the year -- 0-based year day of first monday of the year
zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7 zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7
-- 0-based week of year -- 0-based week of year
zbWeek = w - 1 zbWeek = w - 1
-- 0-based day of week -- 0-based day of week
zbDay = d zbDay = d
-- 0-based day in year -- 0-based day in year
zbYearDay = zbFirstSunday + 7 * toInteger zbWeek + toInteger zbDay zbYearDay = zbFirstSunday + 7 * toInteger zbWeek + toInteger zbDay
in addDays zbYearDay firstDay in addDays zbYearDay firstDay
fromSundayStartWeekValid :: fromSundayStartWeekValid ::
-- | Year. -- | Year.
...@@ -195,7 +197,8 @@ fromSundayStartWeekValid :: ...@@ -195,7 +197,8 @@ fromSundayStartWeekValid ::
Maybe Day Maybe Day
fromSundayStartWeekValid year w d = do fromSundayStartWeekValid year w d = do
d' <- clipValid 0 6 d d' <- clipValid 0 6 d
let -- first day of the year let
-- first day of the year
firstDay = fromOrdinalDate year 1 firstDay = fromOrdinalDate year 1
-- 0-based week of year -- 0-based week of year
zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7 zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7
......
lib/Data/Time/Calendar/Private.hs
View file @ baab563e
...@@ -74,6 +74,6 @@ remBy d n = n - (fromInteger f) * d ...@@ -74,6 +74,6 @@ remBy d n = n - (fromInteger f) * d
f = quotBy d n f = quotBy d n
quotRemBy :: (Real a, Integral b) => a -> a -> (b, a) quotRemBy :: (Real a, Integral b) => a -> a -> (b, a)
quotRemBy d n = quotRemBy d n = let
let f = quotBy d n f = quotBy d n
in (f, n - (fromIntegral f) * d) in (f, n - (fromIntegral f) * d)
lib/Data/Time/Calendar/Week.hs
View file @ baab563e
...@@ -6,6 +6,9 @@ module Data.Time.Calendar.Week ( ...@@ -6,6 +6,9 @@ module Data.Time.Calendar.Week (
dayOfWeek, dayOfWeek,
dayOfWeekDiff, dayOfWeekDiff,
firstDayOfWeekOnAfter, firstDayOfWeekOnAfter,
weekAllDays,
weekFirstDay,
weekLastDay,
) where ) where
import Control.DeepSeq import Control.DeepSeq
...@@ -36,15 +39,14 @@ instance NFData DayOfWeek where ...@@ -36,15 +39,14 @@ instance NFData DayOfWeek where
-- | \"Circular\", so for example @[Tuesday ..]@ gives an endless sequence. -- | \"Circular\", so for example @[Tuesday ..]@ gives an endless sequence.
-- Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday], and 'toEnum' performs mod 7 to give a cycle of days. -- Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday], and 'toEnum' performs mod 7 to give a cycle of days.
instance Enum DayOfWeek where instance Enum DayOfWeek where
toEnum i = toEnum i = case mod i 7 of
case mod i 7 of 0 -> Sunday
0 -> Sunday 1 -> Monday
1 -> Monday 2 -> Tuesday
2 -> Tuesday 3 -> Wednesday
3 -> Wednesday 4 -> Thursday
4 -> Thursday 5 -> Friday
5 -> Friday _ -> Saturday
_ -> Saturday
fromEnum Monday = 1 fromEnum Monday = 1
fromEnum Tuesday = 2 fromEnum Tuesday = 2
fromEnum Wednesday = 3 fromEnum Wednesday = 3
...@@ -70,3 +72,55 @@ dayOfWeekDiff a b = mod' (fromEnum a - fromEnum b) 7 ...@@ -70,3 +72,55 @@ dayOfWeekDiff a b = mod' (fromEnum a - fromEnum b) 7
-- | The first day-of-week on or after some day -- | The first day-of-week on or after some day
firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day
firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d
-- | Returns a week containing the given 'Day' where the first day is the
-- 'DayOfWeek' specified.
--
-- Examples:
--
-- >>> weekAllDays Sunday (YearMonthDay 2022 02 21)
-- [YearMonthDay 2022 2 20 .. YearMonthDay 2022 2 26]
--
-- >>> weekAllDays Monday (YearMonthDay 2022 02 21)
-- [YearMonthDay 2022 2 21 .. YearMonthDay 2022 2 27]
--
-- >>> weekAllDays Tuesday (YearMonthDay 2022 02 21)
-- [YearMonthDay 2022 2 15 .. YearMonthDay 2022 2 21]
--
-- @since 1.12.2
weekAllDays :: DayOfWeek -> Day -> [Day]
weekAllDays firstDay day = [weekFirstDay firstDay day .. weekLastDay firstDay day]
-- | Returns the first day of a week containing the given 'Day'.
--
-- Examples:
--
-- >>> weekFirstDay Sunday (YearMonthDay 2022 02 21)
-- YearMonthDay 2022 2 20
--
-- >>> weekFirstDay Monday (YearMonthDay 2022 02 21)
-- YearMonthDay 2022 2 21
--
-- >>> weekFirstDay Tuesday (YearMonthDay 2022 02 21)
-- YearMonthDay 2022 2 15
--
-- @since 1.12.2
weekFirstDay :: DayOfWeek -> Day -> Day
weekFirstDay firstDay day = addDays (negate 7) $ firstDayOfWeekOnAfter firstDay $ succ day
-- | Returns the last day of a week containing the given 'Day'.
--
-- Examples:
--
-- >>> weekLastDay Sunday (YearMonthDay 2022 02 21)
-- YearMonthDay 2022 2 26
--
-- >>> weekLastDay Monday (YearMonthDay 2022 02 21)
-- YearMonthDay 2022 2 27
--
-- >>> weekLastDay Tuesday (YearMonthDay 2022 02 21)
-- YearMonthDay 2022 2 21
--
-- @since 1.12.2
weekLastDay :: DayOfWeek -> Day -> Day
weekLastDay firstDay day = pred $ firstDayOfWeekOnAfter firstDay $ succ day
lib/Data/Time/Calendar/WeekDate.hs
View file @ baab563e
...@@ -32,11 +32,11 @@ data FirstWeekType ...@@ -32,11 +32,11 @@ data FirstWeekType
deriving (Eq) deriving (Eq)
firstDayOfWeekCalendar :: FirstWeekType -> DayOfWeek -> Year -> Day firstDayOfWeekCalendar :: FirstWeekType -> DayOfWeek -> Year -> Day
firstDayOfWeekCalendar wt dow year = firstDayOfWeekCalendar wt dow year = let
let jan1st = fromOrdinalDate year 1 jan1st = fromOrdinalDate year 1
in case wt of in case wt of
FirstWholeWeek -> firstDayOfWeekOnAfter dow jan1st FirstWholeWeek -> firstDayOfWeekOnAfter dow jan1st
FirstMostWeek -> firstDayOfWeekOnAfter dow $ addDays (-3) jan1st FirstMostWeek -> firstDayOfWeekOnAfter dow $ addDays (-3) jan1st
-- | Convert to the given kind of "week calendar". -- | Convert to the given kind of "week calendar".
-- Note that the year number matches the weeks, and so is not always the same as the Gregorian year number. -- Note that the year number matches the weeks, and so is not always the same as the Gregorian year number.
...@@ -47,18 +47,18 @@ toWeekCalendar :: ...@@ -47,18 +47,18 @@ toWeekCalendar ::
DayOfWeek -> DayOfWeek ->
Day -> Day ->
(Year, WeekOfYear, DayOfWeek) (Year, WeekOfYear, DayOfWeek)
toWeekCalendar wt ws d = toWeekCalendar wt ws d = let
let dw = dayOfWeek d dw = dayOfWeek d
(y0, _) = toOrdinalDate d (y0, _) = toOrdinalDate d
j1p = firstDayOfWeekCalendar wt ws $ pred y0 j1p = firstDayOfWeekCalendar wt ws $ pred y0
j1 = firstDayOfWeekCalendar wt ws y0 j1 = firstDayOfWeekCalendar wt ws y0
j1s = firstDayOfWeekCalendar wt ws $ succ y0 j1s = firstDayOfWeekCalendar wt ws $ succ y0
in if d < j1 in if d < j1
then (pred y0, succ $ div (fromInteger $ diffDays d j1p) 7, dw) then (pred y0, succ $ div (fromInteger $ diffDays d j1p) 7, dw)
else else
if d < j1s if d < j1s
then (y0, succ $ div (fromInteger $ diffDays d j1) 7, dw) then (y0, succ $ div (fromInteger $ diffDays d j1) 7, dw)
else (succ y0, succ $ div (fromInteger $ diffDays d j1s) 7, dw) else (succ y0, succ $ div (fromInteger $ diffDays d j1s) 7, dw)
-- | Convert from the given kind of "week calendar". -- | Convert from the given kind of "week calendar".
-- Invalid week and day values will be clipped to the correct range. -- Invalid week and day values will be clipped to the correct range.
...@@ -71,15 +71,15 @@ fromWeekCalendar :: ...@@ -71,15 +71,15 @@ fromWeekCalendar ::
WeekOfYear -> WeekOfYear ->
DayOfWeek -> DayOfWeek ->
Day Day
fromWeekCalendar wt ws y wy dw = fromWeekCalendar wt ws y wy dw = let
let d1 :: Day d1 :: Day
d1 = firstDayOfWeekCalendar wt ws y d1 = firstDayOfWeekCalendar wt ws y
wy' = clip 1 53 wy wy' = clip 1 53 wy
getday :: WeekOfYear -> Day getday :: WeekOfYear -> Day
getday wy'' = addDays (toInteger $ (pred wy'' * 7) + (dayOfWeekDiff dw ws)) d1 getday wy'' = addDays (toInteger $ (pred wy'' * 7) + (dayOfWeekDiff dw ws)) d1
d1s = firstDayOfWeekCalendar wt ws $ succ y d1s = firstDayOfWeekCalendar wt ws $ succ y
day = getday wy' day = getday wy'
in if wy' == 53 then if day >= d1s then getday 52 else day else day in if wy' == 53 then if day >= d1s then getday 52 else day else day
-- | Convert from the given kind of "week calendar". -- | Convert from the given kind of "week calendar".
-- Invalid week and day values will return Nothing. -- Invalid week and day values will return Nothing.
...@@ -92,17 +92,17 @@ fromWeekCalendarValid :: ...@@ -92,17 +92,17 @@ fromWeekCalendarValid ::
WeekOfYear -> WeekOfYear ->
DayOfWeek -> DayOfWeek ->
Maybe Day Maybe Day
fromWeekCalendarValid wt ws y wy dw = fromWeekCalendarValid wt ws y wy dw = let
let d = fromWeekCalendar wt ws y wy dw d = fromWeekCalendar wt ws y wy dw
in if toWeekCalendar wt ws d == (y, wy, dw) then Just d else Nothing in if toWeekCalendar wt ws d == (y, wy, dw) then Just d else Nothing
-- | Convert to ISO 8601 Week Date format. First element of result is year, second week number (1-53), third day of week (1 for Monday to 7 for Sunday). -- | Convert to ISO 8601 Week Date format. First element of result is year, second week number (1-53), third day of week (1 for Monday to 7 for Sunday).
-- Note that \"Week\" years are not quite the same as Gregorian years, as the first day of the year is always a Monday. -- Note that \"Week\" years are not quite the same as Gregorian years, as the first day of the year is always a Monday.
-- The first week of a year is the first week to contain at least four days in the corresponding Gregorian year. -- The first week of a year is the first week to contain at least four days in the corresponding Gregorian year.
toWeekDate :: Day -> (Year, WeekOfYear, Int) toWeekDate :: Day -> (Year, WeekOfYear, Int)
toWeekDate d = toWeekDate d = let
let (y, wy, dw) = toWeekCalendar FirstMostWeek Monday d (y, wy, dw) = toWeekCalendar FirstMostWeek Monday d
in (y, wy, fromEnum dw) in (y, wy, fromEnum dw)
-- | Convert from ISO 8601 Week Date format. First argument is year, second week number (1-52 or 53), third day of week (1 for Monday to 7 for Sunday). -- | 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. -- Invalid week and day values will be clipped to the correct range.
......
lib/Data/Time/Clock/Internal/CTimespec.hsc
View file @ baab563e
{-# LANGUAGE CApiFFI #-}
module Data.Time.Clock.Internal.CTimespec where module Data.Time.Clock.Internal.CTimespec where
#include "HsTimeConfig.h" #include "HsTimeConfig.h"
...@@ -49,8 +51,7 @@ clockGetTime clockid = alloca (\ptspec -> do ...@@ -49,8 +51,7 @@ clockGetTime clockid = alloca (\ptspec -> do
peek ptspec peek ptspec
) )
clock_REALTIME :: ClockID foreign import capi unsafe "time.h value CLOCK_REALTIME" clock_REALTIME :: ClockID
clock_REALTIME = #{const CLOCK_REALTIME}
clock_TAI :: Maybe ClockID clock_TAI :: Maybe ClockID
clock_TAI = clock_TAI =
......
lib/Data/Time/Clock/Internal/DiffTime.hs
View file @ baab563e
...@@ -64,9 +64,9 @@ instance Fractional DiffTime where ...@@ -64,9 +64,9 @@ instance Fractional DiffTime where
fromRational r = MkDiffTime (fromRational r) fromRational r = MkDiffTime (fromRational r)
instance RealFrac DiffTime where instance RealFrac DiffTime where
properFraction (MkDiffTime a) = properFraction (MkDiffTime a) = let
let (b', a') = properFraction a (b', a') = properFraction a
in (b', MkDiffTime a') in (b', MkDiffTime a')
truncate (MkDiffTime a) = truncate a truncate (MkDiffTime a) = truncate a
round (MkDiffTime a) = round a round (MkDiffTime a) = round a
ceiling (MkDiffTime a) = ceiling a ceiling (MkDiffTime a) = ceiling a
......
lib/Data/Time/Clock/Internal/SystemTime.hs
View file @ baab563e
...@@ -57,7 +57,7 @@ getTime_resolution :: DiffTime ...@@ -57,7 +57,7 @@ getTime_resolution :: DiffTime
getTAISystemTime :: Maybe (DiffTime, IO SystemTime) getTAISystemTime :: Maybe (DiffTime, IO SystemTime)
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS
-- On Windows, the equlvalent of POSIX time is "file time", defined as -- On Windows, the equivalent of POSIX time is "file time", defined as
-- the number of 100-nanosecond intervals that have elapsed since -- the number of 100-nanosecond intervals that have elapsed since
-- 12:00 A.M. January 1, 1601 (UTC). We can convert this into a POSIX -- 12:00 A.M. January 1, 1601 (UTC). We can convert this into a POSIX
-- time by adjusting the offset to be relative to the POSIX epoch. -- time by adjusting the offset to be relative to the POSIX epoch.
......
lib/Data/Time/Clock/Internal/UTCTime.hs
View file @ baab563e
...@@ -23,10 +23,10 @@ import Data.Time.Clock.Internal.DiffTime ...@@ -23,10 +23,10 @@ import Data.Time.Clock.Internal.DiffTime
-- It consists of the day number, and a time offset from midnight. -- 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. -- Note that if a day has a leap second added to it, it will have 86401 seconds.
data UTCTime = UTCTime data UTCTime = UTCTime
{ -- | the day { utctDay :: Day
utctDay :: Day -- ^ the day
, -- | the time from midnight, 0 <= t < 86401s (because of leap-seconds) , utctDayTime :: DiffTime
utctDayTime :: DiffTime -- ^ the time from midnight, 0 <= t < 86401s (because of leap-seconds)
} }
deriving (Data, Typeable) deriving (Data, Typeable)
......
lib/Data/Time/Clock/POSIX.hs
View file @ baab563e
...@@ -34,9 +34,9 @@ import Data.Time.Clock.Internal.UTCTime ...@@ -34,9 +34,9 @@ import Data.Time.Clock.Internal.UTCTime
import Data.Time.Clock.System import Data.Time.Clock.System
posixSecondsToUTCTime :: POSIXTime -> UTCTime posixSecondsToUTCTime :: POSIXTime -> UTCTime
posixSecondsToUTCTime i = posixSecondsToUTCTime i = let
let (d, t) = divMod' i posixDayLength (d, t) = divMod' i posixDayLength
in UTCTime (addDays d systemEpochDay) (realToFrac t) in UTCTime (addDays d systemEpochDay) (realToFrac t)
utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime d t) = utcTimeToPOSIXSeconds (UTCTime d t) =
......
lib/Data/Time/Clock/System.hs
View file @ baab563e
...@@ -27,48 +27,48 @@ truncateSystemTimeLeapSecond t = t ...@@ -27,48 +27,48 @@ truncateSystemTimeLeapSecond t = t
-- | Convert 'SystemTime' to 'UTCTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC. -- | Convert 'SystemTime' to 'UTCTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC.
systemToUTCTime :: SystemTime -> UTCTime systemToUTCTime :: SystemTime -> UTCTime
systemToUTCTime (MkSystemTime seconds nanoseconds) = systemToUTCTime (MkSystemTime seconds nanoseconds) = let
let days :: Int64 days :: Int64
timeSeconds :: Int64 timeSeconds :: Int64
(days, timeSeconds) = seconds `divMod` 86400 (days, timeSeconds) = seconds `divMod` 86400
day :: Day day :: Day
day = addDays (fromIntegral days) systemEpochDay day = addDays (fromIntegral days) systemEpochDay
timeNanoseconds :: Int64 timeNanoseconds :: Int64
timeNanoseconds = timeSeconds * 1000000000 + (fromIntegral nanoseconds) timeNanoseconds = timeSeconds * 1000000000 + (fromIntegral nanoseconds)
timePicoseconds :: Int64 timePicoseconds :: Int64
timePicoseconds = timeNanoseconds * 1000 timePicoseconds = timeNanoseconds * 1000
time :: DiffTime time :: DiffTime
time = picosecondsToDiffTime $ fromIntegral timePicoseconds time = picosecondsToDiffTime $ fromIntegral timePicoseconds
in UTCTime day time in UTCTime day time
-- | Convert 'UTCTime' to 'SystemTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC. -- | Convert 'UTCTime' to 'SystemTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC.
utcToSystemTime :: UTCTime -> SystemTime utcToSystemTime :: UTCTime -> SystemTime
utcToSystemTime (UTCTime day time) = utcToSystemTime (UTCTime day time) = let
let days :: Int64 days :: Int64
days = fromIntegral $ diffDays day systemEpochDay days = fromIntegral $ diffDays day systemEpochDay
timePicoseconds :: Int64 timePicoseconds :: Int64
timePicoseconds = fromIntegral $ diffTimeToPicoseconds time timePicoseconds = fromIntegral $ diffTimeToPicoseconds time
timeNanoseconds :: Int64 timeNanoseconds :: Int64
timeNanoseconds = timePicoseconds `div` 1000 timeNanoseconds = timePicoseconds `div` 1000
timeSeconds :: Int64 timeSeconds :: Int64
nanoseconds :: Int64 nanoseconds :: Int64
(timeSeconds, nanoseconds) = (timeSeconds, nanoseconds) =
if timeNanoseconds >= 86400000000000 if timeNanoseconds >= 86400000000000
then (86399, timeNanoseconds - 86399000000000) then (86399, timeNanoseconds - 86399000000000)
else timeNanoseconds `divMod` 1000000000 else timeNanoseconds `divMod` 1000000000
seconds :: Int64 seconds :: Int64
seconds = days * 86400 + timeSeconds seconds = days * 86400 + timeSeconds
in MkSystemTime seconds $ fromIntegral nanoseconds in MkSystemTime seconds $ fromIntegral nanoseconds
systemEpochAbsolute :: AbsoluteTime systemEpochAbsolute :: AbsoluteTime
systemEpochAbsolute = taiNominalDayStart systemEpochDay systemEpochAbsolute = taiNominalDayStart systemEpochDay
-- | Convert 'SystemTime' to 'AbsoluteTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' TAI. -- | Convert 'SystemTime' to 'AbsoluteTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' TAI.
systemToTAITime :: SystemTime -> AbsoluteTime systemToTAITime :: SystemTime -> AbsoluteTime
systemToTAITime (MkSystemTime s ns) = systemToTAITime (MkSystemTime s ns) = let
let diff :: DiffTime diff :: DiffTime
diff = (fromIntegral s) + (fromIntegral ns) * 1E-9 diff = (fromIntegral s) + (fromIntegral ns) * 1E-9
in addAbsoluteTime diff systemEpochAbsolute in addAbsoluteTime diff systemEpochAbsolute
-- | The day of the epoch of 'SystemTime', 1970-01-01 -- | The day of the epoch of 'SystemTime', 1970-01-01
systemEpochDay :: Day systemEpochDay :: Day
......
lib/Data/Time/Clock/TAI.hs
View file @ baab563e
...@@ -49,16 +49,17 @@ utcToTAITime lsmap (UTCTime day dtime) = do ...@@ -49,16 +49,17 @@ utcToTAITime lsmap (UTCTime day dtime) = do
return $ addAbsoluteTime dtime t return $ addAbsoluteTime dtime t
taiToUTCTime :: LeapSecondMap -> AbsoluteTime -> Maybe UTCTime taiToUTCTime :: LeapSecondMap -> AbsoluteTime -> Maybe UTCTime
taiToUTCTime lsmap abstime = taiToUTCTime lsmap abstime = let
let stable day = do stable day = do
dayt <- dayStart lsmap day dayt <- dayStart lsmap day
len <- utcDayLength lsmap day len <- utcDayLength lsmap day
let dtime = diffAbsoluteTime abstime dayt let
day' = addDays (div' dtime len) day dtime = diffAbsoluteTime abstime dayt
if day == day' day' = addDays (div' dtime len) day
then return (UTCTime day dtime) if day == day'
else stable day' then return (UTCTime day dtime)
in stable $ ModifiedJulianDay $ div' (diffAbsoluteTime abstime taiEpoch) 86400 else stable day'
in stable $ ModifiedJulianDay $ div' (diffAbsoluteTime abstime taiEpoch) 86400
-- | TAI clock, if it exists. Note that it is unlikely to be set correctly, without due care and attention. -- | TAI clock, if it exists. Note that it is unlikely to be set correctly, without due care and attention.
taiClock :: Maybe (DiffTime, IO AbsoluteTime) taiClock :: Maybe (DiffTime, IO AbsoluteTime)
......
lib/Data/Time/Format/Format/Class.hs
View file @ baab563e
...@@ -39,33 +39,28 @@ class FormatTime t where ...@@ -39,33 +39,28 @@ class FormatTime t where
-- the weird UNIX logic is here -- the weird UNIX logic is here
getPadOption :: Bool -> Bool -> Int -> Char -> Maybe FormatNumericPadding -> Maybe Int -> PadOption getPadOption :: Bool -> Bool -> Int -> Char -> Maybe FormatNumericPadding -> Maybe Int -> PadOption
getPadOption trunc fdef idef cdef mnpad mi = getPadOption trunc fdef idef cdef mnpad mi = let
let c = c = case mnpad of
case mnpad of Just (Just c') -> c'
Just (Just c') -> c' Just Nothing -> ' '
Just Nothing -> ' ' _ -> cdef
_ -> cdef i = case mi of
i = Just i' -> case mnpad of
case mi of Just Nothing -> i'
Just i' -> _ ->
case mnpad of if trunc
Just Nothing -> i' then i'
_ -> else max i' idef
if trunc Nothing -> idef
then i' f = case mi of
else max i' idef Just _ -> True
Nothing -> idef Nothing -> case mnpad of
f = Nothing -> fdef
case mi of Just Nothing -> False
Just _ -> True Just (Just _) -> True
Nothing -> in if f
case mnpad of then Pad i c
Nothing -> fdef else NoPad
Just Nothing -> False
Just (Just _) -> True
in if f
then Pad i c
else NoPad
formatGeneral :: formatGeneral ::
Bool -> Bool -> Int -> Char -> (TimeLocale -> PadOption -> t -> String) -> (FormatOptions -> t -> String) Bool -> Bool -> Int -> Char -> (TimeLocale -> PadOption -> t -> String) -> (FormatOptions -> t -> String)
...@@ -84,25 +79,25 @@ formatNumberStd n = formatNumber False n '0' ...@@ -84,25 +79,25 @@ formatNumberStd n = formatNumber False n '0'
showPaddedFixed :: HasResolution a => PadOption -> PadOption -> Fixed a -> String showPaddedFixed :: HasResolution a => PadOption -> PadOption -> Fixed a -> String
showPaddedFixed padn padf x showPaddedFixed padn padf x
| x < 0 = '-' : showPaddedFixed padn padf (negate x) | x < 0 = '-' : showPaddedFixed padn padf (negate x)
showPaddedFixed padn padf x = showPaddedFixed padn padf x = let
let ns = showPaddedNum padn $ (floor x :: Integer) ns = showPaddedNum padn $ (floor x :: Integer)
fs = showPaddedFixedFraction padf x fs = showPaddedFixedFraction padf x
ds = ds =
if null fs if null fs
then "" then ""
else "." else "."
in ns ++ ds ++ fs in ns ++ ds ++ fs
showPaddedFixedFraction :: HasResolution a => PadOption -> Fixed a -> String showPaddedFixedFraction :: HasResolution a => PadOption -> Fixed a -> String
showPaddedFixedFraction pado x = showPaddedFixedFraction pado x = let
let digits = dropWhile (== '.') $ dropWhile (/= '.') $ showFixed True x digits = dropWhile (== '.') $ dropWhile (/= '.') $ showFixed True x
n = length digits n = length digits
in case pado of in case pado of
NoPad -> digits NoPad -> digits
Pad i c -> Pad i c ->
if i < n if i < n
then take i digits then take i digits
else digits ++ replicate (i - n) c else digits ++ replicate (i - n) c
-- | Substitute various time-related information for each %-code in the string, as per 'formatCharacter'. -- | Substitute various time-related information for each %-code in the string, as per 'formatCharacter'.
-- --
...@@ -358,9 +353,9 @@ pullNumber mx s@(c : cs) = ...@@ -358,9 +353,9 @@ pullNumber mx s@(c : cs) =
formatTime2 :: formatTime2 ::
(FormatTime t) => TimeLocale -> (String -> String) -> Maybe FormatNumericPadding -> String -> t -> Maybe String (FormatTime t) => TimeLocale -> (String -> String) -> Maybe FormatNumericPadding -> String -> t -> Maybe String
formatTime2 locale recase mpad cs t = formatTime2 locale recase mpad cs t = let
let (mwidth, rest) = pullNumber Nothing cs (mwidth, rest) = pullNumber Nothing cs
in formatTime3 locale recase mpad mwidth rest t in formatTime3 locale recase mpad mwidth rest t
formatTime3 :: formatTime3 ::
(FormatTime t) => (FormatTime t) =>
......
lib/Data/Time/Format/Format/Instances.hs
View file @ baab563e
...@@ -39,11 +39,11 @@ instance FormatTime LocalTime where ...@@ -39,11 +39,11 @@ instance FormatTime LocalTime where
<|> mapFormatCharacter localTimeOfDay (formatCharacter alt c) <|> mapFormatCharacter localTimeOfDay (formatCharacter alt c)
todAMPM :: TimeLocale -> TimeOfDay -> String todAMPM :: TimeLocale -> TimeOfDay -> String
todAMPM locale day = todAMPM locale day = let
let (am, pm) = amPm locale (am, pm) = amPm locale
in if (todHour day) < 12 in if (todHour day) < 12
then am then am
else pm else pm
tod12Hour :: TimeOfDay -> Int tod12Hour :: TimeOfDay -> Int
tod12Hour day = (mod (todHour day - 1) 12) + 1 tod12Hour day = (mod (todHour day - 1) 12) + 1
...@@ -87,15 +87,15 @@ instance FormatTime TimeZone where ...@@ -87,15 +87,15 @@ instance FormatTime TimeZone where
formatCharacter False 'z' = Just $ formatGeneral False True 4 '0' $ \_ -> timeZoneOffsetString'' False formatCharacter False 'z' = Just $ formatGeneral False True 4 '0' $ \_ -> timeZoneOffsetString'' False
formatCharacter True 'z' = Just $ formatGeneral False True 5 '0' $ \_ -> timeZoneOffsetString'' True formatCharacter True 'z' = Just $ formatGeneral False True 5 '0' $ \_ -> timeZoneOffsetString'' True
formatCharacter alt 'Z' = formatCharacter alt 'Z' =
Just $ \fo z -> Just $ \fo z -> let
let n = timeZoneName z n = timeZoneName z
idef = idef =
if alt if alt
then 5 then 5
else 4 else 4
in if null n in if null n
then formatGeneral False True idef '0' (\_ -> timeZoneOffsetString'' alt) fo z then formatGeneral False True idef '0' (\_ -> timeZoneOffsetString'' alt) fo z
else formatString (\_ -> timeZoneName) fo z else formatString (\_ -> timeZoneName) fo z
formatCharacter _ _ = Nothing formatCharacter _ _ = Nothing
instance FormatTime DayOfWeek where instance FormatTime DayOfWeek where
...@@ -166,12 +166,11 @@ instance FormatTime NominalDiffTime where ...@@ -166,12 +166,11 @@ instance FormatTime NominalDiffTime where
formatCharacter False 'S' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 1 formatCharacter False 'S' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 1
formatCharacter True 'S' = formatCharacter True 'S' =
Just $ Just $
formatGeneral True False 12 '0' $ \_ padf t -> formatGeneral True False 12 '0' $ \_ padf t -> let
let padn = padn = case padf of
case padf of NoPad -> NoPad
NoPad -> NoPad Pad _ c -> Pad 2 c
Pad _ c -> Pad 2 c in showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico)
in showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico)
formatCharacter _ _ = Nothing formatCharacter _ _ = Nothing
instance FormatTime DiffTime where instance FormatTime DiffTime where
...@@ -188,12 +187,11 @@ instance FormatTime DiffTime where ...@@ -188,12 +187,11 @@ instance FormatTime DiffTime where
formatCharacter False 'S' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 1 formatCharacter False 'S' = Just $ formatNumberStd 2 $ remBy 60 . quotBy 1
formatCharacter True 'S' = formatCharacter True 'S' =
Just $ Just $
formatGeneral True False 12 '0' $ \_ padf t -> formatGeneral True False 12 '0' $ \_ padf t -> let
let padn = padn = case padf of
case padf of NoPad -> NoPad
NoPad -> NoPad Pad _ c -> Pad 2 c
Pad _ c -> Pad 2 c in showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico)
in showPaddedFixed padn padf (realToFrac $ remBy 60 t :: Pico)
formatCharacter _ _ = Nothing formatCharacter _ _ = Nothing
instance FormatTime CalendarDiffDays where instance FormatTime CalendarDiffDays where
......
lib/Data/Time/Format/ISO8601.hs
View file @ baab563e
...@@ -231,27 +231,26 @@ fromRationalRound r = fromRational $ round (r * 1000000000000) % 1000000000000 ...@@ -231,27 +231,26 @@ fromRationalRound r = fromRational $ round (r * 1000000000000) % 1000000000000
-- | ISO 8601:2004(E) sec. 4.2.2.3(a), 4.2.2.4(b) -- | ISO 8601:2004(E) sec. 4.2.2.3(a), 4.2.2.4(b)
hourMinuteFormat :: FormatExtension -> Format TimeOfDay hourMinuteFormat :: FormatExtension -> Format TimeOfDay
hourMinuteFormat fe = hourMinuteFormat fe = let
let toTOD (h, m) = toTOD (h, m) =
case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ (fromIntegral h) * 3600 + m * 60 of case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ (fromIntegral h) * 3600 + m * 60 of
(0, tod) -> Just tod (0, tod) -> Just tod
(1, TimeOfDay 0 0 0) -> Just $ TimeOfDay 24 0 0 (1, TimeOfDay 0 0 0) -> Just $ TimeOfDay 24 0 0
_ -> Nothing _ -> Nothing
fromTOD tod = fromTOD tod = let
let mm = (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 60 mm = (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 60
in Just $ quotRemBy 60 mm in Just $ quotRemBy 60 mm
in mapMFormat toTOD fromTOD $ extColonFormat fe hourFormat' $ minuteDecimalFormat in mapMFormat toTOD fromTOD $ extColonFormat fe hourFormat' $ minuteDecimalFormat
-- | ISO 8601:2004(E) sec. 4.2.2.3(b), 4.2.2.4(c) -- | ISO 8601:2004(E) sec. 4.2.2.3(b), 4.2.2.4(c)
hourFormat :: Format TimeOfDay hourFormat :: Format TimeOfDay
hourFormat = hourFormat = let
let toTOD h = toTOD h = case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ h * 3600 of
case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ h * 3600 of (0, tod) -> Just tod
(0, tod) -> Just tod (1, TimeOfDay 0 0 0) -> Just $ TimeOfDay 24 0 0
(1, TimeOfDay 0 0 0) -> Just $ TimeOfDay 24 0 0 _ -> Nothing
_ -> Nothing fromTOD tod = Just $ (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 3600
fromTOD tod = Just $ (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 3600 in mapMFormat toTOD fromTOD $ hourDecimalFormat
in mapMFormat toTOD fromTOD $ hourDecimalFormat
-- | ISO 8601:2004(E) sec. 4.2.2.5 -- | ISO 8601:2004(E) sec. 4.2.2.5
withTimeDesignator :: Format t -> Format t withTimeDesignator :: Format t -> Format t
...@@ -263,14 +262,19 @@ withUTCDesignator f = f <** literalFormat "Z" ...@@ -263,14 +262,19 @@ withUTCDesignator f = f <** literalFormat "Z"
-- | ISO 8601:2004(E) sec. 4.2.5.1 -- | ISO 8601:2004(E) sec. 4.2.5.1
timeOffsetFormat :: FormatExtension -> Format TimeZone timeOffsetFormat :: FormatExtension -> Format TimeZone
timeOffsetFormat fe = timeOffsetFormat fe = let
let toTimeZone (sign, (h, m)) = minutesToTimeZone $ sign * (h * 60 + m) toTimeZone (sign, ehm) =
fromTimeZone tz = minutesToTimeZone $
let mm = timeZoneMinutes tz sign * case ehm of
hm = quotRem (abs mm) 60 Left h -> h * 60
in (signum mm, hm) Right (h, m) -> h * 60 + m
in isoMap toTimeZone fromTimeZone $ fromTimeZone tz = let
mandatorySignFormat <**> extColonFormat fe (integerFormat NoSign (Just 2)) (integerFormat NoSign (Just 2)) mm = timeZoneMinutes tz
(h, m) = quotRem (abs mm) 60
in (signum mm, Right (h, m))
digits2 = integerFormat NoSign (Just 2)
in isoMap toTimeZone fromTimeZone $
mandatorySignFormat <**> (digits2 <++> extColonFormat fe digits2 digits2)
-- | ISO 8601:2004(E) sec. 4.2.5.2 -- | ISO 8601:2004(E) sec. 4.2.5.2
timeOfDayAndOffsetFormat :: FormatExtension -> Format (TimeOfDay, TimeZone) timeOfDayAndOffsetFormat :: FormatExtension -> Format (TimeOfDay, TimeZone)
...@@ -307,10 +311,10 @@ decDesignator :: (Eq t, Show t, Read t, Num t) => Char -> Format t ...@@ -307,10 +311,10 @@ decDesignator :: (Eq t, Show t, Read t, Num t) => Char -> Format t
decDesignator c = optionalFormat 0 $ decimalFormat NoSign Nothing <** literalFormat [c] decDesignator c = optionalFormat 0 $ decimalFormat NoSign Nothing <** literalFormat [c]
daysDesigs :: Format CalendarDiffDays daysDesigs :: Format CalendarDiffDays
daysDesigs = daysDesigs = let
let toCD (y, (m, (w, d))) = CalendarDiffDays (y * 12 + m) (w * 7 + d) toCD (y, (m, (w, d))) = CalendarDiffDays (y * 12 + m) (w * 7 + d)
fromCD (CalendarDiffDays mm d) = (quot mm 12, (rem mm 12, (0, d))) fromCD (CalendarDiffDays mm d) = (quot mm 12, (rem mm 12, (0, d)))
in isoMap toCD fromCD $ intDesignator 'Y' <**> intDesignator 'M' <**> intDesignator 'W' <**> intDesignator 'D' in isoMap toCD fromCD $ intDesignator 'Y' <**> intDesignator 'M' <**> intDesignator 'W' <**> intDesignator 'D'
-- | ISO 8601:2004(E) sec. 4.4.3.2 -- | ISO 8601:2004(E) sec. 4.4.3.2
durationDaysFormat :: Format CalendarDiffDays durationDaysFormat :: Format CalendarDiffDays
...@@ -318,44 +322,44 @@ durationDaysFormat = (**>) (literalFormat "P") $ specialCaseShowFormat (mempty, ...@@ -318,44 +322,44 @@ durationDaysFormat = (**>) (literalFormat "P") $ specialCaseShowFormat (mempty,
-- | ISO 8601:2004(E) sec. 4.4.3.2 -- | ISO 8601:2004(E) sec. 4.4.3.2
durationTimeFormat :: Format CalendarDiffTime durationTimeFormat :: Format CalendarDiffTime
durationTimeFormat = durationTimeFormat = let
let toCT (cd, (h, (m, s))) = toCT (cd, (h, (m, s))) =
mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s) mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s)
fromCT (CalendarDiffTime mm t) = fromCT (CalendarDiffTime mm t) = let
let (d, TimeOfDay h m s) = timeToDaysAndTimeOfDay t (d, TimeOfDay h m s) = timeToDaysAndTimeOfDay t
in (CalendarDiffDays mm d, (h, (m, s))) in (CalendarDiffDays mm d, (h, (m, s)))
in (**>) (literalFormat "P") $ in (**>) (literalFormat "P") $
specialCaseShowFormat (mempty, "0D") $ specialCaseShowFormat (mempty, "0D") $
isoMap toCT fromCT $ isoMap toCT fromCT $
(<**>) daysDesigs $ (<**>) daysDesigs $
optionalFormat (0, (0, 0)) $ optionalFormat (0, (0, 0)) $
literalFormat "T" **> intDesignator 'H' <**> intDesignator 'M' <**> decDesignator 'S' literalFormat "T" **> intDesignator 'H' <**> intDesignator 'M' <**> decDesignator 'S'
-- | ISO 8601:2004(E) sec. 4.4.3.3 -- | ISO 8601:2004(E) sec. 4.4.3.3
alternativeDurationDaysFormat :: FormatExtension -> Format CalendarDiffDays alternativeDurationDaysFormat :: FormatExtension -> Format CalendarDiffDays
alternativeDurationDaysFormat fe = alternativeDurationDaysFormat fe = let
let toCD (y, (m, d)) = CalendarDiffDays (y * 12 + m) d toCD (y, (m, d)) = CalendarDiffDays (y * 12 + m) d
fromCD (CalendarDiffDays mm d) = (quot mm 12, (rem mm 12, d)) fromCD (CalendarDiffDays mm d) = (quot mm 12, (rem mm 12, d))
in isoMap toCD fromCD $ in isoMap toCD fromCD $
(**>) (literalFormat "P") $ (**>) (literalFormat "P") $
extDashFormat fe (clipFormat (0, 9999) $ integerFormat NegSign $ Just 4) $ extDashFormat fe (clipFormat (0, 9999) $ integerFormat NegSign $ Just 4) $
extDashFormat fe (clipFormat (0, 12) $ integerFormat NegSign $ Just 2) $ extDashFormat fe (clipFormat (0, 12) $ integerFormat NegSign $ Just 2) $
(clipFormat (0, 30) $ integerFormat NegSign $ Just 2) (clipFormat (0, 30) $ integerFormat NegSign $ Just 2)
-- | ISO 8601:2004(E) sec. 4.4.3.3 -- | ISO 8601:2004(E) sec. 4.4.3.3
alternativeDurationTimeFormat :: FormatExtension -> Format CalendarDiffTime alternativeDurationTimeFormat :: FormatExtension -> Format CalendarDiffTime
alternativeDurationTimeFormat fe = alternativeDurationTimeFormat fe = let
let toCT (cd, (h, (m, s))) = toCT (cd, (h, (m, s))) =
mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s) mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s)
fromCT (CalendarDiffTime mm t) = fromCT (CalendarDiffTime mm t) = let
let (d, TimeOfDay h m s) = timeToDaysAndTimeOfDay t (d, TimeOfDay h m s) = timeToDaysAndTimeOfDay t
in (CalendarDiffDays mm d, (h, (m, s))) in (CalendarDiffDays mm d, (h, (m, s)))
in isoMap toCT fromCT $ in isoMap toCT fromCT $
(<**>) (alternativeDurationDaysFormat fe) $ (<**>) (alternativeDurationDaysFormat fe) $
withTimeDesignator $ withTimeDesignator $
extColonFormat fe (clipFormat (0, 24) $ integerFormat NegSign (Just 2)) $ extColonFormat fe (clipFormat (0, 24) $ integerFormat NegSign (Just 2)) $
extColonFormat fe (clipFormat (0, 60) $ integerFormat NegSign (Just 2)) $ extColonFormat fe (clipFormat (0, 60) $ integerFormat NegSign (Just 2)) $
(clipFormat (0, 60) $ decimalFormat NegSign (Just 2)) (clipFormat (0, 60) $ decimalFormat NegSign (Just 2))
-- | ISO 8601:2004(E) sec. 4.4.4.1 -- | ISO 8601:2004(E) sec. 4.4.4.1
intervalFormat :: Format a -> Format b -> Format (a, b) intervalFormat :: Format a -> Format b -> Format (a, b)
......
lib/Data/Time/Format/Internal.hs
View file @ baab563e
...@@ -4,9 +4,10 @@ ...@@ -4,9 +4,10 @@
--The contents of this module is liable to change, or disappear entirely. --The contents of this module is liable to change, or disappear entirely.
--Please <https://github.com/haskell/time/issues/new let me know> if you depend on anything here. --Please <https://github.com/haskell/time/issues/new let me know> if you depend on anything here.
module Data.Time.Format.Internal ( module Data.Time.Format.Internal (
-- * ISO8601 formatting
Format (..), Format (..),
FormatTime (..), module Data.Time.Format.Format.Class,
ParseTime (..), module Data.Time.Format.Parse.Class,
) where ) where
import Data.Format import Data.Format
......
lib/Data/Time/Format/Locale.hs
View file @ baab563e
...@@ -26,7 +26,7 @@ data TimeLocale = TimeLocale ...@@ -26,7 +26,7 @@ data TimeLocale = TimeLocale
-- | Locale representing American usage. -- | Locale representing American usage.
-- --
-- 'knownTimeZones' contains only the ten time-zones mentioned in RFC 802 sec. 5: -- 'knownTimeZones' contains only the ten time-zones mentioned in RFC 822 sec. 5:
-- \"UT\", \"GMT\", \"EST\", \"EDT\", \"CST\", \"CDT\", \"MST\", \"MDT\", \"PST\", \"PDT\". -- \"UT\", \"GMT\", \"EST\", \"EDT\", \"CST\", \"CDT\", \"MST\", \"MDT\", \"PST\", \"PDT\".
-- Note that the parsing functions will regardless parse \"UTC\", single-letter military time-zones, and +HHMM format. -- Note that the parsing functions will regardless parse \"UTC\", single-letter military time-zones, and +HHMM format.
defaultTimeLocale :: TimeLocale defaultTimeLocale :: TimeLocale
......
lib/Data/Time/Format/Parse.hs
View file @ baab563e
...@@ -224,13 +224,15 @@ instance Read LocalTime where ...@@ -224,13 +224,15 @@ instance Read LocalTime where
-- | This only works for @±HHMM@ format, -- | This only works for @±HHMM@ format,
-- single-letter military time-zones, -- single-letter military time-zones,
-- and these time-zones: \"UTC\", \"UT\", \"GMT\", \"EST\", \"EDT\", \"CST\", \"CDT\", \"MST\", \"MDT\", \"PST\", \"PDT\",
-- per RFC 822 section 5.
instance Read TimeZone where instance Read TimeZone where
readsPrec _ = readParen False $ readSTime True defaultTimeLocale "%Z" readsPrec _ = readParen False $ readSTime True defaultTimeLocale "%Z"
-- | This only works for a 'zonedTimeZone' in @±HHMM@ format, -- | This only works for a 'zonedTimeZone' in @±HHMM@ format,
-- single-letter military time-zones, -- single-letter military time-zones,
-- and these time-zones: \"UTC\", \"UT\", \"GMT\", \"EST\", \"EDT\", \"CST\", \"CDT\", \"MST\", \"MDT\", \"PST\", \"PDT\",
-- per RFC 822 section 5.
instance Read ZonedTime where instance Read ZonedTime where
readsPrec n = readParen False $ \s -> [(ZonedTime t z, r2) | (t, r1) <- readsPrec n s, (z, r2) <- readsPrec n r1] readsPrec n = readParen False $ \s -> [(ZonedTime t z, r2) | (t, r1) <- readsPrec n s, (z, r2) <- readsPrec n r1]
......
lib/Data/Time/Format/Parse/Class.hs
View file @ baab563e
...@@ -55,7 +55,8 @@ charCI c = satisfy (\x -> toUpper c == toUpper x) ...@@ -55,7 +55,8 @@ charCI c = satisfy (\x -> toUpper c == toUpper x)
-- | Case-insensitive version of 'Text.ParserCombinators.ReadP.string'. -- | Case-insensitive version of 'Text.ParserCombinators.ReadP.string'.
stringCI :: String -> ReadP String stringCI :: String -> ReadP String
stringCI this = do stringCI this = do
let scan [] _ = return this let
scan [] _ = return this
scan (x : xs) (y : ys) scan (x : xs) (y : ys)
| toUpper x == toUpper y = do | toUpper x == toUpper y = do
_ <- get _ <- get
...@@ -65,41 +66,38 @@ stringCI this = do ...@@ -65,41 +66,38 @@ stringCI this = do
scan this s scan this s
parseSpecifiers :: ParseTime t => Proxy t -> TimeLocale -> String -> ReadP [(Char, String)] parseSpecifiers :: ParseTime t => Proxy t -> TimeLocale -> String -> ReadP [(Char, String)]
parseSpecifiers pt locale = parseSpecifiers pt locale = let
let parse :: String -> ReadP [(Char, String)] parse :: String -> ReadP [(Char, String)]
parse [] = return [] parse [] = return []
parse ('%' : cs) = parse1 cs parse ('%' : cs) = parse1 cs
parse (c : cs) parse (c : cs) | isSpace c = do
| isSpace c = do _ <- satisfy isSpace
_ <- satisfy isSpace case cs of
case cs of (c' : _) | isSpace c' -> return ()
(c' : _) _ -> skipSpaces
| isSpace c' -> return () parse cs
_ -> skipSpaces parse (c : cs) = do
parse cs _ <- charCI c
parse (c : cs) = do parse cs
_ <- charCI c parse1 :: String -> ReadP [(Char, String)]
parse cs parse1 ('-' : cs) = parse2 (Just NoPadding) cs
parse1 :: String -> ReadP [(Char, String)] parse1 ('_' : cs) = parse2 (Just SpacePadding) cs
parse1 ('-' : cs) = parse2 (Just NoPadding) cs parse1 ('0' : cs) = parse2 (Just ZeroPadding) cs
parse1 ('_' : cs) = parse2 (Just SpacePadding) cs parse1 cs = parse2 Nothing cs
parse1 ('0' : cs) = parse2 (Just ZeroPadding) cs parse2 :: Maybe ParseNumericPadding -> String -> ReadP [(Char, String)]
parse1 cs = parse2 Nothing cs parse2 mpad ('E' : cs) = parse3 mpad True cs
parse2 :: Maybe ParseNumericPadding -> String -> ReadP [(Char, String)] parse2 mpad cs = parse3 mpad False cs
parse2 mpad ('E' : cs) = parse3 mpad True cs parse3 :: Maybe ParseNumericPadding -> Bool -> String -> ReadP [(Char, String)]
parse2 mpad cs = parse3 mpad False cs parse3 _ _ ('%' : cs) = do
parse3 :: Maybe ParseNumericPadding -> Bool -> String -> ReadP [(Char, String)] _ <- char '%'
parse3 _ _ ('%' : cs) = do parse cs
_ <- char '%' parse3 _ _ (c : cs) | Just s <- substituteTimeSpecifier pt locale c = parse $ s ++ cs
parse cs parse3 mpad _alt (c : cs) = do
parse3 _ _ (c : cs) str <- parseTimeSpecifier pt locale mpad c
| Just s <- substituteTimeSpecifier pt locale c = parse $ s ++ cs specs <- parse cs
parse3 mpad _alt (c : cs) = do return $ (c, str) : specs
str <- parseTimeSpecifier pt locale mpad c parse3 _ _ [] = return []
specs <- parse cs in parse
return $ (c, str) : specs
parse3 _ _ [] = return []
in parse
data PaddingSide data PaddingSide
= PrePadding = PrePadding
...@@ -138,76 +136,78 @@ parseSignedDecimal = do ...@@ -138,76 +136,78 @@ parseSignedDecimal = do
return $ sign ++ digits ++ decimaldigits return $ sign ++ digits ++ decimaldigits
timeParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String timeParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String
timeParseTimeSpecifier l mpad c = timeParseTimeSpecifier l mpad c = let
let digits' ps pad = parsePaddedDigits ps (fromMaybe pad mpad) digits' ps pad = parsePaddedDigits ps (fromMaybe pad mpad)
digits pad = digits' PrePadding pad False digits pad = digits' PrePadding pad False
oneOf = choice . map stringCI oneOf = choice . map stringCI
numericTZ = do numericTZ = do
s <- choice [char '+', char '-'] s <- choice [char '+', char '-']
h <- parsePaddedDigits PrePadding ZeroPadding False 2 h <- parsePaddedDigits PrePadding ZeroPadding False 2
optional (char ':') optional (char ':')
m <- parsePaddedDigits PrePadding ZeroPadding False 2 m <- parsePaddedDigits PrePadding ZeroPadding False 2
return (s : h ++ m) return (s : h ++ m)
allowNegative :: ReadP String -> ReadP String allowNegative :: ReadP String -> ReadP String
allowNegative p = (char '-' >> fmap ('-' :) p) <++ p allowNegative p = (char '-' >> fmap ('-' :) p) <++ p
in case c of in case c of
-- century -- century
'C' -> allowNegative $ digits SpacePadding 2 'C' -> allowNegative $ digits SpacePadding 2
'f' -> allowNegative $ digits SpacePadding 2 'f' -> allowNegative $ digits SpacePadding 2
-- year -- year
'Y' -> allowNegative $ digits SpacePadding 4 'Y' -> allowNegative $ digits SpacePadding 4
'G' -> allowNegative $ digits SpacePadding 4 'G' -> allowNegative $ digits SpacePadding 4
-- year of century -- year of century
'y' -> digits ZeroPadding 2 'y' -> digits ZeroPadding 2
'g' -> digits ZeroPadding 2 'g' -> digits ZeroPadding 2
-- month of year -- month of year
'B' -> oneOf (map fst (months l)) 'B' -> oneOf (map fst (months l))
'b' -> oneOf (map snd (months l)) 'b' -> oneOf (map snd (months l))
'm' -> digits ZeroPadding 2 'm' -> digits ZeroPadding 2
-- day of month -- day of month
'd' -> digits ZeroPadding 2 'd' -> digits ZeroPadding 2
'e' -> digits SpacePadding 2 'e' -> digits SpacePadding 2
-- week of year -- week of year
'V' -> digits ZeroPadding 2 'V' -> digits ZeroPadding 2
'U' -> digits ZeroPadding 2 'U' -> digits ZeroPadding 2
'W' -> digits ZeroPadding 2 'W' -> digits ZeroPadding 2
-- day of week -- day of week
'u' -> oneOf $ map (: []) ['1' .. '7'] 'u' -> oneOf $ map (: []) ['1' .. '7']
'a' -> oneOf (map snd (wDays l)) 'a' -> oneOf (map snd (wDays l))
'A' -> oneOf (map fst (wDays l)) 'A' -> oneOf (map fst (wDays l))
'w' -> oneOf $ map (: []) ['0' .. '6'] 'w' -> oneOf $ map (: []) ['0' .. '6']
-- day of year -- day of year
'j' -> digits ZeroPadding 3 'j' -> digits ZeroPadding 3
-- dayhalf of day (i.e. AM or PM) -- dayhalf of day (i.e. AM or PM)
'P' -> 'P' ->
oneOf oneOf
( let (am, pm) = amPm l ( let
in [am, pm] (am, pm) = amPm l
) in [am, pm]
'p' -> )
oneOf 'p' ->
( let (am, pm) = amPm l oneOf
in [am, pm] ( let
) (am, pm) = amPm l
-- hour of day (i.e. 24h) in [am, pm]
'H' -> digits ZeroPadding 2 )
'k' -> digits SpacePadding 2 -- hour of day (i.e. 24h)
-- hour of dayhalf (i.e. 12h) 'H' -> digits ZeroPadding 2
'I' -> digits ZeroPadding 2 'k' -> digits SpacePadding 2
'l' -> digits SpacePadding 2 -- hour of dayhalf (i.e. 12h)
-- minute of hour 'I' -> digits ZeroPadding 2
'M' -> digits ZeroPadding 2 'l' -> digits SpacePadding 2
-- second of minute -- minute of hour
'S' -> digits ZeroPadding 2 'M' -> digits ZeroPadding 2
-- picosecond of second -- second of minute
'q' -> digits' PostPadding ZeroPadding True 12 'S' -> digits ZeroPadding 2
'Q' -> (char '.' >> digits' PostPadding NoPadding True 12) <++ return "" -- picosecond of second
-- time zone 'q' -> digits' PostPadding ZeroPadding True 12
'z' -> numericTZ 'Q' -> (char '.' >> digits' PostPadding NoPadding True 12) <++ return ""
'Z' -> munch1 isAlpha <++ numericTZ -- time zone
-- seconds since epoch 'z' -> numericTZ
's' -> (char '-' >> fmap ('-' :) (munch1 isDigit)) <++ munch1 isDigit 'Z' -> munch1 isAlpha <++ numericTZ
_ -> fail $ "Unknown format character: " ++ show c -- seconds since epoch
's' -> (char '-' >> fmap ('-' :) (munch1 isDigit)) <++ munch1 isDigit
_ -> fail $ "Unknown format character: " ++ show c
timeSubstituteTimeSpecifier :: TimeLocale -> Char -> Maybe String timeSubstituteTimeSpecifier :: TimeLocale -> Char -> Maybe String
timeSubstituteTimeSpecifier l 'c' = Just $ dateTimeFmt l timeSubstituteTimeSpecifier l 'c' = Just $ dateTimeFmt l
...@@ -222,19 +222,19 @@ timeSubstituteTimeSpecifier _ 'h' = Just "%b" ...@@ -222,19 +222,19 @@ timeSubstituteTimeSpecifier _ 'h' = Just "%b"
timeSubstituteTimeSpecifier _ _ = Nothing timeSubstituteTimeSpecifier _ _ = Nothing
durationParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String durationParseTimeSpecifier :: TimeLocale -> Maybe ParseNumericPadding -> Char -> ReadP String
durationParseTimeSpecifier _ mpad c = durationParseTimeSpecifier _ mpad c = let
let padopt = parsePaddedSignedDigits $ fromMaybe NoPadding mpad padopt = parsePaddedSignedDigits $ fromMaybe NoPadding mpad
in case c of in case c of
'y' -> padopt 1 'y' -> padopt 1
'b' -> padopt 1 'b' -> padopt 1
'B' -> padopt 2 'B' -> padopt 2
'w' -> padopt 1 'w' -> padopt 1
'd' -> padopt 1 'd' -> padopt 1
'D' -> padopt 1 'D' -> padopt 1
'h' -> padopt 1 'h' -> padopt 1
'H' -> padopt 2 'H' -> padopt 2
'm' -> padopt 1 'm' -> padopt 1
'M' -> padopt 2 'M' -> padopt 2
's' -> parseSignedDecimal 's' -> parseSignedDecimal
'S' -> parseSignedDecimal 'S' -> parseSignedDecimal
_ -> fail $ "Unknown format character: " ++ show c _ -> fail $ "Unknown format character: " ++ show c
lib/Data/Time/Format/Parse/Instances.hs
View file @ baab563e
...@@ -49,115 +49,118 @@ data WeekType ...@@ -49,115 +49,118 @@ data WeekType
| MondayWeek | MondayWeek
makeDayComponent :: TimeLocale -> Char -> String -> Maybe [DayComponent] makeDayComponent :: TimeLocale -> Char -> String -> Maybe [DayComponent]
makeDayComponent l c x = makeDayComponent l c x = let
let ra :: (Read a) => Maybe a ra :: (Read a) => Maybe a
ra = readMaybe x ra = readMaybe x
zeroBasedListIndex :: [String] -> Maybe Int zeroBasedListIndex :: [String] -> Maybe Int
zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss
oneBasedListIndex :: [String] -> Maybe Int oneBasedListIndex :: [String] -> Maybe Int
oneBasedListIndex ss = do oneBasedListIndex ss = do
index <- zeroBasedListIndex ss index <- zeroBasedListIndex ss
return $ 1 + index return $ 1 + index
in case c of in case c of
-- %C: century (all but the last two digits of the year), 00 - 99 -- %C: century (all but the last two digits of the year), 00 - 99
'C' -> do 'C' -> do
a <- ra a <- ra
return [DCCentury a] return [DCCentury a]
-- %f century (all but the last two digits of the year), 00 - 99 -- %f century (all but the last two digits of the year), 00 - 99
'f' -> do 'f' -> do
a <- ra a <- ra
return [DCCentury a] return [DCCentury a]
-- %Y: year -- %Y: year
'Y' -> do 'Y' -> do
a <- ra a <- ra
return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)] return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)]
-- %G: year for Week Date format -- %G: year for Week Date format
'G' -> do 'G' -> do
a <- ra a <- ra
return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)] return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)]
-- %y: last two digits of year, 00 - 99 -- %y: last two digits of year, 00 - 99
'y' -> do 'y' -> do
a <- ra a <- ra
return [DCCenturyYear a] return [DCCenturyYear a]
-- %g: last two digits of year for Week Date format, 00 - 99 -- %g: last two digits of year for Week Date format, 00 - 99
'g' -> do 'g' -> do
a <- ra a <- ra
return [DCCenturyYear a] return [DCCenturyYear a]
-- %B: month name, long form (fst from months locale), January - December -- %B: month name, long form (fst from months locale), January - December
'B' -> do 'B' -> do
a <- oneBasedListIndex $ fmap fst $ months l a <- oneBasedListIndex $ fmap fst $ months l
return [DCYearMonth a] return [DCYearMonth a]
-- %b: month name, short form (snd from months locale), Jan - Dec -- %b: month name, short form (snd from months locale), Jan - Dec
'b' -> do 'b' -> do
a <- oneBasedListIndex $ fmap snd $ months l a <- oneBasedListIndex $ fmap snd $ months l
return [DCYearMonth a] return [DCYearMonth a]
-- %m: month of year, leading 0 as needed, 01 - 12 -- %m: month of year, leading 0 as needed, 01 - 12
'm' -> do 'm' -> do
raw <- ra raw <- ra
a <- clipValid 1 12 raw a <- clipValid 1 12 raw
return [DCYearMonth a] return [DCYearMonth a]
-- %d: day of month, leading 0 as needed, 01 - 31 -- %d: day of month, leading 0 as needed, 01 - 31
'd' -> do 'd' -> do
raw <- ra raw <- ra
a <- clipValid 1 31 raw a <- clipValid 1 31 raw
return [DCMonthDay a] return [DCMonthDay a]
-- %e: day of month, leading space as needed, 1 - 31 -- %e: day of month, leading space as needed, 1 - 31
'e' -> do 'e' -> do
raw <- ra raw <- ra
a <- clipValid 1 31 raw a <- clipValid 1 31 raw
return [DCMonthDay a] return [DCMonthDay a]
-- %V: week for Week Date format, 01 - 53 -- %V: week for Week Date format, 01 - 53
'V' -> do 'V' -> do
raw <- ra raw <- ra
a <- clipValid 1 53 raw a <- clipValid 1 53 raw
return [DCYearWeek ISOWeek a] return [DCYearWeek ISOWeek a]
-- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53 -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53
'U' -> do 'U' -> do
raw <- ra raw <- ra
a <- clipValid 0 53 raw a <- clipValid 0 53 raw
return [DCYearWeek SundayWeek a] return [DCYearWeek SundayWeek a]
-- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53 -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53
'W' -> do 'W' -> do
raw <- ra raw <- ra
a <- clipValid 0 53 raw a <- clipValid 0 53 raw
return [DCYearWeek MondayWeek a] return [DCYearWeek MondayWeek a]
-- %u: day for Week Date format, 1 - 7 -- %u: day for Week Date format, 1 - 7
'u' -> do 'u' -> do
raw <- ra raw <- ra
a <- clipValid 1 7 raw a <- clipValid 1 7 raw
return [DCWeekDay a] return [DCWeekDay a]
-- %a: day of week, short form (snd from wDays locale), Sun - Sat -- %a: day of week, short form (snd from wDays locale), Sun - Sat
'a' -> do 'a' -> do
a' <- zeroBasedListIndex $ fmap snd $ wDays l a' <- zeroBasedListIndex $ fmap snd $ wDays l
let a = let
if a' == 0 a =
then 7 if a' == 0
else a' then 7
return [DCWeekDay a] else a'
-- %A: day of week, long form (fst from wDays locale), Sunday - Saturday return [DCWeekDay a]
'A' -> do -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday
a' <- zeroBasedListIndex $ fmap fst $ wDays l 'A' -> do
let a = a' <- zeroBasedListIndex $ fmap fst $ wDays l
if a' == 0 let
then 7 a =
else a' if a' == 0
return [DCWeekDay a] then 7
-- %w: day of week number, 0 (= Sunday) - 6 (= Saturday) else a'
'w' -> do return [DCWeekDay a]
raw <- ra -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday)
a' <- clipValid 0 6 raw 'w' -> do
let a = raw <- ra
if a' == 0 a' <- clipValid 0 6 raw
then 7 let
else a' a =
return [DCWeekDay a] if a' == 0
-- %j: day of year for Ordinal Date format, 001 - 366 then 7
'j' -> do else a'
raw <- ra return [DCWeekDay a]
a <- clipValid 1 366 raw -- %j: day of year for Ordinal Date format, 001 - 366
return [DCYearDay a] 'j' -> do
-- unrecognised, pass on to other parsers raw <- ra
_ -> return [] a <- clipValid 1 366 raw
return [DCYearDay a]
-- unrecognised, pass on to other parsers
_ -> return []
makeDayComponents :: TimeLocale -> [(Char, String)] -> Maybe [DayComponent] makeDayComponents :: TimeLocale -> [(Char, String)] -> Maybe [DayComponent]
makeDayComponents l pairs = do makeDayComponents l pairs = do
...@@ -174,26 +177,27 @@ instance ParseTime Day where ...@@ -174,26 +177,27 @@ instance ParseTime Day where
cs <- makeDayComponents l pairs cs <- makeDayComponents l pairs
-- 'Nothing' indicates a parse failure, -- 'Nothing' indicates a parse failure,
-- while 'Just []' means no information -- while 'Just []' means no information
let y = let
let d = safeLast 70 [x | DCCenturyYear x <- cs] y = let
c = d = safeLast 70 [x | DCCenturyYear x <- cs]
safeLast c =
( if d >= 69 safeLast
then 19 ( if d >= 69
else 20 then 19
) else 20
[x | DCCentury x <- cs] )
in 100 * c + d [x | DCCentury x <- cs]
rest (DCYearMonth m : _) = in 100 * c + d
let d = safeLast 1 [x | DCMonthDay x <- cs] rest (DCYearMonth m : _) = let
in fromGregorianValid y m d d = safeLast 1 [x | DCMonthDay x <- cs]
in fromGregorianValid y m d
rest (DCYearDay d : _) = fromOrdinalDateValid y d rest (DCYearDay d : _) = fromOrdinalDateValid y d
rest (DCYearWeek wt w : _) = rest (DCYearWeek wt w : _) = let
let d = safeLast 4 [x | DCWeekDay x <- cs] d = safeLast 4 [x | DCWeekDay x <- cs]
in case wt of in case wt of
ISOWeek -> fromWeekDateValid y w d ISOWeek -> fromWeekDateValid y w d
SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7) SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7)
MondayWeek -> fromMondayStartWeekValid y w d MondayWeek -> fromMondayStartWeekValid y w d
rest (_ : xs) = rest xs rest (_ : xs) = rest xs
rest [] = rest [DCYearMonth 1] rest [] = rest [DCYearMonth 1]
rest cs rest cs
...@@ -205,90 +209,91 @@ instance ParseTime Month where ...@@ -205,90 +209,91 @@ instance ParseTime Month where
cs <- makeDayComponents l pairs cs <- makeDayComponents l pairs
-- 'Nothing' indicates a parse failure, -- 'Nothing' indicates a parse failure,
-- while 'Just []' means no information -- while 'Just []' means no information
let y = let
let d = safeLast 70 [x | DCCenturyYear x <- cs] y = let
c = d = safeLast 70 [x | DCCenturyYear x <- cs]
safeLast c =
( if d >= 69 safeLast
then 19 ( if d >= 69
else 20 then 19
) else 20
[x | DCCentury x <- cs] )
in 100 * c + d [x | DCCentury x <- cs]
in 100 * c + d
rest (DCYearMonth m : _) = fromYearMonthValid y m rest (DCYearMonth m : _) = fromYearMonthValid y m
rest (_ : xs) = rest xs rest (_ : xs) = rest xs
rest [] = fromYearMonthValid y 1 rest [] = fromYearMonthValid y 1
rest cs rest cs
mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a
mfoldl f = mfoldl f = let
let mf ma b = do mf ma b = do
a <- ma a <- ma
f a b f a b
in foldl mf in foldl mf
instance ParseTime TimeOfDay where instance ParseTime TimeOfDay where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l = buildTime l = let
let f t@(TimeOfDay h m s) (c, x) = f t@(TimeOfDay h m s) (c, x) = let
let ra :: (Read a) => Maybe a ra :: (Read a) => Maybe a
ra = readMaybe x ra = readMaybe x
getAmPm = getAmPm = let
let upx = map toUpper x upx = map toUpper x
(amStr, pmStr) = amPm l (amStr, pmStr) = amPm l
in if upx == amStr in if upx == amStr
then Just $ TimeOfDay (h `mod` 12) m s then Just $ TimeOfDay (h `mod` 12) m s
else else
if upx == pmStr if upx == pmStr
then then
Just $ Just $
TimeOfDay TimeOfDay
( if h < 12 ( if h < 12
then h + 12 then h + 12
else h else h
) )
m m
s s
else Nothing else Nothing
in case c of in case c of
'P' -> getAmPm 'P' -> getAmPm
'p' -> getAmPm 'p' -> getAmPm
'H' -> do 'H' -> do
raw <- ra raw <- ra
a <- clipValid 0 23 raw a <- clipValid 0 23 raw
return $ TimeOfDay a m s return $ TimeOfDay a m s
'I' -> do 'I' -> do
raw <- ra raw <- ra
a <- clipValid 1 12 raw a <- clipValid 1 12 raw
return $ TimeOfDay a m s return $ TimeOfDay a m s
'k' -> do 'k' -> do
raw <- ra raw <- ra
a <- clipValid 0 23 raw a <- clipValid 0 23 raw
return $ TimeOfDay a m s return $ TimeOfDay a m s
'l' -> do 'l' -> do
raw <- ra raw <- ra
a <- clipValid 1 12 raw a <- clipValid 1 12 raw
return $ TimeOfDay a m s return $ TimeOfDay a m s
'M' -> do 'M' -> do
raw <- ra raw <- ra
a <- clipValid 0 59 raw a <- clipValid 0 59 raw
return $ TimeOfDay h a s return $ TimeOfDay h a s
'S' -> do 'S' -> do
raw <- ra raw <- ra
a <- clipValid 0 60 raw a <- clipValid 0 60 raw
return $ TimeOfDay h m (fromInteger a) return $ TimeOfDay h m (fromInteger a)
'q' -> do 'q' -> do
ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0
return $ TimeOfDay h m (mkPico (floor s) ps)
'Q' ->
if null x
then Just t
else do
ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0 ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0
return $ TimeOfDay h m (mkPico (floor s) ps) return $ TimeOfDay h m (mkPico (floor s) ps)
'Q' -> _ -> Just t
if null x in mfoldl f (Just midnight)
then Just t
else do
ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0
return $ TimeOfDay h m (mkPico (floor s) ps)
_ -> Just t
in mfoldl f (Just midnight)
rpad :: Int -> a -> [a] -> [a] rpad :: Int -> a -> [a] -> [a]
rpad n c xs = xs ++ replicate (n - length xs) c rpad n c xs = xs ++ replicate (n - length xs) c
...@@ -318,11 +323,11 @@ getMilZoneHours 'Z' = Just 0 ...@@ -318,11 +323,11 @@ getMilZoneHours 'Z' = Just 0
getMilZoneHours _ = Nothing getMilZoneHours _ = Nothing
getMilZone :: Char -> Maybe TimeZone getMilZone :: Char -> Maybe TimeZone
getMilZone c = getMilZone c = let
let yc = toUpper c yc = toUpper c
in do in do
hours <- getMilZoneHours yc hours <- getMilZoneHours yc
return $ TimeZone (hours * 60) False [yc] return $ TimeZone (hours * 60) False [yc]
getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone
getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (knownTimeZones locale) getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (knownTimeZones locale)
...@@ -330,49 +335,50 @@ getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (know ...@@ -330,49 +335,50 @@ getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (know
instance ParseTime TimeZone where instance ParseTime TimeZone where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l = buildTime l = let
let f :: Char -> String -> TimeZone -> Maybe TimeZone f :: Char -> String -> TimeZone -> Maybe TimeZone
f 'z' str (TimeZone _ dst name) f 'z' str (TimeZone _ dst name)
| Just offset <- readTzOffset str = Just $ TimeZone offset dst name | Just offset <- readTzOffset str = Just $ TimeZone offset dst name
f 'z' _ _ = Nothing f 'z' _ _ = Nothing
f 'Z' str _ f 'Z' str _
| Just offset <- readTzOffset str = Just $ TimeZone offset False "" | Just offset <- readTzOffset str = Just $ TimeZone offset False ""
f 'Z' str _ f 'Z' str _
| Just zone <- getKnownTimeZone l str = Just zone | Just zone <- getKnownTimeZone l str = Just zone
f 'Z' "UTC" _ = Just utc f 'Z' "UTC" _ = Just utc
f 'Z' [c] _ f 'Z' [c] _
| Just zone <- getMilZone c = Just zone | Just zone <- getMilZone c = Just zone
f 'Z' _ _ = Nothing f 'Z' _ _ = Nothing
f _ _ tz = Just tz f _ _ tz = Just tz
in foldl (\mt (c, s) -> mt >>= f c s) (Just $ minutesToTimeZone 0) in foldl (\mt (c, s) -> mt >>= f c s) (Just $ minutesToTimeZone 0)
readTzOffset :: String -> Maybe Int readTzOffset :: String -> Maybe Int
readTzOffset str = readTzOffset str = let
let getSign '+' = Just 1 getSign '+' = Just 1
getSign '-' = Just (-1) getSign '-' = Just (-1)
getSign _ = Nothing getSign _ = Nothing
calc s h1 h2 m1 m2 = do calc s h1 h2 m1 m2 = do
sign <- getSign s sign <- getSign s
h <- readMaybe [h1, h2] h <- readMaybe [h1, h2]
m <- readMaybe [m1, m2] m <- readMaybe [m1, m2]
return $ sign * (60 * h + m) return $ sign * (60 * h + m)
in case str of 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
(s : h1 : h2 : m1 : m2 : []) -> calc s h1 h2 m1 m2 (s : h1 : h2 : m1 : m2 : []) -> calc s h1 h2 m1 m2
_ -> Nothing _ -> Nothing
instance ParseTime ZonedTime where instance ParseTime ZonedTime where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
parseTimeSpecifier _ = timeParseTimeSpecifier parseTimeSpecifier _ = timeParseTimeSpecifier
buildTime l xs = buildTime l xs = let
let f (ZonedTime (LocalTime _ tod) z) ('s', x) = do f (ZonedTime (LocalTime _ tod) z) ('s', x) = do
a <- readMaybe x a <- readMaybe x
let s = fromInteger a let
(_, ps) = properFraction (todSec tod) :: (Integer, Pico) s = fromInteger a
s' = s + fromRational (toRational ps) (_, ps) = properFraction (todSec tod) :: (Integer, Pico)
return $ utcToZonedTime z (posixSecondsToUTCTime s') s' = s + fromRational (toRational ps)
f t _ = Just t return $ utcToZonedTime z (posixSecondsToUTCTime s')
in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs f t _ = Just t
in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs
instance ParseTime UTCTime where instance ParseTime UTCTime where
substituteTimeSpecifier _ = timeSubstituteTimeSpecifier substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
...@@ -408,20 +414,19 @@ buildTimeDays xs = do ...@@ -408,20 +414,19 @@ buildTimeDays xs = do
buildTimeSeconds :: [(Char, String)] -> Maybe Pico buildTimeSeconds :: [(Char, String)] -> Maybe Pico
buildTimeSeconds xs = do buildTimeSeconds xs = do
tt <- tt <- for xs $ \(c, s) -> let
for xs $ \(c, s) -> readInt :: Integer -> Maybe Pico
let readInt :: Integer -> Maybe Pico readInt t = do
readInt t = do i <- readMaybe s
i <- readMaybe s return $ fromInteger $ i * t
return $ fromInteger $ i * t in case c of
in case c of 'h' -> readInt 3600
'h' -> readInt 3600 'H' -> readInt 3600
'H' -> readInt 3600 'm' -> readInt 60
'm' -> readInt 60 'M' -> readInt 60
'M' -> readInt 60 's' -> readMaybe s
's' -> readMaybe s 'S' -> readMaybe s
'S' -> readMaybe s _ -> return 0
_ -> return 0
return $ sum tt return $ sum tt
instance ParseTime NominalDiffTime where instance ParseTime NominalDiffTime where
......
lib/Data/Time/LocalTime/Internal/TimeOfDay.hs
View file @ baab563e
...@@ -31,13 +31,13 @@ import Data.Time.LocalTime.Internal.TimeZone ...@@ -31,13 +31,13 @@ import Data.Time.LocalTime.Internal.TimeZone
-- @TimeOfDay 24 0 0@ is considered invalid for the purposes of 'makeTimeOfDayValid', as well as reading and parsing, -- @TimeOfDay 24 0 0@ is considered invalid for the purposes of 'makeTimeOfDayValid', as well as reading and parsing,
-- but valid for ISO 8601 parsing in "Data.Time.Format.ISO8601". -- but valid for ISO 8601 parsing in "Data.Time.Format.ISO8601".
data TimeOfDay = TimeOfDay data TimeOfDay = TimeOfDay
{ -- | range 0 - 23 { todHour :: Int
todHour :: Int -- ^ range 0 - 23
, -- | range 0 - 59 , todMin :: Int
todMin :: Int -- ^ range 0 - 59
, -- | Note that 0 <= 'todSec' < 61, accomodating leap seconds. , todSec :: Pico
-- Any local minute may have a leap second, since leap seconds happen in all zones simultaneously -- ^ Note that 0 <= 'todSec' < 61, accomodating leap seconds.
todSec :: Pico -- Any local minute may have a leap second, since leap seconds happen in all zones simultaneously
} }
deriving (Eq, Ord, Data, Typeable) deriving (Eq, Ord, Data, Typeable)
...@@ -65,12 +65,12 @@ makeTimeOfDayValid h m s = do ...@@ -65,12 +65,12 @@ makeTimeOfDayValid h m s = do
-- | Convert a period of time into a count of days and a time of day since midnight. -- | Convert a period of time into a count of days and a time of day since midnight.
-- The time of day will never have a leap second. -- The time of day will never have a leap second.
timeToDaysAndTimeOfDay :: NominalDiffTime -> (Integer, TimeOfDay) timeToDaysAndTimeOfDay :: NominalDiffTime -> (Integer, TimeOfDay)
timeToDaysAndTimeOfDay dt = timeToDaysAndTimeOfDay dt = let
let s = realToFrac dt s = realToFrac dt
(m, ms) = divMod' s 60 (m, ms) = divMod' s 60
(h, hm) = divMod' m 60 (h, hm) = divMod' m 60
(d, dh) = divMod' h 24 (d, dh) = divMod' h 24
in (d, TimeOfDay dh hm ms) in (d, TimeOfDay dh hm ms)
-- | Convert a count of days and a time of day since midnight into a period of time. -- | Convert a count of days and a time of day since midnight into a period of time.
daysAndTimeOfDayToTime :: Integer -> TimeOfDay -> NominalDiffTime daysAndTimeOfDayToTime :: Integer -> TimeOfDay -> NominalDiffTime
......