lib/Data/Time/Calendar/MonthDay.hs

    {-# LANGUAGE Safe #-}

    module Data.Time.Calendar.MonthDay
        ( MonthOfYear, DayOfMonth, DayOfYear
        , monthAndDayToDayOfYear
        , monthAndDayToDayOfYearValid
        , dayOfYearToMonthAndDay
        , monthLength
        ) where

    import Data.Time.Calendar.Types
    import Data.Time.Calendar.Private

    -- | Convert month and day in the Gregorian or Julian calendars to day of year.
    -- First arg is leap year flag.
    monthAndDayToDayOfYear :: Bool -> MonthOfYear -> DayOfMonth -> DayOfYear
    monthAndDayToDayOfYear isLeap month day = (div (367 * month'' - 362) 12) + k + day'
      where
        month' = clip 1 12 month
        day' = fromIntegral (clip 1 (monthLength' isLeap month') day)
        month'' = fromIntegral month'
        k =
            if month' <= 2
                then 0
                else if isLeap
                         then -1
                         else -2

    -- | Convert month and day in the Gregorian or Julian calendars to day of year.
    -- First arg is leap year flag.
    monthAndDayToDayOfYearValid :: Bool -> MonthOfYear -> DayOfMonth -> Maybe DayOfYear
    monthAndDayToDayOfYearValid isLeap month day = do
        month' <- clipValid 1 12 month
        day' <- clipValid 1 (monthLength' isLeap month') day
        let
            day'' = fromIntegral day'
            month'' = fromIntegral month'
            k =
                if month' <= 2
                    then 0
                    else if isLeap
                             then -1
                             else -2
        return ((div (367 * month'' - 362) 12) + k + day'')

    -- | Convert day of year in the Gregorian or Julian calendars to month and day.
    -- First arg is leap year flag.
    dayOfYearToMonthAndDay :: Bool -> DayOfYear -> (MonthOfYear, DayOfMonth)
    dayOfYearToMonthAndDay isLeap yd =
        findMonthDay
            (monthLengths isLeap)
            (clip
                 1
                 (if isLeap
                      then 366
                      else 365)
                 yd)

    findMonthDay :: [Int] -> Int -> (Int, Int)
    findMonthDay (n:ns) yd
        | yd > n = (\(m, d) -> (m + 1, d)) (findMonthDay ns (yd - n))
    findMonthDay _ yd = (1, yd)

    -- | The length of a given month in the Gregorian or Julian calendars.
    -- First arg is leap year flag.
    monthLength :: Bool -> MonthOfYear -> DayOfMonth
    monthLength isLeap month' = monthLength' isLeap (clip 1 12 month')

    monthLength' :: Bool -> MonthOfYear -> DayOfMonth
    monthLength' isLeap month' = (monthLengths isLeap) !! (month' - 1)

    monthLengths :: Bool -> [DayOfMonth]
    monthLengths isleap =
        [ 31
        , if isleap
              then 29
              else 28
        , 31
        , 30
        , 31
        , 30
        , 31
        , 31
        , 30
        , 31
        , 30
        , 31
        ]
        --J        F                   M  A  M  J  J  A  S  O  N  D