module Data.Thyme.Calendar
( Years, Months, Days
, Day (..)
, Year, Month, DayOfMonth
, YearMonthDay (..)
, isLeapYear
, module Data.Thyme.Calendar
) where
import Prelude hiding ((.))
import Control.Applicative
import Control.Category
import Control.Lens
import Data.Thyme.Calendar.Internal
import Data.Thyme.Calendar.MonthDay
import Data.Thyme.Format.Internal
import Data.Thyme.TH
yearMonthDay :: Iso' OrdinalDate YearMonthDay
yearMonthDay = iso fromOrdinal toOrdinal where
fromOrdinal :: OrdinalDate -> YearMonthDay
fromOrdinal (OrdinalDate y yd) = YearMonthDay y m d where
MonthDay m d = view (monthDay (isLeapYear y)) yd
toOrdinal :: YearMonthDay -> OrdinalDate
toOrdinal (YearMonthDay y m d) = OrdinalDate y $
review (monthDay (isLeapYear y)) (MonthDay m d)
gregorian :: Iso' Day YearMonthDay
gregorian = ordinalDate . yearMonthDay
gregorianValid :: YearMonthDay -> Maybe Day
gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y
<$> monthDayValid (isLeapYear y) (MonthDay m d)
showGregorian :: Day -> String
showGregorian (view gregorian -> YearMonthDay y m d) =
shows04 y . (:) '-' . shows02 m . (:) '-' . shows02 d $ ""
#if SHOW_INTERNAL
deriving instance Show Day
#else
instance Show Day where show = showGregorian
#endif
gregorianMonthLength :: Year -> Month -> Days
gregorianMonthLength = monthLength . isLeapYear
gregorianMonthsClip :: Months -> YearMonthDay -> YearMonthDay
gregorianMonthsClip n (YearMonthDay y m d) = YearMonthDay y' m'
$ min (gregorianMonthLength y' m') d where
((+) y -> y', (+) 1 -> m') = divMod (m + n 1) 12
gregorianMonthsRollover :: Months -> YearMonthDay -> YearMonthDay
gregorianMonthsRollover n (YearMonthDay y m d) = case d <= len of
True -> YearMonthDay y' m' d
False -> case m' < 12 of
True -> YearMonthDay y' (m' + 1) (d len)
False -> YearMonthDay (y' + 1) 1 (d len)
where
((+) y -> y', (+) 1 -> m') = divMod (m + n 1) 12
len = gregorianMonthLength y' m'
gregorianYearsClip :: Years -> YearMonthDay -> YearMonthDay
gregorianYearsClip n (YearMonthDay ((+) n -> y') 2 29)
| not (isLeapYear y') = YearMonthDay y' 2 28
gregorianYearsClip n (YearMonthDay y m d) = YearMonthDay (y + n) m d
gregorianYearsRollover :: Years -> YearMonthDay -> YearMonthDay
gregorianYearsRollover n (YearMonthDay ((+) n -> y') 2 29)
| not (isLeapYear y') = YearMonthDay y' 3 1
gregorianYearsRollover n (YearMonthDay y m d) = YearMonthDay (y + n) m d
thymeLenses ''Day
thymeLenses ''YearMonthDay