{-|

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 d :: 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 1 Day
d)
periodAsDateSpan (WeekPeriod b :: 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 7 Day
b)
periodAsDateSpan (MonthPeriod y :: Integer
y m :: 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 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' 1)
  where
    (y' :: Integer
y',m' :: Month
m') | Month
mMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==12     = (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1,1)
            | Bool
otherwise = (Integer
y,Month
mMonth -> Month -> Month
forall a. Num a => a -> a -> a
+1)
periodAsDateSpan (QuarterPeriod y :: Integer
y q :: 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 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' 1)
  where
    (y' :: Integer
y', q' :: Month
q') | Month
qMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==4      = (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1,1)
             | Bool
otherwise = (Integer
y,Month
qMonth -> Month -> Month
forall a. Num a => a -> a -> a
+1)
    quarterAsMonth :: a -> a
quarterAsMonth q :: a
q = (a
qa -> a -> a
forall a. Num a => a -> a -> a
-1) a -> a -> a
forall a. Num a => a -> a -> a
* 3 a -> a -> a
forall a. Num 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 y :: 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 1 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
+1) 1 1)
periodAsDateSpan (PeriodBetween b :: Day
b e :: 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 b :: 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 e :: 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 b :: Day
b) (Just e :: 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 b :: Day
b) Nothing) = Day -> Period
PeriodFrom Day
b
dateSpanAsPeriod (DateSpan Nothing (Just e :: Day
e)) = Day -> Period
PeriodTo Day
e
dateSpanAsPeriod (DateSpan Nothing 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 b :: Day
b e :: Day
e) =
  case (Day -> (Integer, Month, Month)
toGregorian Day
b, Day -> (Integer, Month, Month)
toGregorian Day
e) of
    -- a year
    ((by :: Integer
by,1,1), (ey :: Integer
ey,1,1))   | Integer
byInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+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
    ((by :: Integer
by,1,1), (ey :: Integer
ey,4,1))   | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey             -> Integer -> Month -> Period
QuarterPeriod Integer
by 1
    ((by :: Integer
by,4,1), (ey :: Integer
ey,7,1))   | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey             -> Integer -> Month -> Period
QuarterPeriod Integer
by 2
    ((by :: Integer
by,7,1), (ey :: Integer
ey,10,1))  | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey             -> Integer -> Month -> Period
QuarterPeriod Integer
by 3
    ((by :: Integer
by,10,1), (ey :: Integer
ey,1,1))  | Integer
byInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey           -> Integer -> Month -> Period
QuarterPeriod Integer
by 4
    -- a month
    ((by :: Integer
by,bm :: Month
bm,1), (ey :: Integer
ey,em :: Month
em,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
+1Month -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==Month
em -> Integer -> Month -> Period
MonthPeriod Integer
by Month
bm
    ((by :: Integer
by,12,1), (ey :: Integer
ey,1,1))  | Integer
byInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey           -> Integer -> Month -> Period
MonthPeriod Integer
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 :: Integer
by,bw :: Month
bw,bd :: Month
bd), (ey :: Integer
ey,ew :: Month
ew,ed :: Month
ed)) = (Day -> (Integer, Month, Month)
toWeekDate Day
b, Day -> (Integer, Month, Month)
toWeekDate (Integer -> Day -> Day
addDays (-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
==1 Bool -> Bool -> Bool
&& Month
edMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==7   -> Day -> Period
WeekPeriod Day
b
    -- a day
    ((by :: Integer
by,bm :: Month
bm,bd :: Month
bd), (ey :: Integer
ey,em :: Month
em,ed :: 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
+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
+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
==12 Bool -> Bool -> Bool
&& Month
emMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==1 Bool -> Bool -> Bool
&& Month
bdMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==31 Bool -> Bool -> Bool
&& Month
edMonth -> Month -> Bool
forall a. Eq a => a -> a -> Bool
==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
+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
==1) -- crossing a month boundary
         -> Day -> Period
DayPeriod Day
b
    _ -> Day -> Day -> Period
PeriodBetween Day
b Day
e
simplifyPeriod p :: Period
p = Period
p

isLastDayOfMonth :: Integer -> a -> a -> Bool
isLastDayOfMonth y :: Integer
y m :: a
m d :: a
d =
  case a
m of
    1 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==31
    2 | Integer -> Bool
isLeapYear Integer
y -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==29
      | Bool
otherwise    -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==28
    3 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==31
    4 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==30
    5 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==31
    6 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==30
    7 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==31
    8 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==31
    9 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==30
    10 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==31
    11 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==30
    12 -> a
da -> a -> Bool
forall a. Eq a => a -> a -> Bool
==31
    _ -> 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 _) = Bool
True
    isStandardPeriod' (WeekPeriod _) = Bool
True
    isStandardPeriod' (MonthPeriod _ _) = Bool
True
    isStandardPeriod' (QuarterPeriod _ _) = Bool
True
    isStandardPeriod' (YearPeriod _) = Bool
True
    isStandardPeriod' _ = 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 b :: Day
b)       = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%F" Day
b              -- DATE
showPeriod (WeekPeriod b :: Day
b)      = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%FW%V" Day
b           -- STARTDATEWYEARWEEK
showPeriod (MonthPeriod y :: Integer
y m :: Month
m)   = String -> Integer -> Month -> String
forall r. PrintfType r => String -> r
printf "%04d-%02d" Integer
y Month
m                           -- YYYY-MM
showPeriod (QuarterPeriod y :: Integer
y q :: Month
q) = String -> Integer -> Month -> String
forall r. PrintfType r => String -> r
printf "%04dQ%d" Integer
y Month
q                             -- YYYYQN
showPeriod (YearPeriod y :: Integer
y)      = String -> Integer -> String
forall r. PrintfType r => String -> r
printf "%04d" Integer
y                                  -- YYYY
showPeriod (PeriodBetween b :: Day
b e :: Day
e) = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%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 "..%F" (Integer -> Day -> Day
addDays (-1) Day
e) -- STARTDATE..INCLUSIVEENDDATE
showPeriod (PeriodFrom b :: Day
b)      = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%F.." Day
b                   -- STARTDATE..
showPeriod (PeriodTo e :: Day
e)        = TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "..%F" (Integer -> Day -> Day
addDays (-1) Day
e)    -- ..INCLUSIVEENDDATE
showPeriod PeriodAll           = ".."

-- | 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 _ m :: Month
m)                           -- Jan
  | Month
m Month -> Month -> Bool
forall a. Ord a => a -> a -> Bool
> 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
-1)
  where monthnames :: [(String, String)]
monthnames = TimeLocale -> [(String, String)]
months TimeLocale
defaultTimeLocale
showPeriodMonthAbbrev p :: Period
p = Period -> String
showPeriod Period
p

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

periodEnd :: Period -> Maybe Day
periodEnd :: Period -> Maybe Day
periodEnd p :: Period
p = Maybe Day
me
  where
    DateSpan _ me :: 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 b :: Day
b) = Day -> Period
DayPeriod (Integer -> Day -> Day
addDays 1 Day
b)
periodNext (WeekPeriod b :: Day
b) = Day -> Period
WeekPeriod (Integer -> Day -> Day
addDays 7 Day
b)
periodNext (MonthPeriod y :: Integer
y 12) = Integer -> Month -> Period
MonthPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1) 1
periodNext (MonthPeriod y :: Integer
y m :: Month
m) = Integer -> Month -> Period
MonthPeriod Integer
y (Month
mMonth -> Month -> Month
forall a. Num a => a -> a -> a
+1)
periodNext (QuarterPeriod y :: Integer
y 4) = Integer -> Month -> Period
QuarterPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1) 1
periodNext (QuarterPeriod y :: Integer
y q :: Month
q) = Integer -> Month -> Period
QuarterPeriod Integer
y (Month
qMonth -> Month -> Month
forall a. Num a => a -> a -> a
+1)
periodNext (YearPeriod y :: Integer
y) = Integer -> Period
YearPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1)
periodNext p :: 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 b :: Day
b) = Day -> Period
DayPeriod (Integer -> Day -> Day
addDays (-1) Day
b)
periodPrevious (WeekPeriod b :: Day
b) = Day -> Period
WeekPeriod (Integer -> Day -> Day
addDays (-7) Day
b)
periodPrevious (MonthPeriod y :: Integer
y 1) = Integer -> Month -> Period
MonthPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-1) 12
periodPrevious (MonthPeriod y :: Integer
y m :: Month
m) = Integer -> Month -> Period
MonthPeriod Integer
y (Month
mMonth -> Month -> Month
forall a. Num a => a -> a -> a
-1)
periodPrevious (QuarterPeriod y :: Integer
y 1) = Integer -> Month -> Period
QuarterPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-1) 4
periodPrevious (QuarterPeriod y :: Integer
y q :: Month
q) = Integer -> Month -> Period
QuarterPeriod Integer
y (Month
qMonth -> Month -> Month
forall a. Num a => a -> a -> a
-1)
periodPrevious (YearPeriod y :: Integer
y) = Integer -> Period
YearPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-1)
periodPrevious p :: 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 _ (Just e :: Day
e)) p :: Period
p =
  case Maybe Day
mb of
    Just b :: Day
b -> if Day
b Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
< Day
e then Period
p' else Period
p
    _      -> Period
p
  where
    p' :: Period
p' = Period -> Period
periodNext Period
p
    mb :: Maybe Day
mb = Period -> Maybe Day
periodStart Period
p'
periodNextIn _ p :: 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 b :: Day
b) _) p :: Period
p =
  case Maybe Day
me of
    Just e :: Day
e -> if Day
e Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
> Day
b then Period
p' else Period
p
    _      -> Period
p
  where
    p' :: Period
p' = Period -> Period
periodPrevious Period
p
    me :: Maybe Day
me = Period -> Maybe Day
periodEnd Period
p'
periodPreviousIn _ p :: 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 d :: Day
d (DayPeriod _) = Day -> Period
DayPeriod Day
d
periodMoveTo d :: Day
d (WeekPeriod _) = Day -> Period
WeekPeriod (Day -> Period) -> Day -> Period
forall a b. (a -> b) -> a -> b
$ Day -> Day
mondayBefore Day
d
periodMoveTo d :: Day
d (MonthPeriod _ _) = Integer -> Month -> Period
MonthPeriod Integer
y Month
m where (y :: Integer
y,m :: Month
m,_) = Day -> (Integer, Month, Month)
toGregorian Day
d
periodMoveTo d :: Day
d (QuarterPeriod _ _) = Integer -> Month -> Period
QuarterPeriod Integer
y Month
q
  where
    (y :: Integer
y,m :: Month
m,_) = Day -> (Integer, Month, Month)
toGregorian Day
d
    q :: Month
q = Month -> Month
forall a. Integral a => a -> a
quarterContainingMonth Month
m
periodMoveTo d :: Day
d (YearPeriod _) = Integer -> Period
YearPeriod Integer
y where (y :: Integer
y,_,_) = Day -> (Integer, Month, Month)
toGregorian Day
d
periodMoveTo _ p :: 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 b :: Day
b) = Day -> Period
WeekPeriod (Day -> Period) -> Day -> Period
forall a b. (a -> b) -> a -> b
$ Day -> Day
mondayBefore Day
b
periodGrow (WeekPeriod b :: Day
b) = Integer -> Month -> Period
MonthPeriod Integer
y Month
m
  where (y :: Integer
y,m :: Month
m) = Day -> (Integer, Month)
yearMonthContainingWeekStarting Day
b
periodGrow (MonthPeriod y :: Integer
y m :: Month
m) = Integer -> Month -> Period
QuarterPeriod Integer
y (Month -> Month
forall a. Integral a => a -> a
quarterContainingMonth Month
m)
periodGrow (QuarterPeriod y :: Integer
y _) = Integer -> Period
YearPeriod Integer
y
periodGrow (YearPeriod _) = Period
PeriodAll
periodGrow p :: 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 _     p :: Period
p@(DayPeriod _) = Period
p
periodShrink today :: Day
today (WeekPeriod b :: 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
< 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 1
  | Bool
otherwise                          = Day -> Period
DayPeriod Day
b
  where
    (_,m :: Month
m,_) = Day -> (Integer, Month, Month)
toGregorian Day
b
    (weekyear :: Integer
weekyear,weekmonth :: Month
weekmonth) = Day -> (Integer, Month)
yearMonthContainingWeekStarting Day
b
periodShrink today :: Day
today (MonthPeriod y :: Integer
y m :: 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 (y' :: Integer
y',m' :: Month
m',_) = Day -> (Integer, Month, Month)
toGregorian Day
today
periodShrink today :: Day
today (QuarterPeriod y :: Integer
y q :: 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 (_,thismonth :: Month
thismonth,_) = Day -> (Integer, Month, Month)
toGregorian Day
today
periodShrink today :: Day
today (YearPeriod y :: 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 1
  where
    (thisyear :: Integer
thisyear,thismonth :: Month
thismonth,_) = Day -> (Integer, Month, Month)
toGregorian Day
today
    thisquarter :: Month
thisquarter = Month -> Month
forall a. Integral a => a -> a
quarterContainingMonth Month
thismonth
periodShrink today :: Day
today _ = Integer -> Period
YearPeriod Integer
y
  where (y :: Integer
y,_,_) = Day -> (Integer, Month, Month)
toGregorian Day
today

mondayBefore :: Day -> Day
mondayBefore d :: Day
d = Integer -> Day -> Day
addDays (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
    (_,_,wd :: Month
wd) = Day -> (Integer, Month, Month)
toWeekDate Day
d

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

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

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

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