    {-|

    Manipulate the time periods typically used for reports with Period,
    a richer abstraction than DateSpan. See also Types and Dates.

    -}

    module Hledger.Data.Period
    where

    import Data.Time.Calendar
    import Data.Time.Calendar.MonthDay
    import Data.Time.Calendar.OrdinalDate
    import Data.Time.Calendar.WeekDate
    import Data.Time.Format
    import Text.Printf

    import Hledger.Data.Types

    -- | Convert Periods to DateSpans.
    --
    -- >>> periodAsDateSpan (MonthPeriod 2000 1) == DateSpan (Just $ fromGregorian 2000 1 1) (Just $ fromGregorian 2000 2 1)
    -- True
    periodAsDateSpan :: Period -> DateSpan
    periodAsDateSpan (DayPeriod d) = DateSpan (Just d) (Just $ addDays 1 d)
    periodAsDateSpan (WeekPeriod b) = DateSpan (Just b) (Just $ addDays 7 b)
    periodAsDateSpan (MonthPeriod y m) = DateSpan (Just $ fromGregorian y m 1) (Just $ fromGregorian y' m' 1)
      where
        (y',m') | m==12     = (y+1,1)
                | otherwise = (y,m+1)
    periodAsDateSpan (QuarterPeriod y q) = DateSpan (Just $ fromGregorian y m 1) (Just $ fromGregorian y' m' 1)
      where
        (y', q') | q==4      = (y+1,1)
                 | otherwise = (y,q+1)
        quarterAsMonth q = (q-1) * 3 + 1
        m  = quarterAsMonth q
        m' = quarterAsMonth q'
    periodAsDateSpan (YearPeriod y) = DateSpan (Just $ fromGregorian y 1 1) (Just $ fromGregorian (y+1) 1 1)
    periodAsDateSpan (PeriodBetween b e) = DateSpan (Just b) (Just e)
    periodAsDateSpan (PeriodFrom b) = DateSpan (Just b) Nothing
    periodAsDateSpan (PeriodTo e) = DateSpan Nothing (Just e)
    periodAsDateSpan (PeriodAll) = DateSpan Nothing Nothing

    -- | Convert DateSpans to Periods.
    --
    -- >>> dateSpanAsPeriod $ DateSpan (Just $ fromGregorian 2000 1 1) (Just $ fromGregorian 2000 2 1)
    -- MonthPeriod 2000 1
    dateSpanAsPeriod :: DateSpan -> Period
    dateSpanAsPeriod (DateSpan (Just b) (Just e)) = simplifyPeriod $ PeriodBetween b e
    dateSpanAsPeriod (DateSpan (Just b) Nothing) = PeriodFrom b
    dateSpanAsPeriod (DateSpan Nothing (Just e)) = PeriodTo e
    dateSpanAsPeriod (DateSpan Nothing Nothing) = PeriodAll

    -- | Convert PeriodBetweens to a more abstract period where possible.
    --
    -- >>> simplifyPeriod $ PeriodBetween (fromGregorian 1 1 1) (fromGregorian 2 1 1)
    -- YearPeriod 1
    -- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 10 1) (fromGregorian 2001 1 1)
    -- QuarterPeriod 2000 4
    -- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 1) (fromGregorian 2000 3 1)
    -- MonthPeriod 2000 2
    -- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2016 7 25) (fromGregorian 2016 8 1)
    -- WeekPeriod 2016-07-25
    -- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 1 1) (fromGregorian 2000 1 2)
    -- DayPeriod 2000-01-01
    -- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 28) (fromGregorian 2000 3 1)
    -- PeriodBetween 2000-02-28 2000-03-01
    -- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 2 29) (fromGregorian 2000 3 1)
    -- DayPeriod 2000-02-29
    -- >>> simplifyPeriod $ PeriodBetween (fromGregorian 2000 12 31) (fromGregorian 2001 1 1)
    -- DayPeriod 2000-12-31
    --
    simplifyPeriod :: Period -> Period
    simplifyPeriod (PeriodBetween b e) =
      case (toGregorian b, toGregorian e) of
        -- a year
        ((by,1,1), (ey,1,1))   | by+1==ey           -> YearPeriod by
        -- a half-year
        -- ((by,1,1), (ey,7,1))   | by==ey             ->
        -- ((by,7,1), (ey,1,1))   | by+1==ey           ->
        -- a quarter
        ((by,1,1), (ey,4,1))   | by==ey             -> QuarterPeriod by 1
        ((by,4,1), (ey,7,1))   | by==ey             -> QuarterPeriod by 2
        ((by,7,1), (ey,10,1))  | by==ey             -> QuarterPeriod by 3
        ((by,10,1), (ey,1,1))  | by+1==ey           -> QuarterPeriod by 4
        -- a month
        ((by,bm,1), (ey,em,1)) | by==ey && bm+1==em -> MonthPeriod by bm
        ((by,12,1), (ey,1,1))  | by+1==ey           -> MonthPeriod by 12
        -- a week (two successive mondays),
        -- YYYYwN ("week N of year YYYY")
        -- _ | let ((by,bw,bd), (ey,ew,ed)) = (toWeekDate from, toWeekDate to) in by==ey && fw+1==tw && bd==1 && ed==1 ->
        -- a week starting on a monday
        _ | let ((by,bw,bd), (ey,ew,ed)) = (toWeekDate b, toWeekDate (addDays (-1) e))
            in by==ey && bw==ew && bd==1 && ed==7   -> WeekPeriod b
        -- a day
        ((by,bm,bd), (ey,em,ed)) |
            (by==ey && bm==em && bd+1==ed) ||
            (by+1==ey && bm==12 && em==1 && bd==31 && ed==1) || -- crossing a year boundary
            (by==ey && bm+1==em && isLastDayOfMonth by bm bd && ed==1) -- crossing a month boundary
             -> DayPeriod b
        _ -> PeriodBetween b e
    simplifyPeriod p = p

    isLastDayOfMonth y m d =
      case m of
        1 -> d==31
        2 | isLeapYear y -> d==29
          | otherwise    -> d==28
        3 -> d==31
        4 -> d==30
        5 -> d==31
        6 -> d==30
        7 -> d==31
        8 -> d==31
        9 -> d==30
        10 -> d==31
        11 -> d==30
        12 -> d==31
        _ -> False

    -- | Is this period a "standard" period, referencing a particular day, week, month, quarter, or year ?
    -- Periods of other durations, or infinite duration, or not starting on a standard period boundary, are not.
    isStandardPeriod = isStandardPeriod' . simplifyPeriod
      where
        isStandardPeriod' (DayPeriod _) = True
        isStandardPeriod' (WeekPeriod _) = True
        isStandardPeriod' (MonthPeriod _ _) = True
        isStandardPeriod' (QuarterPeriod _ _) = True
        isStandardPeriod' (YearPeriod _) = True
        isStandardPeriod' _ = False

    -- | Render a period as a compact display string suitable for user output.
    --
    -- >>> showPeriod (WeekPeriod (fromGregorian 2016 7 25))
    -- "2016/07/25w30"
    showPeriod (DayPeriod b)       = formatTime defaultTimeLocale "%0C%y/%m/%d" b     -- DATE
    showPeriod (WeekPeriod b)      = formatTime defaultTimeLocale "%0C%y/%m/%dw%V" b  -- STARTDATEwYEARWEEK
    showPeriod (MonthPeriod y m)   = printf "%04d/%02d" y m                           -- YYYY/MM
    showPeriod (QuarterPeriod y q) = printf "%04dq%d" y q                             -- YYYYqN
    showPeriod (YearPeriod y)      = printf "%04d" y                                  -- YYYY
    showPeriod (PeriodBetween b e) = formatTime defaultTimeLocale "%0C%y/%m/%d" b
                                     ++ formatTime defaultTimeLocale "-%0C%y/%m/%d" (addDays (-1) e) -- STARTDATE-INCLUSIVEENDDATE
    showPeriod (PeriodFrom b)      = formatTime defaultTimeLocale "%0C%y/%m/%d-" b                   -- STARTDATE-
    showPeriod (PeriodTo e)        = formatTime defaultTimeLocale "-%0C%y/%m/%d" (addDays (-1) e)    -- -INCLUSIVEENDDATE
    showPeriod PeriodAll           = "-"

    periodStart :: Period -> Maybe Day
    periodStart p = mb
      where
        DateSpan mb _ = periodAsDateSpan p

    periodEnd :: Period -> Maybe Day
    periodEnd p = me
      where
        DateSpan _ me = periodAsDateSpan p

    -- | Move a standard period to the following period of same duration.
    -- Non-standard periods are unaffected.
    periodNext :: Period -> Period
    periodNext (DayPeriod b) = DayPeriod (addDays 1 b)
    periodNext (WeekPeriod b) = WeekPeriod (addDays 7 b)
    periodNext (MonthPeriod y 12) = MonthPeriod (y+1) 1
    periodNext (MonthPeriod y m) = MonthPeriod y (m+1)
    periodNext (QuarterPeriod y 4) = QuarterPeriod (y+1) 1
    periodNext (QuarterPeriod y q) = QuarterPeriod y (q+1)
    periodNext (YearPeriod y) = YearPeriod (y+1)
    periodNext p = p

    -- | Move a standard period to the preceding period of same duration.
    -- Non-standard periods are unaffected.
    periodPrevious :: Period -> Period
    periodPrevious (DayPeriod b) = DayPeriod (addDays (-1) b)
    periodPrevious (WeekPeriod b) = WeekPeriod (addDays (-7) b)
    periodPrevious (MonthPeriod y 1) = MonthPeriod (y-1) 12
    periodPrevious (MonthPeriod y m) = MonthPeriod y (m-1)
    periodPrevious (QuarterPeriod y 1) = QuarterPeriod (y-1) 4
    periodPrevious (QuarterPeriod y q) = QuarterPeriod y (q-1)
    periodPrevious (YearPeriod y) = YearPeriod (y-1)
    periodPrevious p = p

    -- | Move a standard period to the following period of same duration, staying within enclosing dates.
    -- Non-standard periods are unaffected.
    periodNextIn :: DateSpan -> Period -> Period
    periodNextIn (DateSpan _ (Just e)) p =
      case mb of
        Just b -> if b < e then p' else p
        _      -> p
      where
        p' = periodNext p
        mb = periodStart p'
    periodNextIn _ p = periodNext p

    -- | Move a standard period to the preceding period of same duration, staying within enclosing dates.
    -- Non-standard periods are unaffected.
    periodPreviousIn :: DateSpan -> Period -> Period
    periodPreviousIn (DateSpan (Just b) _) p =
      case me of
        Just e -> if e > b then p' else p
        _      -> p
      where
        p' = periodPrevious p
        me = periodEnd p'
    periodPreviousIn _ p = periodPrevious p

    -- | Move a standard period stepwise so that it encloses the given date.
    -- Non-standard periods are unaffected.
    periodMoveTo :: Day -> Period -> Period
    periodMoveTo d (DayPeriod _) = DayPeriod d
    periodMoveTo d (WeekPeriod _) = WeekPeriod $ mondayBefore d
    periodMoveTo d (MonthPeriod _ _) = MonthPeriod y m where (y,m,_) = toGregorian d
    periodMoveTo d (QuarterPeriod _ _) = QuarterPeriod y q
      where
        (y,m,_) = toGregorian d
        q = quarterContainingMonth m
    periodMoveTo d (YearPeriod _) = YearPeriod y where (y,_,_) = toGregorian d
    periodMoveTo _ p = p

    -- | Enlarge a standard period to the next larger enclosing standard period, if there is one.
    -- Eg, a day becomes the enclosing week.
    -- A week becomes whichever month the week's thursday falls into.
    -- A year becomes all (unlimited).
    -- Non-standard periods (arbitrary dates, or open-ended) are unaffected.
    periodGrow :: Period -> Period
    periodGrow (DayPeriod b) = WeekPeriod $ mondayBefore b
    periodGrow (WeekPeriod b) = MonthPeriod y m
      where (y,m) = yearMonthContainingWeekStarting b
    periodGrow (MonthPeriod y m) = QuarterPeriod y (quarterContainingMonth m)
    periodGrow (QuarterPeriod y _) = YearPeriod y
    periodGrow (YearPeriod _) = PeriodAll
    periodGrow p = p

    -- | Shrink a period to the next smaller standard period inside it,
    -- choosing the subperiod which contains today's date if possible,
    -- otherwise the first subperiod. It goes like this:
    -- unbounded periods and nonstandard periods (between two arbitrary dates) ->
    -- current year ->
    -- current quarter if it's in selected year, otherwise first quarter of selected year ->
    -- current month if it's in selected quarter, otherwise first month of selected quarter ->
    -- current week if it's in selected month, otherwise first week of selected month ->
    -- today if it's in selected week, otherwise first day of selected week,
    --  unless that's in previous month, in which case first day of month containing selected week.
    -- Shrinking a day has no effect.
    periodShrink :: Day -> Period -> Period
    periodShrink _     p@(DayPeriod _) = p
    periodShrink today (WeekPeriod b)
      | today >= b && diffDays today b < 7 = DayPeriod today
      | m /= weekmonth                     = DayPeriod $ fromGregorian weekyear weekmonth 1
      | otherwise                          = DayPeriod b
      where
        (_,m,_) = toGregorian b
        (weekyear,weekmonth) = yearMonthContainingWeekStarting b
    periodShrink today (MonthPeriod y m)
      | (y',m') == (y,m) = WeekPeriod $ mondayBefore today
      | otherwise        = WeekPeriod $ startOfFirstWeekInMonth y m
      where (y',m',_) = toGregorian today
    periodShrink today (QuarterPeriod y q)
      | quarterContainingMonth thismonth == q = MonthPeriod y thismonth
      | otherwise                             = MonthPeriod y (firstMonthOfQuarter q)
      where (_,thismonth,_) = toGregorian today
    periodShrink today (YearPeriod y)
      | y == thisyear = QuarterPeriod y thisquarter
      | otherwise     = QuarterPeriod y 1
      where
        (thisyear,thismonth,_) = toGregorian today
        thisquarter = quarterContainingMonth thismonth
    periodShrink today _ = YearPeriod y
      where (y,_,_) = toGregorian today

    mondayBefore d = addDays (fromIntegral (1 - wd)) d
      where
        (_,_,wd) = toWeekDate d

    yearMonthContainingWeekStarting weekstart = (y,m)
      where
        thu = addDays 3 weekstart
        (y,yd) = toOrdinalDate thu
        (m,_) = dayOfYearToMonthAndDay (isLeapYear y) yd

    quarterContainingMonth m = (m-1) `div` 3 + 1

    firstMonthOfQuarter q = (q-1)*3 + 1

    startOfFirstWeekInMonth y m
      | monthstartday <= 4 = mon
      | otherwise          = addDays 7 mon  -- month starts with a fri/sat/sun
      where
        monthstart = fromGregorian y m 1
        mon = mondayBefore monthstart
        (_,_,monthstartday) = toWeekDate monthstart