time-lens 0.1 → 0.2
raw patch · 2 files changed
+135/−37 lines, 2 files
Files
- Data/Time/Lens.hs +134/−36
- time-lens.cabal +1/−1
Data/Time/Lens.hs view
@@ -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
time-lens.cabal view
@@ -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