diff --git a/Data/Time/Lens.hs b/Data/Time/Lens.hs --- a/Data/Time/Lens.hs +++ b/Data/Time/Lens.hs @@ -1,20 +1,19 @@ module Data.Time.Lens ( -- * Time + -- $time HasTime(..) , hours , minutes , seconds -- * Date - , HasDay(..) + -- $date + , HasDate(..) , year , month - , dayOfMonth - , gregorianDay + , day + , gregorian -- * Time zone , HasTimeZone(..) - , tzMinutes - , tzSummerOnly - , tzName -- * Re-exports from "Data.Time" , T.Day , T.TimeOfDay @@ -24,15 +23,42 @@ -- * Re-exports from "Data.Lens.Common" , Lens , getL + , modL + , setL ) where import Control.Category import Prelude hiding ((.), id) import Data.Lens.Common -import Data.Fixed (Pico) +import Data.Fixed import qualified Data.Time as T +import Data.Time (TimeOfDay(..), LocalTime(..), fromGregorian) +-- $time +-- The semantics of 'getL' for time lenses ('time','hours','minutes','seconds') +-- is straightforward. +-- +-- The semantics of 'setL' is to «normalize» the time before setting. Hence +-- @'modL' 'minutes' (+5)@ will correctly add 5 minutes to the time, e.g. +-- +-- >>> modL minutes (+5) (TimeOfDay 16 57 13) +-- 17:02:13 +-- +-- If this means crossing a day boundary, the semantics varies for different +-- structures. For structures that have a date component (i.e. for instances of +-- 'HasDate') the date is adjusted appropriately. +-- +-- >>> modL hours (+10) (LocalTime (fromGregorian 2012 05 23) (TimeOfDay 16 57 13)) +-- 2012-05-24 02:57:13 +-- >>> modL seconds (subtract 1) (LocalTime (fromGregorian 2012 05 23) (TimeOfDay 0 0 0)) +-- 2012-05-22 23:59:59 +-- +-- If there's no date, the time is simply wrapped around. +-- +-- >>> modL seconds (subtract 1) (TimeOfDay 0 0 0) +-- 23:59:59 + class HasTime a where time :: Lens a T.TimeOfDay @@ -46,7 +72,7 @@ seconds = (lens T.todSec $ \x t -> t { T.todSec = x }) . time instance HasTime T.TimeOfDay where - time = iso id id + time = ntime $ iso id id localTimeOfZonedTime :: Lens T.ZonedTime T.LocalTime localTimeOfZonedTime = @@ -54,7 +80,8 @@ \x t -> t { T.zonedTimeToLocalTime = x } instance HasTime T.LocalTime where - time = lens T.localTimeOfDay $ \x t -> t { T.localTimeOfDay = x } + time = ntimeAdjustDay $ + lens T.localTimeOfDay $ \x t -> t { T.localTimeOfDay = x } instance HasTime T.ZonedTime where time = time . localTimeOfZonedTime @@ -62,47 +89,118 @@ instance HasTime T.UTCTime where time = time . iso (T.utcToLocalTime T.utc) (T.localTimeToUTC T.utc) -class HasDay a where - day :: Lens a T.Day +-- $date +-- In contrast to 'time', the 'date' lens is a simple accessor (it doesn't make +-- sense to «normalize» a 'T.Day'). +-- +-- Instead, setters for 'year', 'month' and 'day' have special semantics +-- described below. +-- Getters are always straightforward. -gregorianDay :: HasDay a => Lens a (Integer,Int,Int) -gregorianDay = iso T.toGregorian (uncurry3 T.fromGregorian) . day +class HasDate a where + date :: Lens a T.Day -year :: HasDay a => Lens a Integer -year = lens (\(y,_,_) -> y) (\y (_,m,d) -> (y,m,d)) . gregorianDay +-- | The semantics of 'gregorian' corresponds to that of 'T.toGregorian' and +-- 'T.fromGregorian' +gregorian :: HasDate a => Lens a (Integer,Int,Int) +gregorian = iso T.toGregorian (uncurry3 T.fromGregorian) . date -month :: HasDay a => Lens a Int -month = lens (\(_,m,_) -> m) (\m (y,_,d) -> (y,m,d)) . gregorianDay +-- | @'modL' 'year' (+n)@ adds @n@ years, matching month and day, with Feb 29th +-- rolled over to Mar 1st if necessary (like 'T.addGregorianYearsRollOver') +year :: HasDate a => Lens a Integer +year = lens getYear setYear . date + where + getYear date = + case T.toGregorian date of + (year,_,_) -> year + setYear year date = + case T.toGregorian date of + (origYear,_,_) -> T.addGregorianYearsRollOver (fromIntegral $ year - origYear) date -dayOfMonth :: HasDay a => Lens a Int -dayOfMonth = lens (\(_,_,d) -> d) (\d (y,m,_) -> (y,m,d)) . gregorianDay +-- | @'modL' 'month' (+n)@ adds @n@ months, with days past the last day of the +-- month rolling over to the next month (like 'T.addGregorianMonthsRollOver') +month :: HasDate a => Lens a Int +month = lens getMonth setMonth . date + where + getMonth date = + case T.toGregorian date of + (_,month,_) -> month + setMonth month date = + case T.toGregorian date of + (_,origMonth,_) -> T.addGregorianMonthsRollOver (fromIntegral $ month - origMonth) date +-- | @'modL' 'day' (+n)@ computes the date @n@ days after the original date +-- (like 'T.addDays') +day :: HasDate a => Lens a Int +day = lens getDay setDay . date + where + getDay date = + case T.toGregorian date of + (_,_,day) -> day + setDay day date = + case T.toGregorian date of + (_,_,origDay) -> T.addDays (fromIntegral $ day - origDay) date + uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c -instance HasDay T.Day where - day = iso id id +instance HasDate T.Day where + date = iso id id -instance HasDay T.LocalTime where - day = lens T.localDay (\d s -> s { T.localDay = d }) +instance HasDate T.LocalTime where + date = lens T.localDay (\d s -> s { T.localDay = d }) -instance HasDay T.ZonedTime where - day = day . localTimeOfZonedTime +instance HasDate T.ZonedTime where + date = date . localTimeOfZonedTime -instance HasDay T.UTCTime where - day = day . iso (T.utcToLocalTime T.utc) (T.localTimeToUTC T.utc) +instance HasDate T.UTCTime where + date = date . iso (T.utcToLocalTime T.utc) (T.localTimeToUTC T.utc) -class HasTimeZone a where +-- $zone +-- Getting 'timeZone' is straightforward. Setting 'TimeZone' changes both +-- 'timeZone' and 'time' (and 'date', if present) in such a way that the new +-- zoned time corresponds to the same UTC time as the original zoned time. + +class HasTime a => HasTimeZone a where timeZone :: Lens a T.TimeZone -tzMinutes :: HasTimeZone a => Lens a Int -tzMinutes = (lens T.timeZoneMinutes $ \x t -> t { T.timeZoneMinutes = x }) . timeZone +instance HasTimeZone T.ZonedTime where + timeZone = lens T.zonedTimeZone setTimeZone + where + setTimeZone z t = t { T.zonedTimeZone = z, T.zonedTimeToLocalTime = newTime } + where newTime = modL minutes (+ T.timeZoneMinutes z) $ T.zonedTimeToLocalTime t -tzSummerOnly :: HasTimeZone a => Lens a Bool -tzSummerOnly = (lens T.timeZoneSummerOnly $ \x t -> t { T.timeZoneSummerOnly = x }) . timeZone +-- +-- Auxiliary functions +-- -tzName :: HasTimeZone a => Lens a String -tzName = (lens T.timeZoneName $ \x t -> t { T.timeZoneName = x }) . timeZone +normalizeTime :: T.TimeOfDay -> (T.TimeOfDay, Integer) +normalizeTime = timeToTimeOfDay . timeOfDayToTime -instance HasTimeZone T.ZonedTime where - timeZone = lens T.zonedTimeZone $ \x t -> t { T.zonedTimeZone = x } +-- Can't rely on a HasTime instance here because this function will be used to +-- define one +ntime :: Lens a T.TimeOfDay -> Lens a T.TimeOfDay +ntime time = iso id (fst . normalizeTime) . time + +ntimeAdjustDay :: (HasDate a) => Lens a T.TimeOfDay -> Lens a T.TimeOfDay +ntimeAdjustDay time = lens (getL time) $ \t -> + case normalizeTime t of + (t', days) -> setL time t' . modL date (T.addDays days) + +-- We don't use T.timeToTimeOfDay and T.timeOfDayToTime here for the following +-- reasons: +-- * T.timeOfDayToTime could potentially perform bounds checking (although its +-- current implementation doesn't) +-- * T.timeToTimeOfDay converts excess time to leap seconds +timeOfDayToTime :: T.TimeOfDay -> T.DiffTime +timeOfDayToTime (T.TimeOfDay h m s) = ((fromIntegral h) * 60 + (fromIntegral m)) * 60 + (realToFrac s) + +timeToTimeOfDay :: T.DiffTime -> (T.TimeOfDay, Integer) +timeToTimeOfDay dt = (T.TimeOfDay (fromInteger h) (fromInteger m) s, d) where + s' = realToFrac dt + s = mod' s' 60 + m' = div' s' 60 + m = mod' m' 60 + h' = div' m' 60 + h = mod' h' 24 + d = div' h' 24 diff --git a/time-lens.cabal b/time-lens.cabal --- a/time-lens.cabal +++ b/time-lens.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: time-lens -version: 0.1 +version: 0.2 synopsis: Lens-based interface to Data.Time data structures -- description: license: BSD3