{-|

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

-}

module Hledger.Data.Period (
   periodAsDateSpan
  ,dateSpanAsPeriod
  ,simplifyPeriod
  ,isLastDayOfMonth
  ,isStandardPeriod
  ,showPeriod
  ,showPeriodMonthAbbrev
  ,periodStart
  ,periodEnd
  ,periodNext
  ,periodPrevious
  ,periodNextIn
  ,periodPreviousIn
  ,periodMoveTo
  ,periodGrow
  ,periodShrink
  ,mondayBefore
  ,yearMonthContainingWeekStarting
  ,quarterContainingMonth
  ,firstMonthOfQuarter
  ,startOfFirstWeekInMonth
)
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 :: Period -> DateSpan
periodAsDateSpan (DayPeriod Day
d) = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
d) (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
d)
periodAsDateSpan (WeekPeriod Day
b) = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
b) (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
7 Day
b)
periodAsDateSpan (MonthPeriod Integer
y Month
m) = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Integer -> Month -> Month -> Day
fromGregorian Integer
y Month
m Month
1) (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Integer -> Month -> Month -> Day
fromGregorian Integer
y' Month
m' Month
1)
  where
    (Integer
y',Month
m') | Month
mMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
12     = (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1,Month
1)
            | Bool
otherwise = (Integer
y,Month
mMonth -> Month -> Month
forall a. Num a => a -> a -> a
+Month
1)
periodAsDateSpan (QuarterPeriod Integer
y Month
q) = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Integer -> Month -> Month -> Day
fromGregorian Integer
y Month
m Month
1) (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Integer -> Month -> Month -> Day
fromGregorian Integer
y' Month
m' Month
1)
  where
    (Integer
y', Month
q') | Month
qMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
4      = (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1,Month
1)
             | Bool
otherwise = (Integer
y,Month
qMonth -> Month -> Month
forall a. Num a => a -> a -> a
+Month
1)
    quarterAsMonth :: a -> a
quarterAsMonth a
q = (a
qa -> a -> a
forall a. Num a => a -> a -> a
-a
1) a -> a -> a
forall a. Num a => a -> a -> a
* a
3 a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
    m :: Month
m  = Month -> Month
forall a. Num a => a -> a
quarterAsMonth Month
q
    m' :: Month
m' = Month -> Month
forall a. Num a => a -> a
quarterAsMonth Month
q'
periodAsDateSpan (YearPeriod Integer
y) = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Integer -> Month -> Month -> Day
fromGregorian Integer
y Month
1 Month
1) (Day -> Maybe Day
forall a. a -> Maybe a
Just (Day -> Maybe Day) -> Day -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Integer -> Month -> Month -> Day
fromGregorian (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Month
1 Month
1)
periodAsDateSpan (PeriodBetween Day
b Day
e) = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
b) (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
e)
periodAsDateSpan (PeriodFrom Day
b) = Maybe Day -> Maybe Day -> DateSpan
DateSpan (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
b) Maybe Day
forall a. Maybe a
Nothing
periodAsDateSpan (PeriodTo Day
e) = Maybe Day -> Maybe Day -> DateSpan
DateSpan Maybe Day
forall a. Maybe a
Nothing (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
e)
periodAsDateSpan (Period
PeriodAll) = Maybe Day -> Maybe Day -> DateSpan
DateSpan Maybe Day
forall a. Maybe a
Nothing Maybe Day
forall a. Maybe a
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 -> Period
dateSpanAsPeriod (DateSpan (Just Day
b) (Just Day
e)) = Period -> Period
simplifyPeriod (Period -> Period) -> Period -> Period
forall a b. (a -> b) -> a -> b
$ Day -> Day -> Period
PeriodBetween Day
b Day
e
dateSpanAsPeriod (DateSpan (Just Day
b) Maybe Day
Nothing) = Day -> Period
PeriodFrom Day
b
dateSpanAsPeriod (DateSpan Maybe Day
Nothing (Just Day
e)) = Day -> Period
PeriodTo Day
e
dateSpanAsPeriod (DateSpan Maybe Day
Nothing Maybe Day
Nothing) = Period
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 :: Period -> Period
simplifyPeriod (PeriodBetween Day
b Day
e) =
  case (Day -> (Integer, Month, Month)
toGregorian Day
b, Day -> (Integer, Month, Month)
toGregorian Day
e) of
    -- a year
    ((Integer
by,Month
1,Month
1), (Integer
ey,Month
1,Month
1))   | Integer
byInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey           -> Integer -> Period
YearPeriod Integer
by
    -- a half-year
    -- ((by,1,1), (ey,7,1))   | by==ey             ->
    -- ((by,7,1), (ey,1,1))   | by+1==ey           ->
    -- a quarter
    ((Integer
by,Month
1,Month
1), (Integer
ey,Month
4,Month
1))   | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey             -> Integer -> Month -> Period
QuarterPeriod Integer
by Month
1
    ((Integer
by,Month
4,Month
1), (Integer
ey,Month
7,Month
1))   | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey             -> Integer -> Month -> Period
QuarterPeriod Integer
by Month
2
    ((Integer
by,Month
7,Month
1), (Integer
ey,Month
10,Month
1))  | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey             -> Integer -> Month -> Period
QuarterPeriod Integer
by Month
3
    ((Integer
by,Month
10,Month
1), (Integer
ey,Month
1,Month
1))  | Integer
byInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey           -> Integer -> Month -> Period
QuarterPeriod Integer
by Month
4
    -- a month
    ((Integer
by,Month
bm,Month
1), (Integer
ey,Month
em,Month
1)) | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey Bool -> Bool -> Bool
&& Month
bmMonth -> Month -> Month
forall a. Num a => a -> a -> a
+Month
1Month -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
em -> Integer -> Month -> Period
MonthPeriod Integer
by Month
bm
    ((Integer
by,Month
12,Month
1), (Integer
ey,Month
1,Month
1))  | Integer
byInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey           -> Integer -> Month -> Period
MonthPeriod Integer
by Month
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
    ((Integer, Month, Month), (Integer, Month, Month))
_ | let ((Integer
by,Month
bw,Month
bd), (Integer
ey,Month
ew,Month
ed)) = (Day -> (Integer, Month, Month)
toWeekDate Day
b, Day -> (Integer, Month, Month)
toWeekDate (Integer -> Day -> Day
addDays (-Integer
1) Day
e))
        in Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey Bool -> Bool -> Bool
&& Month
bwMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
ew Bool -> Bool -> Bool
&& Month
bdMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
1 Bool -> Bool -> Bool
&& Month
edMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
7   -> Day -> Period
WeekPeriod Day
b
    -- a day
    ((Integer
by,Month
bm,Month
bd), (Integer
ey,Month
em,Month
ed)) |
        (Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey Bool -> Bool -> Bool
&& Month
bmMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
em Bool -> Bool -> Bool
&& Month
bdMonth -> Month -> Month
forall a. Num a => a -> a -> a
+Month
1Month -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
ed) Bool -> Bool -> Bool
||
        (Integer
byInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey Bool -> Bool -> Bool
&& Month
bmMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
12 Bool -> Bool -> Bool
&& Month
emMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
1 Bool -> Bool -> Bool
&& Month
bdMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
31 Bool -> Bool -> Bool
&& Month
edMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
1) Bool -> Bool -> Bool
|| -- crossing a year boundary
        (Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey Bool -> Bool -> Bool
&& Month
bmMonth -> Month -> Month
forall a. Num a => a -> a -> a
+Month
1Month -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
em Bool -> Bool -> Bool
&& Integer -> Month -> Month -> Bool
forall a a. (Eq a, Eq a, Num a, Num a) => Integer -> a -> a -> Bool
isLastDayOfMonth Integer
by Month
bm Month
bd Bool -> Bool -> Bool
&& Month
edMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
1) -- crossing a month boundary
         -> Day -> Period
DayPeriod Day
b
    ((Integer, Month, Month), (Integer, Month, Month))
_ -> Day -> Day -> Period
PeriodBetween Day
b Day
e
simplifyPeriod Period
p = Period
p

isLastDayOfMonth :: Integer -> a -> a -> Bool
isLastDayOfMonth Integer
y a
m a
d =
  case a
m of
    a
1 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
31
    a
2 | Integer -> Bool
isLeapYear Integer
y -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
29
      | Bool
otherwise    -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
28
    a
3 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
31
    a
4 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
30
    a
5 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
31
    a
6 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
30
    a
7 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
31
    a
8 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
31
    a
9 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
30
    a
10 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
31
    a
11 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
30
    a
12 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
31
    a
_ -> Bool
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 :: Period -> Bool
isStandardPeriod = Period -> Bool
isStandardPeriod' (Period -> Bool) -> (Period -> Period) -> Period -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Period -> Period
simplifyPeriod
  where
    isStandardPeriod' :: Period -> Bool
isStandardPeriod' (DayPeriod Day
_) = Bool
True
    isStandardPeriod' (WeekPeriod Day
_) = Bool
True
    isStandardPeriod' (MonthPeriod Integer
_ Month
_) = Bool
True
    isStandardPeriod' (QuarterPeriod Integer
_ Month
_) = Bool
True
    isStandardPeriod' (YearPeriod Integer
_) = Bool
True
    isStandardPeriod' Period
_ = Bool
False

-- | Render a period as a compact display string suitable for user output.
--
-- >>> showPeriod (WeekPeriod (fromGregorian 2016 7 25))
-- "2016-07-25W30"
showPeriod :: Period -> String
showPeriod (DayPeriod Day
b)       = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F" Day
b              -- DATE
showPeriod (WeekPeriod Day
b)      = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%FW%V" Day
b           -- STARTDATEWYEARWEEK
showPeriod (MonthPeriod Integer
y Month
m)   = String -> Integer -> Month -> String
forall r. PrintfType r => String -> r
printf String
"%04d-%02d" Integer
y Month
m                           -- YYYY-MM
showPeriod (QuarterPeriod Integer
y Month
q) = String -> Integer -> Month -> String
forall r. PrintfType r => String -> r
printf String
"%04dQ%d" Integer
y Month
q                             -- YYYYQN
showPeriod (YearPeriod Integer
y)      = String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%04d" Integer
y                                  -- YYYY
showPeriod (PeriodBetween Day
b Day
e) = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F" Day
b
                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"..%F" (Integer -> Day -> Day
addDays (-Integer
1) Day
e) -- STARTDATE..INCLUSIVEENDDATE
showPeriod (PeriodFrom Day
b)      = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F.." Day
b                   -- STARTDATE..
showPeriod (PeriodTo Day
e)        = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"..%F" (Integer -> Day -> Day
addDays (-Integer
1) Day
e)    -- ..INCLUSIVEENDDATE
showPeriod Period
PeriodAll           = String
".."

-- | Like showPeriod, but if it's a month period show just
-- the 3 letter month name abbreviation for the current locale.
showPeriodMonthAbbrev :: Period -> String
showPeriodMonthAbbrev (MonthPeriod Integer
_ Month
m)                           -- Jan
  | Month
m Month -> Month -> Bool
forall a. Ord a => a -> a -> Bool
> Month
0 Bool -> Bool -> Bool
&& Month
m Month -> Month -> Bool
forall a. Ord a => a -> a -> Bool
<= [(String, String)] -> Month
forall (t :: * -> *) a. Foldable t => t a -> Month
length [(String, String)]
monthnames = (String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> String) -> (String, String) -> String
forall a b. (a -> b) -> a -> b
$ [(String, String)]
monthnames [(String, String)] -> Month -> (String, String)
forall a. [a] -> Month -> a
!! (Month
mMonth -> Month -> Month
forall a. Num a => a -> a -> a
-Month
1)
  where monthnames :: [(String, String)]
monthnames = TimeLocale -> [(String, String)]
months TimeLocale
defaultTimeLocale
showPeriodMonthAbbrev Period
p = Period -> String
showPeriod Period
p

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

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

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

-- | Move a standard period to the preceding period of same duration.
-- Non-standard periods are unaffected.
periodPrevious :: Period -> Period
periodPrevious :: Period -> Period
periodPrevious (DayPeriod Day
b) = Day -> Period
DayPeriod (Integer -> Day -> Day
addDays (-Integer
1) Day
b)
periodPrevious (WeekPeriod Day
b) = Day -> Period
WeekPeriod (Integer -> Day -> Day
addDays (-Integer
7) Day
b)
periodPrevious (MonthPeriod Integer
y Month
1) = Integer -> Month -> Period
MonthPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) Month
12
periodPrevious (MonthPeriod Integer
y Month
m) = Integer -> Month -> Period
MonthPeriod Integer
y (Month
mMonth -> Month -> Month
forall a. Num a => a -> a -> a
-Month
1)
periodPrevious (QuarterPeriod Integer
y Month
1) = Integer -> Month -> Period
QuarterPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) Month
4
periodPrevious (QuarterPeriod Integer
y Month
q) = Integer -> Month -> Period
QuarterPeriod Integer
y (Month
qMonth -> Month -> Month
forall a. Num a => a -> a -> a
-Month
1)
periodPrevious (YearPeriod Integer
y) = Integer -> Period
YearPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)
periodPrevious Period
p = Period
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 -> Period -> Period
periodNextIn (DateSpan Maybe Day
_ (Just Day
e)) Period
p =
  case Maybe Day
mb of
    Just Day
b -> if Day
b Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
< Day
e then Period
p' else Period
p
    Maybe Day
_      -> Period
p
  where
    p' :: Period
p' = Period -> Period
periodNext Period
p
    mb :: Maybe Day
mb = Period -> Maybe Day
periodStart Period
p'
periodNextIn DateSpan
_ Period
p = Period -> Period
periodNext Period
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 -> Period -> Period
periodPreviousIn (DateSpan (Just Day
b) Maybe Day
_) Period
p =
  case Maybe Day
me of
    Just Day
e -> if Day
e Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
> Day
b then Period
p' else Period
p
    Maybe Day
_      -> Period
p
  where
    p' :: Period
p' = Period -> Period
periodPrevious Period
p
    me :: Maybe Day
me = Period -> Maybe Day
periodEnd Period
p'
periodPreviousIn DateSpan
_ Period
p = Period -> Period
periodPrevious Period
p

-- | Move a standard period stepwise so that it encloses the given date.
-- Non-standard periods are unaffected.
periodMoveTo :: Day -> Period -> Period
periodMoveTo :: Day -> Period -> Period
periodMoveTo Day
d (DayPeriod Day
_) = Day -> Period
DayPeriod Day
d
periodMoveTo Day
d (WeekPeriod Day
_) = Day -> Period
WeekPeriod (Day -> Period) -> Day -> Period
forall a b. (a -> b) -> a -> b
$ Day -> Day
mondayBefore Day
d
periodMoveTo Day
d (MonthPeriod Integer
_ Month
_) = Integer -> Month -> Period
MonthPeriod Integer
y Month
m where (Integer
y,Month
m,Month
_) = Day -> (Integer, Month, Month)
toGregorian Day
d
periodMoveTo Day
d (QuarterPeriod Integer
_ Month
_) = Integer -> Month -> Period
QuarterPeriod Integer
y Month
q
  where
    (Integer
y,Month
m,Month
_) = Day -> (Integer, Month, Month)
toGregorian Day
d
    q :: Month
q = Month -> Month
forall a. Integral a => a -> a
quarterContainingMonth Month
m
periodMoveTo Day
d (YearPeriod Integer
_) = Integer -> Period
YearPeriod Integer
y where (Integer
y,Month
_,Month
_) = Day -> (Integer, Month, Month)
toGregorian Day
d
periodMoveTo Day
_ Period
p = Period
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 :: Period -> Period
periodGrow (DayPeriod Day
b) = Day -> Period
WeekPeriod (Day -> Period) -> Day -> Period
forall a b. (a -> b) -> a -> b
$ Day -> Day
mondayBefore Day
b
periodGrow (WeekPeriod Day
b) = Integer -> Month -> Period
MonthPeriod Integer
y Month
m
  where (Integer
y,Month
m) = Day -> (Integer, Month)
yearMonthContainingWeekStarting Day
b
periodGrow (MonthPeriod Integer
y Month
m) = Integer -> Month -> Period
QuarterPeriod Integer
y (Month -> Month
forall a. Integral a => a -> a
quarterContainingMonth Month
m)
periodGrow (QuarterPeriod Integer
y Month
_) = Integer -> Period
YearPeriod Integer
y
periodGrow (YearPeriod Integer
_) = Period
PeriodAll
periodGrow Period
p = Period
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 :: Day -> Period -> Period
periodShrink Day
_     p :: Period
p@(DayPeriod Day
_) = Period
p
periodShrink Day
today (WeekPeriod Day
b)
  | Day
today Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day
b Bool -> Bool -> Bool
&& Day -> Day -> Integer
diffDays Day
today Day
b Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
7 = Day -> Period
DayPeriod Day
today
  | Month
m Month -> Month -> Bool
forall a. Eq a => a -> a -> Bool
/= Month
weekmonth                     = Day -> Period
DayPeriod (Day -> Period) -> Day -> Period
forall a b. (a -> b) -> a -> b
$ Integer -> Month -> Month -> Day
fromGregorian Integer
weekyear Month
weekmonth Month
1
  | Bool
otherwise                          = Day -> Period
DayPeriod Day
b
  where
    (Integer
_,Month
m,Month
_) = Day -> (Integer, Month, Month)
toGregorian Day
b
    (Integer
weekyear,Month
weekmonth) = Day -> (Integer, Month)
yearMonthContainingWeekStarting Day
b
periodShrink Day
today (MonthPeriod Integer
y Month
m)
  | (Integer
y',Month
m') (Integer, Month) -> (Integer, Month) -> Bool
forall a. Eq a => a -> a -> Bool
== (Integer
y,Month
m) = Day -> Period
WeekPeriod (Day -> Period) -> Day -> Period
forall a b. (a -> b) -> a -> b
$ Day -> Day
mondayBefore Day
today
  | Bool
otherwise        = Day -> Period
WeekPeriod (Day -> Period) -> Day -> Period
forall a b. (a -> b) -> a -> b
$ Integer -> Month -> Day
startOfFirstWeekInMonth Integer
y Month
m
  where (Integer
y',Month
m',Month
_) = Day -> (Integer, Month, Month)
toGregorian Day
today
periodShrink Day
today (QuarterPeriod Integer
y Month
q)
  | Month -> Month
forall a. Integral a => a -> a
quarterContainingMonth Month
thismonth Month -> Month -> Bool
forall a. Eq a => a -> a -> Bool
== Month
q = Integer -> Month -> Period
MonthPeriod Integer
y Month
thismonth
  | Bool
otherwise                             = Integer -> Month -> Period
MonthPeriod Integer
y (Month -> Month
forall a. Num a => a -> a
firstMonthOfQuarter Month
q)
  where (Integer
_,Month
thismonth,Month
_) = Day -> (Integer, Month, Month)
toGregorian Day
today
periodShrink Day
today (YearPeriod Integer
y)
  | Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
thisyear = Integer -> Month -> Period
QuarterPeriod Integer
y Month
thisquarter
  | Bool
otherwise     = Integer -> Month -> Period
QuarterPeriod Integer
y Month
1
  where
    (Integer
thisyear,Month
thismonth,Month
_) = Day -> (Integer, Month, Month)
toGregorian Day
today
    thisquarter :: Month
thisquarter = Month -> Month
forall a. Integral a => a -> a
quarterContainingMonth Month
thismonth
periodShrink Day
today Period
_ = Integer -> Period
YearPeriod Integer
y
  where (Integer
y,Month
_,Month
_) = Day -> (Integer, Month, Month)
toGregorian Day
today

mondayBefore :: Day -> Day
mondayBefore Day
d = Integer -> Day -> Day
addDays (Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Month -> Integer
forall a. Integral a => a -> Integer
toInteger Month
wd) Day
d
  where
    (Integer
_,Month
_,Month
wd) = Day -> (Integer, Month, Month)
toWeekDate Day
d

yearMonthContainingWeekStarting :: Day -> (Integer, Month)
yearMonthContainingWeekStarting Day
weekstart = (Integer
y,Month
m)
  where
    thu :: Day
thu = Integer -> Day -> Day
addDays Integer
3 Day
weekstart
    (Integer
y,Month
yd) = Day -> (Integer, Month)
toOrdinalDate Day
thu
    (Month
m,Month
_) = Bool -> Month -> (Month, Month)
dayOfYearToMonthAndDay (Integer -> Bool
isLeapYear Integer
y) Month
yd

quarterContainingMonth :: a -> a
quarterContainingMonth a
m = (a
ma -> a -> a
forall a. Num a => a -> a -> a
-a
1) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
3 a -> a -> a
forall a. Num a => a -> a -> a
+ a
1

firstMonthOfQuarter :: a -> a
firstMonthOfQuarter a
q = (a
qa -> a -> a
forall a. Num a => a -> a -> a
-a
1)a -> a -> a
forall a. Num a => a -> a -> a
*a
3 a -> a -> a
forall a. Num a => a -> a -> a
+ a
1

startOfFirstWeekInMonth :: Integer -> Month -> Day
startOfFirstWeekInMonth Integer
y Month
m
  | Month
monthstartday Month -> Month -> Bool
forall a. Ord a => a -> a -> Bool
<= Month
4 = Day
mon
  | Bool
otherwise          = Integer -> Day -> Day
addDays Integer
7 Day
mon  -- month starts with a fri/sat/sun
  where
    monthstart :: Day
monthstart = Integer -> Month -> Month -> Day
fromGregorian Integer
y Month
m Month
1
    mon :: Day
mon = Day -> Day
mondayBefore Day
monthstart
    (Integer
_,Month
_,Month
monthstartday) = Day -> (Integer, Month, Month)
toWeekDate Day
monthstart