module Data.Time.Class.Time () where
import Control.Monad.IO.Class
import qualified Data.Time.Calendar as Cal
import qualified Data.Time.Calendar.WeekDate as Cal
import Data.Time.Class
import Data.Time.Clock
import Data.Time.LocalTime
instance (MonadIO m) => GetTime m UTCTime where
getTime = liftIO getCurrentTime
instance SkipDate UTCTime where
dateBegin (Week wd0) (UTCTime d tod) =
let (_, _, wd) = Cal.toWeekDate d
dd = mod (wd0 wd) 7
in UTCTime (Cal.addDays (if dd == 0 && tod /= 0 then 7 else toInteger dd) d) 0
dateBegin Month (UTCTime d' tod) =
let (y, m, md) = Cal.toGregorian d'
d = Cal.fromGregorian y m 1
in UTCTime (if tod == 0 && md == 1 then d else Cal.addGregorianMonthsClip 1 d) 0
dateBegin Year (UTCTime d' tod) =
let (y, m, md) = Cal.toGregorian d'
d = Cal.fromGregorian y 1 1
in UTCTime (if tod == 0 && md == 1 && m == 1 then d else Cal.addGregorianYearsClip 1 d) 0
dateNext (Week wd0) (UTCTime d _) =
let (_, _, wd) = Cal.toWeekDate d
dd = mod (wd0 wd) 7
in UTCTime (Cal.addDays (if dd == 0 then 7 else toInteger dd) d) 0
dateNext Month (UTCTime d' _) =
let (y, m, _) = Cal.toGregorian d'
d = Cal.fromGregorian y m 1
in UTCTime (Cal.addGregorianMonthsClip 1 d) 0
dateNext Year (UTCTime d' _) =
let (y, _, _) = Cal.toGregorian d'
d = Cal.fromGregorian y 1 1
in UTCTime (Cal.addGregorianYearsClip 1 d) 0
dateSkip n unit (UTCTime d tod) =
UTCTime (case unit of
Week _ -> Cal.addDays (7*n) d
Month -> Cal.addGregorianMonthsClip n d
Year -> Cal.addGregorianYearsClip n d)
(
if tod < 86400
then tod
else tod / 86401 * 86400)
instance SkipUnit UTCTime where
begin unit t@(UTCTime _ tod) =
let pf = properFraction in
case unit of
Second | (_, 0) <- pf tod -> t
Minute | (s, 0) <- pf tod, mod s 60 == 0 -> t
Hour | (s, 0) <- pf tod, mod s 3600 == 0 -> t
Day | tod == 0 -> t
_ -> next unit t
next Second (UTCTime d tod) =
addTime 1 (UTCTime d (fromInteger (floor tod)))
next Minute (UTCTime d tod)
| u < 3599 = addTime 60 (UTCTime d (fromInteger (60*u)))
| otherwise = UTCTime (Cal.addDays 1 d) 0
where
u = floor tod `div` 60
next Hour (UTCTime d tod)
| u < 23 = addTime 3600 (UTCTime d (fromInteger (3600*u)))
| otherwise = UTCTime (Cal.addDays 1 d) 0
where
u = floor tod `div` 3600
next Day (UTCTime d _) = UTCTime (Cal.addDays 1 d) 0
skip n Second = addTime (fromInteger n)
skip n Minute = addTime (fromInteger n * 60)
skip n Hour = addTime (fromInteger n * 3600)
skip n Day = addTime (fromInteger n * 86400)
instance Time UTCTime where
type Delta UTCTime = NominalDiffTime
diffTime = diffUTCTime
addTime = addUTCTime
instance TimeSeconds UTCTime where
oneSecond _ = 1
instance (MonadIO m) => GetTime m ZonedTime where
getTime = liftIO getZonedTime
instance SkipDate ZonedTime where
dateBegin unit (ZonedTime (LocalTime d' tod) tz) =
ZonedTime (LocalTime d (TimeOfDay 0 0 0)) tz
where
d = case unit of
Week wd0 ->
let (_, _, wd) = Cal.toWeekDate d'
dd = mod (wd0 wd) 7
in Cal.addDays (if tod /= midnight && dd == 0 then 7 else toInteger dd) d'
Month ->
let (y, m, md) = Cal.toGregorian d'
d = Cal.fromGregorian y m 1
in if tod == midnight && md == 1 then d else Cal.addGregorianMonthsClip 1 d
Year ->
let (y, m, md) = Cal.toGregorian d'
d = Cal.fromGregorian y 1 1
in if tod == midnight && md == 1 && m == 1 then d else Cal.addGregorianYearsClip 1 d
dateNext unit (ZonedTime (LocalTime d' _) tz) =
ZonedTime (LocalTime d (TimeOfDay 0 0 0)) tz
where
d = case unit of
Week wd0 ->
let (_, _, wd) = Cal.toWeekDate d'
dd = mod (wd0 wd) 7
in Cal.addDays (if dd == 0 then 7 else toInteger dd) d'
Month ->
let (y, m, _) = Cal.toGregorian d'
d = Cal.fromGregorian y m 1
in Cal.addGregorianMonthsClip 1 d
Year ->
let (y, _, _) = Cal.toGregorian d'
d = Cal.fromGregorian y 1 1
in Cal.addGregorianYearsClip 1 d
dateSkip n unit (ZonedTime (LocalTime d' tod') tz) =
ZonedTime (LocalTime d tod) tz
where
tod | todSec tod' < 60 = tod'
| otherwise =
timeToTimeOfDay
(timeOfDayToTime tod' / 86401 * 86400)
d = case unit of
Week _ -> Cal.addDays (7*n) d'
Month -> Cal.addGregorianMonthsClip n d'
Year -> Cal.addGregorianYearsClip n d'
instance SkipUnit ZonedTime where
begin unit t@(ZonedTime (LocalTime _ (TimeOfDay h m s)) _) =
case unit of
Second | (_, 0) <- properFraction s -> t
Minute | s == 0 -> t
Hour | s == 0 && m == 0 -> t
Day | s == 0 && m == 0 && h == 0 -> t
_ -> next unit t
next unit t@(ZonedTime (LocalTime d (TimeOfDay h m s)) tz) =
case unit of
Second | s < 59 -> todRes (TimeOfDay h m (fromInteger (floor s + 1)))
| otherwise -> next Minute t
Minute | m < 59 -> todRes (TimeOfDay h (m + 1) 0)
| otherwise -> next Hour t
Hour | h < 23 -> todRes (TimeOfDay (h + 1) 0 0)
_ -> res (LocalTime (Cal.addDays 1 d) (TimeOfDay 0 0 0))
where
todRes = res . LocalTime d
res lt = ZonedTime lt tz
skip n unit lt =
utcToZonedTime
(zonedTimeZone lt)
(skip n unit (zonedTimeToUTC lt))
instance Time ZonedTime where
type Delta ZonedTime = NominalDiffTime
diffTime lt0 lt1 =
diffTime (zonedTimeToUTC lt0)
(zonedTimeToUTC lt1)
addTime dt lt =
utcToZonedTime
(zonedTimeZone lt)
(addTime dt (zonedTimeToUTC lt))
instance TimeSeconds ZonedTime where
oneSecond _ = 1