module Data.Time.Calendar.Lens
( modifiedJulianDay
, TraverseDay(..)
, HasYear(..)
, HasMonth(..)
, HasWeek(..)
, HasDay(..)
, Gregorian(..)
, gregorian
, JulianYearAndDay(..)
, julianYearAndDay
, WeekDate(..)
, weekDate
, OrdinalDate(..)
, ordinalDate
) where
import Control.Applicative
import Control.Lens
import Data.Data
import Data.Time.Calendar
import Data.Time.Calendar.Julian
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.OrdinalDate
class TraverseDay t where
traverseDay :: Simple Traversal t Day
modifiedJulianDay :: Simple Iso Day Integer
modifiedJulianDay = iso toModifiedJulianDay ModifiedJulianDay
instance TraverseDay Day where
traverseDay = id
class HasYear t where
year :: Simple Lens t Integer
class HasMonth t where
month :: Simple Lens t Int
class HasWeek t where
week :: Simple Lens t Int
class HasDay t where
day :: Simple Lens t Int
data Gregorian = Gregorian
{ gregorianYear :: !Integer
, gregorianMonth :: !Int
, gregorianDay :: !Int
} deriving (Eq,Ord,Show,Read,Typeable,Data)
uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
uncurry3 f (a,b,c) = f a b c
gregorian :: Simple Iso Day Gregorian
gregorian = iso (uncurry3 Gregorian . toGregorian) $ \(Gregorian y m d) -> fromGregorian y m d
instance TraverseDay Gregorian where
traverseDay f g@(Gregorian y m d) = case fromGregorianValid y m d of
Nothing -> pure g
Just j -> (\i -> case toGregorian i of (y', m', d') -> Gregorian y' m' d') <$> f j
instance HasYear Gregorian where
year f (Gregorian y m d) = (\y' -> Gregorian y' m d) <$> f y
instance HasMonth Gregorian where
month f (Gregorian y m d) = (\m' -> Gregorian y m' d) <$> f m
instance HasDay Gregorian where
day f (Gregorian y m d) = Gregorian y m <$> f d
data JulianYearAndDay = JulianYearAndDay
{ julianYearAndDayYear :: !Integer
, julianYearAndDayDay :: !Int
} deriving (Eq,Ord,Show,Read,Typeable,Data)
julianYearAndDay :: Simple Iso Day JulianYearAndDay
julianYearAndDay = iso (uncurry JulianYearAndDay . toJulianYearAndDay) $ \(JulianYearAndDay y d) -> fromJulianYearAndDay y d
instance TraverseDay JulianYearAndDay where
traverseDay f j@(JulianYearAndDay y d) = case fromJulianYearAndDayValid y d of
Nothing -> pure j
Just k -> (\i -> case toJulianYearAndDay i of (y', d') -> JulianYearAndDay y' d') <$> f k
instance HasYear JulianYearAndDay where
year f (JulianYearAndDay y d) = (`JulianYearAndDay` d) <$> f y
instance HasDay JulianYearAndDay where
day f (JulianYearAndDay y d) = JulianYearAndDay y <$> f d
data WeekDate = WeekDate
{ weekDateYear :: !Integer
, weekDateWeek :: !Int
, weekDateDay :: !Int
} deriving (Eq,Ord,Show,Read,Typeable,Data)
weekDate :: Simple Iso Day WeekDate
weekDate = iso (uncurry3 WeekDate . toWeekDate) $ \(WeekDate y w d) -> fromWeekDate y w d
instance TraverseDay WeekDate where
traverseDay f wd@(WeekDate y w d) = case fromWeekDateValid y w d of
Nothing -> pure wd
Just k -> (\i -> case toWeekDate i of (y', w', d') -> WeekDate y' w' d') <$> f k
instance HasYear WeekDate where
year f (WeekDate y w d) = (\y' -> WeekDate y' w d) <$> f y
instance HasWeek WeekDate where
week f (WeekDate y w d) = (\w' -> WeekDate y w' d) <$> f w
instance HasDay WeekDate where
day f (WeekDate y w d) = WeekDate y w <$> f d
data OrdinalDate = OrdinalDate
{ ordinalDateYear :: !Integer
, ordinalDateDay :: !Int
} deriving (Eq,Ord,Show,Read,Typeable,Data)
ordinalDate :: Simple Iso Day OrdinalDate
ordinalDate = iso (uncurry OrdinalDate . toOrdinalDate) $ \(OrdinalDate y d) -> fromOrdinalDate y d
instance TraverseDay OrdinalDate where
traverseDay f od@(OrdinalDate y d) = case fromOrdinalDateValid y d of
Nothing -> pure od
Just k -> (\i -> case toOrdinalDate i of (y', d') -> OrdinalDate y' d') <$> f k
instance HasYear OrdinalDate where
year f (OrdinalDate y d) = (`OrdinalDate` d) <$> f y
instance HasDay OrdinalDate where
day f (OrdinalDate y d) = OrdinalDate y <$> f d