{-|

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

-}

{-# LANGUAGE OverloadedStrings #-}

module Hledger.Data.Period (
   periodAsDateSpan
  ,dateSpanAsPeriod
  ,simplifyPeriod
  ,isLastDayOfMonth
  ,isStandardPeriod
  ,periodTextWidth
  ,showPeriod
  ,showPeriodAbbrev
  ,periodStart
  ,periodEnd
  ,periodNext
  ,periodPrevious
  ,periodNextIn
  ,periodPreviousIn
  ,periodMoveTo
  ,periodGrow
  ,periodShrink
  ,mondayBefore
  ,yearMonthContainingWeekStarting
  ,quarterContainingMonth
  ,firstMonthOfQuarter
  ,startOfFirstWeekInMonth
)
where

import Data.Text (Text)
import qualified Data.Text as T
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 exact DateSpans.
--
-- >>> periodAsDateSpan (MonthPeriod 2000 1) == DateSpan (Just $ Flex $ fromGregorian 2000 1 1) (Just $ Flex $ fromGregorian 2000 2 1)
-- True
periodAsDateSpan :: Period -> DateSpan
periodAsDateSpan :: Period -> DateSpan
periodAsDateSpan (DayPeriod Day
d) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
d) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
1 Day
d)
periodAsDateSpan (WeekPeriod Day
b) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Flex Day
b) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays Integer
7 Day
b)
periodAsDateSpan (MonthPeriod Integer
y MonthOfYear
m) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> MonthOfYear -> MonthOfYear -> Day
fromGregorian Integer
y MonthOfYear
m MonthOfYear
1) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> MonthOfYear -> MonthOfYear -> Day
fromGregorian Integer
y' MonthOfYear
m' MonthOfYear
1)
  where
    (Integer
y',MonthOfYear
m') | MonthOfYear
mMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
12     = (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1,MonthOfYear
1)
            | Bool
otherwise = (Integer
y,MonthOfYear
mMonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
+MonthOfYear
1)
periodAsDateSpan (QuarterPeriod Integer
y MonthOfYear
q) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> MonthOfYear -> MonthOfYear -> Day
fromGregorian Integer
y MonthOfYear
m MonthOfYear
1) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> MonthOfYear -> MonthOfYear -> Day
fromGregorian Integer
y' MonthOfYear
m' MonthOfYear
1)
  where
    (Integer
y', MonthOfYear
q') | MonthOfYear
qMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
4      = (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1,MonthOfYear
1)
             | Bool
otherwise = (Integer
y,MonthOfYear
qMonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
+MonthOfYear
1)
    quarterAsMonth :: a -> a
quarterAsMonth a
q2 = (a
q2a -> 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 :: MonthOfYear
m  = MonthOfYear -> MonthOfYear
forall {a}. Num a => a -> a
quarterAsMonth MonthOfYear
q
    m' :: MonthOfYear
m' = MonthOfYear -> MonthOfYear
forall {a}. Num a => a -> a
quarterAsMonth MonthOfYear
q'
periodAsDateSpan (YearPeriod Integer
y) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> MonthOfYear -> MonthOfYear -> Day
fromGregorian Integer
y MonthOfYear
1 MonthOfYear
1) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Flex (Day -> EFDay) -> Day -> EFDay
forall a b. (a -> b) -> a -> b
$ Integer -> MonthOfYear -> MonthOfYear -> Day
fromGregorian (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) MonthOfYear
1 MonthOfYear
1)
periodAsDateSpan (PeriodBetween Day
b Day
e) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
b) (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
e)
periodAsDateSpan (PeriodFrom Day
b) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
b) Maybe EFDay
forall a. Maybe a
Nothing
periodAsDateSpan (PeriodTo Day
e) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan Maybe EFDay
forall a. Maybe a
Nothing (EFDay -> Maybe EFDay
forall a. a -> Maybe a
Just (EFDay -> Maybe EFDay) -> EFDay -> Maybe EFDay
forall a b. (a -> b) -> a -> b
$ Day -> EFDay
Exact Day
e)
periodAsDateSpan (Period
PeriodAll) = Maybe EFDay -> Maybe EFDay -> DateSpan
DateSpan Maybe EFDay
forall a. Maybe a
Nothing Maybe EFDay
forall a. Maybe a
Nothing

-- | Convert DateSpans to Periods.
--
-- >>> dateSpanAsPeriod $ DateSpan (Just $ Exact $ fromGregorian 2000 1 1) (Just $ Exact $ fromGregorian 2000 2 1)
-- MonthPeriod 2000 1
dateSpanAsPeriod :: DateSpan -> Period
dateSpanAsPeriod :: DateSpan -> Period
dateSpanAsPeriod (DateSpan (Just EFDay
b) (Just EFDay
e)) = Period -> Period
simplifyPeriod (Period -> Period) -> Period -> Period
forall a b. (a -> b) -> a -> b
$ Day -> Day -> Period
PeriodBetween (EFDay -> Day
fromEFDay EFDay
b) (EFDay -> Day
fromEFDay EFDay
e)
dateSpanAsPeriod (DateSpan (Just EFDay
b) Maybe EFDay
Nothing) = Day -> Period
PeriodFrom (EFDay -> Day
fromEFDay EFDay
b)
dateSpanAsPeriod (DateSpan Maybe EFDay
Nothing (Just EFDay
e)) = Day -> Period
PeriodTo (EFDay -> Day
fromEFDay EFDay
e)
dateSpanAsPeriod (DateSpan Maybe EFDay
Nothing Maybe EFDay
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, MonthOfYear, MonthOfYear)
toGregorian Day
b, Day -> (Integer, MonthOfYear, MonthOfYear)
toGregorian Day
e) of
    -- a year
    ((Integer
by,MonthOfYear
1,MonthOfYear
1), (Integer
ey,MonthOfYear
1,MonthOfYear
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,MonthOfYear
1,MonthOfYear
1), (Integer
ey,MonthOfYear
4,MonthOfYear
1))   | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey             -> Integer -> MonthOfYear -> Period
QuarterPeriod Integer
by MonthOfYear
1
    ((Integer
by,MonthOfYear
4,MonthOfYear
1), (Integer
ey,MonthOfYear
7,MonthOfYear
1))   | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey             -> Integer -> MonthOfYear -> Period
QuarterPeriod Integer
by MonthOfYear
2
    ((Integer
by,MonthOfYear
7,MonthOfYear
1), (Integer
ey,MonthOfYear
10,MonthOfYear
1))  | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey             -> Integer -> MonthOfYear -> Period
QuarterPeriod Integer
by MonthOfYear
3
    ((Integer
by,MonthOfYear
10,MonthOfYear
1), (Integer
ey,MonthOfYear
1,MonthOfYear
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 -> MonthOfYear -> Period
QuarterPeriod Integer
by MonthOfYear
4
    -- a month
    ((Integer
by,MonthOfYear
bm,MonthOfYear
1), (Integer
ey,MonthOfYear
em,MonthOfYear
1)) | Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey Bool -> Bool -> Bool
&& MonthOfYear
bmMonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
+MonthOfYear
1MonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
em -> Integer -> MonthOfYear -> Period
MonthPeriod Integer
by MonthOfYear
bm
    ((Integer
by,MonthOfYear
12,MonthOfYear
1), (Integer
ey,MonthOfYear
1,MonthOfYear
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 -> MonthOfYear -> Period
MonthPeriod Integer
by MonthOfYear
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, MonthOfYear, MonthOfYear),
 (Integer, MonthOfYear, MonthOfYear))
_ | let ((Integer
by,MonthOfYear
bw,MonthOfYear
bd), (Integer
ey,MonthOfYear
ew,MonthOfYear
ed)) = (Day -> (Integer, MonthOfYear, MonthOfYear)
toWeekDate Day
b, Day -> (Integer, MonthOfYear, MonthOfYear)
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
&& MonthOfYear
bwMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
ew Bool -> Bool -> Bool
&& MonthOfYear
bdMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
1 Bool -> Bool -> Bool
&& MonthOfYear
edMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
7   -> Day -> Period
WeekPeriod Day
b
    -- a day
    ((Integer
by,MonthOfYear
bm,MonthOfYear
bd), (Integer
ey,MonthOfYear
em,MonthOfYear
ed)) |
        (Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey Bool -> Bool -> Bool
&& MonthOfYear
bmMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
em Bool -> Bool -> Bool
&& MonthOfYear
bdMonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
+MonthOfYear
1MonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
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
&& MonthOfYear
bmMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
12 Bool -> Bool -> Bool
&& MonthOfYear
emMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
1 Bool -> Bool -> Bool
&& MonthOfYear
bdMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
31 Bool -> Bool -> Bool
&& MonthOfYear
edMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
1) Bool -> Bool -> Bool
|| -- crossing a year boundary
        (Integer
byInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
ey Bool -> Bool -> Bool
&& MonthOfYear
bmMonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
+MonthOfYear
1MonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
em Bool -> Bool -> Bool
&& Integer -> MonthOfYear -> MonthOfYear -> Bool
forall {a} {a}.
(Eq a, Eq a, Num a, Num a) =>
Integer -> a -> a -> Bool
isLastDayOfMonth Integer
by MonthOfYear
bm MonthOfYear
bd Bool -> Bool -> Bool
&& MonthOfYear
edMonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
==MonthOfYear
1) -- crossing a month boundary
         -> Day -> Period
DayPeriod Day
b
    ((Integer, MonthOfYear, MonthOfYear),
 (Integer, MonthOfYear, MonthOfYear))
_ -> 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
_ MonthOfYear
_) = Bool
True
    isStandardPeriod' (QuarterPeriod Integer
_ MonthOfYear
_) = Bool
True
    isStandardPeriod' (YearPeriod Integer
_) = Bool
True
    isStandardPeriod' Period
_ = Bool
False

-- | The width of a period of this type when displayed.
periodTextWidth :: Period -> Int
periodTextWidth :: Period -> MonthOfYear
periodTextWidth = Period -> MonthOfYear
forall {a}. Num a => Period -> a
periodTextWidth' (Period -> MonthOfYear)
-> (Period -> Period) -> Period -> MonthOfYear
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Period -> Period
simplifyPeriod
  where
    periodTextWidth' :: Period -> a
periodTextWidth' DayPeriod{}     = a
10  -- 2021-01-01
    periodTextWidth' WeekPeriod{}    = a
13  -- 2021-01-01W52
    periodTextWidth' MonthPeriod{}   = a
7   -- 2021-01
    periodTextWidth' QuarterPeriod{} = a
6   -- 2021Q1
    periodTextWidth' YearPeriod{}    = a
4   -- 2021
    periodTextWidth' PeriodBetween{} = a
22  -- 2021-01-01..2021-01-07
    periodTextWidth' PeriodFrom{}    = a
12  -- 2021-01-01..
    periodTextWidth' PeriodTo{}      = a
12  -- ..2021-01-01
    periodTextWidth' Period
PeriodAll       = a
2   -- ..

-- | Render a period as a compact display string suitable for user output.
--
-- >>> showPeriod (WeekPeriod (fromGregorian 2016 7 25))
-- "2016-W30"
showPeriod :: Period -> Text
showPeriod :: Period -> Text
showPeriod (DayPeriod Day
b)       = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> 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)      = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%0Y-W%V" Day
b         -- YYYY-Www
showPeriod (MonthPeriod Integer
y MonthOfYear
m)   = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Integer -> MonthOfYear -> String
forall r. PrintfType r => String -> r
printf String
"%04d-%02d" Integer
y MonthOfYear
m                           -- YYYY-MM
showPeriod (QuarterPeriod Integer
y MonthOfYear
q) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Integer -> MonthOfYear -> String
forall r. PrintfType r => String -> r
printf String
"%04dQ%d" Integer
y MonthOfYear
q                             -- YYYYQN
showPeriod (YearPeriod Integer
y)      = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%04d" Integer
y                                  -- YYYY
showPeriod (PeriodBetween Day
b Day
e) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ 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)      = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> 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)        = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ 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           = Text
".."

-- | Like showPeriod, but if it's a month or week period show
-- an abbreviated form.
-- >>> showPeriodAbbrev (WeekPeriod (fromGregorian 2016 7 25))
-- "W30"
showPeriodAbbrev :: Period -> Text
showPeriodAbbrev :: Period -> Text
showPeriodAbbrev (MonthPeriod Integer
_ MonthOfYear
m)                                              -- Jan
  | MonthOfYear
m MonthOfYear -> MonthOfYear -> Bool
forall a. Ord a => a -> a -> Bool
> MonthOfYear
0 Bool -> Bool -> Bool
&& MonthOfYear
m MonthOfYear -> MonthOfYear -> Bool
forall a. Ord a => a -> a -> Bool
<= [(String, String)] -> MonthOfYear
forall a. [a] -> MonthOfYear
forall (t :: * -> *) a. Foldable t => t a -> MonthOfYear
length [(String, String)]
monthnames = String -> Text
T.pack (String -> Text)
-> ((String, String) -> String) -> (String, String) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> Text) -> (String, String) -> Text
forall a b. (a -> b) -> a -> b
$ [(String, String)]
monthnames [(String, String)] -> MonthOfYear -> (String, String)
forall a. HasCallStack => [a] -> MonthOfYear -> a
!! (MonthOfYear
mMonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
-MonthOfYear
1)
  where monthnames :: [(String, String)]
monthnames = TimeLocale -> [(String, String)]
months TimeLocale
defaultTimeLocale
showPeriodAbbrev (WeekPeriod Day
b) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"W%V" Day
b -- Www
showPeriodAbbrev Period
p = Period -> Text
showPeriod Period
p

periodStart :: Period -> Maybe Day
periodStart :: Period -> Maybe Day
periodStart Period
p = EFDay -> Day
fromEFDay (EFDay -> Day) -> Maybe EFDay -> Maybe Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EFDay
mb
  where
    DateSpan Maybe EFDay
mb Maybe EFDay
_ = Period -> DateSpan
periodAsDateSpan Period
p

periodEnd :: Period -> Maybe Day
periodEnd :: Period -> Maybe Day
periodEnd Period
p = EFDay -> Day
fromEFDay (EFDay -> Day) -> Maybe EFDay -> Maybe Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe EFDay
me
  where
    DateSpan Maybe EFDay
_ Maybe EFDay
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 MonthOfYear
12) = Integer -> MonthOfYear -> Period
MonthPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) MonthOfYear
1
periodNext (MonthPeriod Integer
y MonthOfYear
m) = Integer -> MonthOfYear -> Period
MonthPeriod Integer
y (MonthOfYear
mMonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
+MonthOfYear
1)
periodNext (QuarterPeriod Integer
y MonthOfYear
4) = Integer -> MonthOfYear -> Period
QuarterPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) MonthOfYear
1
periodNext (QuarterPeriod Integer
y MonthOfYear
q) = Integer -> MonthOfYear -> Period
QuarterPeriod Integer
y (MonthOfYear
qMonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
+MonthOfYear
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 MonthOfYear
1) = Integer -> MonthOfYear -> Period
MonthPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) MonthOfYear
12
periodPrevious (MonthPeriod Integer
y MonthOfYear
m) = Integer -> MonthOfYear -> Period
MonthPeriod Integer
y (MonthOfYear
mMonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
-MonthOfYear
1)
periodPrevious (QuarterPeriod Integer
y MonthOfYear
1) = Integer -> MonthOfYear -> Period
QuarterPeriod (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) MonthOfYear
4
periodPrevious (QuarterPeriod Integer
y MonthOfYear
q) = Integer -> MonthOfYear -> Period
QuarterPeriod Integer
y (MonthOfYear
qMonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
-MonthOfYear
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 EFDay
_ (Just EFDay
e0)) 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
    e :: Day
e = EFDay -> Day
fromEFDay EFDay
e0
    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 EFDay
b0) Maybe EFDay
_) 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
    b :: Day
b = EFDay -> Day
fromEFDay EFDay
b0
    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
_ MonthOfYear
_) = Integer -> MonthOfYear -> Period
MonthPeriod Integer
y MonthOfYear
m where (Integer
y,MonthOfYear
m,MonthOfYear
_) = Day -> (Integer, MonthOfYear, MonthOfYear)
toGregorian Day
d
periodMoveTo Day
d (QuarterPeriod Integer
_ MonthOfYear
_) = Integer -> MonthOfYear -> Period
QuarterPeriod Integer
y MonthOfYear
q
  where
    (Integer
y,MonthOfYear
m,MonthOfYear
_) = Day -> (Integer, MonthOfYear, MonthOfYear)
toGregorian Day
d
    q :: MonthOfYear
q = MonthOfYear -> MonthOfYear
forall {a}. Integral a => a -> a
quarterContainingMonth MonthOfYear
m
periodMoveTo Day
d (YearPeriod Integer
_) = Integer -> Period
YearPeriod Integer
y where (Integer
y,MonthOfYear
_,MonthOfYear
_) = Day -> (Integer, MonthOfYear, MonthOfYear)
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 -> MonthOfYear -> Period
MonthPeriod Integer
y MonthOfYear
m
  where (Integer
y,MonthOfYear
m) = Day -> (Integer, MonthOfYear)
yearMonthContainingWeekStarting Day
b
periodGrow (MonthPeriod Integer
y MonthOfYear
m) = Integer -> MonthOfYear -> Period
QuarterPeriod Integer
y (MonthOfYear -> MonthOfYear
forall {a}. Integral a => a -> a
quarterContainingMonth MonthOfYear
m)
periodGrow (QuarterPeriod Integer
y MonthOfYear
_) = 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
  | MonthOfYear
m MonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
/= MonthOfYear
weekmonth                     = Day -> Period
DayPeriod (Day -> Period) -> Day -> Period
forall a b. (a -> b) -> a -> b
$ Integer -> MonthOfYear -> MonthOfYear -> Day
fromGregorian Integer
weekyear MonthOfYear
weekmonth MonthOfYear
1
  | Bool
otherwise                          = Day -> Period
DayPeriod Day
b
  where
    (Integer
_,MonthOfYear
m,MonthOfYear
_) = Day -> (Integer, MonthOfYear, MonthOfYear)
toGregorian Day
b
    (Integer
weekyear,MonthOfYear
weekmonth) = Day -> (Integer, MonthOfYear)
yearMonthContainingWeekStarting Day
b
periodShrink Day
today (MonthPeriod Integer
y MonthOfYear
m)
  | (Integer
y',MonthOfYear
m') (Integer, MonthOfYear) -> (Integer, MonthOfYear) -> Bool
forall a. Eq a => a -> a -> Bool
== (Integer
y,MonthOfYear
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 -> MonthOfYear -> Day
startOfFirstWeekInMonth Integer
y MonthOfYear
m
  where (Integer
y',MonthOfYear
m',MonthOfYear
_) = Day -> (Integer, MonthOfYear, MonthOfYear)
toGregorian Day
today
periodShrink Day
today (QuarterPeriod Integer
y MonthOfYear
q)
  | MonthOfYear -> MonthOfYear
forall {a}. Integral a => a -> a
quarterContainingMonth MonthOfYear
thismonth MonthOfYear -> MonthOfYear -> Bool
forall a. Eq a => a -> a -> Bool
== MonthOfYear
q = Integer -> MonthOfYear -> Period
MonthPeriod Integer
y MonthOfYear
thismonth
  | Bool
otherwise                             = Integer -> MonthOfYear -> Period
MonthPeriod Integer
y (MonthOfYear -> MonthOfYear
forall {a}. Num a => a -> a
firstMonthOfQuarter MonthOfYear
q)
  where (Integer
_,MonthOfYear
thismonth,MonthOfYear
_) = Day -> (Integer, MonthOfYear, MonthOfYear)
toGregorian Day
today
periodShrink Day
today (YearPeriod Integer
y)
  | Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
thisyear = Integer -> MonthOfYear -> Period
QuarterPeriod Integer
y MonthOfYear
thisquarter
  | Bool
otherwise     = Integer -> MonthOfYear -> Period
QuarterPeriod Integer
y MonthOfYear
1
  where
    (Integer
thisyear,MonthOfYear
thismonth,MonthOfYear
_) = Day -> (Integer, MonthOfYear, MonthOfYear)
toGregorian Day
today
    thisquarter :: MonthOfYear
thisquarter = MonthOfYear -> MonthOfYear
forall {a}. Integral a => a -> a
quarterContainingMonth MonthOfYear
thismonth
periodShrink Day
today Period
_ = Integer -> Period
YearPeriod Integer
y
  where (Integer
y,MonthOfYear
_,MonthOfYear
_) = Day -> (Integer, MonthOfYear, MonthOfYear)
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
- MonthOfYear -> Integer
forall a. Integral a => a -> Integer
toInteger MonthOfYear
wd) Day
d
  where
    (Integer
_,MonthOfYear
_,MonthOfYear
wd) = Day -> (Integer, MonthOfYear, MonthOfYear)
toWeekDate Day
d

yearMonthContainingWeekStarting :: Day -> (Integer, MonthOfYear)
yearMonthContainingWeekStarting Day
weekstart = (Integer
y,MonthOfYear
m)
  where
    thu :: Day
thu = Integer -> Day -> Day
addDays Integer
3 Day
weekstart
    (Integer
y,MonthOfYear
yd) = Day -> (Integer, MonthOfYear)
toOrdinalDate Day
thu
    (MonthOfYear
m,MonthOfYear
_) = Bool -> MonthOfYear -> (MonthOfYear, MonthOfYear)
dayOfYearToMonthAndDay (Integer -> Bool
isLeapYear Integer
y) MonthOfYear
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 -> MonthOfYear -> Day
startOfFirstWeekInMonth Integer
y MonthOfYear
m
  | MonthOfYear
monthstartday MonthOfYear -> MonthOfYear -> Bool
forall a. Ord a => a -> a -> Bool
<= MonthOfYear
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 -> MonthOfYear -> MonthOfYear -> Day
fromGregorian Integer
y MonthOfYear
m MonthOfYear
1
    mon :: Day
mon = Day -> Day
mondayBefore Day
monthstart
    (Integer
_,MonthOfYear
_,MonthOfYear
monthstartday) = Day -> (Integer, MonthOfYear, MonthOfYear)
toWeekDate Day
monthstart