{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

#include "thyme.h"
#if HLINT
#include "cabal_macros.h"
#endif

-- | Calendar calculations.
--
-- Note that 'UTCTime' is not Y294K-compliant, and 'Bounded' instances for
-- the various calendar types reflect this fact. That said, the calendar
-- calculations by themselves work perfectly fine for a wider range of
-- dates, subject to the size of 'Int' for your platform.
module Data.Thyme.Calendar
    (
    -- * Day
      Day (..), modifiedJulianDay

    -- * Calendar
    , Year, Month, DayOfMonth
    , YearMonthDay (..), _ymdYear, _ymdMonth, _ymdDay
    , Years, Months, Days

    -- * Gregorian calendar
    -- $proleptic
    , isLeapYear
    , yearMonthDay, gregorian, gregorianValid, showGregorian
    , module Data.Thyme.Calendar
    ) where

import Prelude hiding ((.))
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Arrow
import Control.Category
import Control.Lens
import Control.Monad
import Data.AdditiveGroup
import Data.AffineSpace
import Data.Thyme.Calendar.Internal
import Data.Thyme.Clock.Internal
import System.Random
import Test.QuickCheck

-- "Data.Thyme.Calendar.Internal" cannot import "Data.Thyme.Clock.Internal",
-- therefore these orphan 'Bounded' instances must live here.
instance Bounded Day where
    minBound :: Day
minBound = forall a. Bounded a => a
minBound forall s a. s -> Getting a s a -> a
^. Lens' UTCTime Day
_utctDay
    maxBound :: Day
maxBound = forall a. Bounded a => a
maxBound forall s a. s -> Getting a s a -> a
^. Lens' UTCTime Day
_utctDay

instance Bounded YearMonthDay where
    minBound :: YearMonthDay
minBound = forall a. Bounded a => a
minBound forall s a. s -> Getting a s a -> a
^. Iso' Day YearMonthDay
gregorian
    maxBound :: YearMonthDay
maxBound = forall a. Bounded a => a
maxBound forall s a. s -> Getting a s a -> a
^. Iso' Day YearMonthDay
gregorian

instance Random Day where
    randomR :: forall g. RandomGen g => (Day, Day) -> g -> (Day, g)
randomR (Day, Day)
r = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall s a. s -> Getting a s a -> a
^. Lens' UTCTime Day
_utctDay) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR ((Day, Day) -> (UTCTime, UTCTime)
range (Day, Day)
r) where
        -- upper bound is one Micro second before the next day
        range :: (Day, Day) -> (UTCTime, UTCTime)
range = Day -> UTCTime
toMidnight forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. Enum a => a -> a
pred forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Day -> UTCTime
toMidnight forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Enum a => a -> a
succ
        toMidnight :: Day -> UTCTime
toMidnight Day
day = Iso' UTCTime UTCView
utcTime forall s t a b. AReview s t a b -> b -> t
# Day -> DiffTime -> UTCView
UTCView Day
day forall v. AdditiveGroup v => v
zeroV
    random :: forall g. RandomGen g => g -> (Day, g)
random = forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (forall a. Bounded a => a
minBound, forall a. Bounded a => a
maxBound)

instance Random YearMonthDay where
    randomR :: forall g.
RandomGen g =>
(YearMonthDay, YearMonthDay) -> g -> (YearMonthDay, g)
randomR = forall s g a.
(Random s, RandomGen g) =>
Iso' s a -> (a, a) -> g -> (a, g)
randomIsoR Iso' Day YearMonthDay
gregorian
    random :: forall g. RandomGen g => g -> (YearMonthDay, g)
random = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall s a. s -> Getting a s a -> a
^. Iso' Day YearMonthDay
gregorian) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a g. (Random a, RandomGen g) => g -> (a, g)
random

instance Arbitrary Day where
    arbitrary :: Gen Day
arbitrary = Years -> Day
ModifiedJulianDay
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***) Day -> Years
toModifiedJulianDay (forall a. Bounded a => a
minBound, forall a. Bounded a => a
maxBound))
    shrink :: Day -> [Day]
shrink (ModifiedJulianDay Years
mjd) = Years -> Day
ModifiedJulianDay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink Years
mjd

instance Arbitrary YearMonthDay where
    arbitrary :: Gen YearMonthDay
arbitrary = forall a s. Getting a s a -> s -> a
view Iso' Day YearMonthDay
gregorian forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
    shrink :: YearMonthDay -> [YearMonthDay]
shrink YearMonthDay
ymd = forall a s. Getting a s a -> s -> a
view Iso' Day YearMonthDay
gregorian forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink (Iso' Day YearMonthDay
gregorian forall s t a b. AReview s t a b -> b -> t
# YearMonthDay
ymd)

instance CoArbitrary YearMonthDay where
    coarbitrary :: forall b. YearMonthDay -> Gen b -> Gen b
coarbitrary (YearMonthDay Years
y Years
m Years
d)
        = forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary Years
y forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary Years
m forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary Years
d

------------------------------------------------------------------------

-- $proleptic
--
-- Note that using the
-- <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian> calendar for
-- dates before its adoption (from 1582 onwards, but varies from one country
-- to the next) produces
-- <https://en.wikipedia.org/wiki/Gregorian_calendar#Proleptic_Gregorian_calendar a proleptic calendar>,
-- which may cause some confusion.

-- | The number of days in a given month in the
-- <https://en.wikipedia.org/wiki/Gregorian_calendar Gregorian> calendar.
--
-- @
-- > 'gregorianMonthLength' 2005 2
-- 28
-- @
{-# INLINE gregorianMonthLength #-}
gregorianMonthLength :: Year -> Month -> Days
gregorianMonthLength :: Years -> Years -> Years
gregorianMonthLength = Bool -> Years -> Years
monthLength forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Years -> Bool
isLeapYear

-- | Add months, with days past the last day of the month clipped to the
-- last day.
--
-- See also 'addGregorianMonthsClip'.
--
-- @
-- > 'gregorianMonthsClip' 1 '$' 'YearMonthDay' 2005 1 30
-- 'YearMonthDay' {'ymdYear' = 2005, 'ymdMonth' = 2, 'ymdDay' = 28}
-- @
{-# INLINEABLE gregorianMonthsClip #-}
gregorianMonthsClip :: Months -> YearMonthDay -> YearMonthDay
gregorianMonthsClip :: Years -> YearMonthDay -> YearMonthDay
gregorianMonthsClip Years
n (YearMonthDay Years
y Years
m Years
d) = Years -> Years -> Years -> YearMonthDay
YearMonthDay Years
y' Years
m'
        forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min (Years -> Years -> Years
gregorianMonthLength Years
y' Years
m') Years
d where
    (forall a. Num a => a -> a -> a
(+) Years
y -> Years
y', forall a. Num a => a -> a -> a
(+) Years
1 -> Years
m') = forall a. Integral a => a -> a -> (a, a)
divMod (Years
m forall a. Num a => a -> a -> a
+ Years
n forall a. Num a => a -> a -> a
- Years
1) Years
12

-- | Add months, with days past the last day of the month rolling over to
-- the next month.
--
-- See also 'addGregorianMonthsRollover'.
--
-- @
-- > 'gregorianMonthsRollover' 1 $ 'YearMonthDay' 2005 1 30
-- 'YearMonthDay' {'ymdYear' = 2005, 'ymdMonth' = 3, 'ymdDay' = 2}
-- @
{-# ANN gregorianMonthsRollover "HLint: ignore Use if" #-}
{-# INLINEABLE gregorianMonthsRollover #-}
gregorianMonthsRollover :: Months -> YearMonthDay -> YearMonthDay
gregorianMonthsRollover :: Years -> YearMonthDay -> YearMonthDay
gregorianMonthsRollover Years
n (YearMonthDay Years
y Years
m Years
d) = case Years
d forall a. Ord a => a -> a -> Bool
<= Years
len of
    Bool
True -> Years -> Years -> Years -> YearMonthDay
YearMonthDay Years
y' Years
m' Years
d
    Bool
False -> case Years
m' forall a. Ord a => a -> a -> Bool
< Years
12 of
        Bool
True -> Years -> Years -> Years -> YearMonthDay
YearMonthDay Years
y' (Years
m' forall a. Num a => a -> a -> a
+ Years
1) (Years
d forall a. Num a => a -> a -> a
- Years
len)
        Bool
False -> Years -> Years -> Years -> YearMonthDay
YearMonthDay (Years
y' forall a. Num a => a -> a -> a
+ Years
1) Years
1 (Years
d forall a. Num a => a -> a -> a
- Years
len)
  where
    (forall a. Num a => a -> a -> a
(+) Years
y -> Years
y', forall a. Num a => a -> a -> a
(+) Years
1 -> Years
m') = forall a. Integral a => a -> a -> (a, a)
divMod (Years
m forall a. Num a => a -> a -> a
+ Years
n forall a. Num a => a -> a -> a
- Years
1) Years
12
    len :: Years
len = Years -> Years -> Years
gregorianMonthLength Years
y' Years
m'

-- | Add years, matching month and day, with /February 29th/ clipped to the
-- /28th/ if necessary.
--
-- See also 'addGregorianYearsClip'.
--
-- @
-- > 'gregorianYearsClip' 2 $ 'YearMonthDay' 2004 2 29
-- 'YearMonthDay' {'ymdYear' = 2006, 'ymdMonth' = 2, 'ymdDay' = 28}
-- @
{-# INLINEABLE gregorianYearsClip #-}
gregorianYearsClip :: Years -> YearMonthDay -> YearMonthDay
gregorianYearsClip :: Years -> YearMonthDay -> YearMonthDay
gregorianYearsClip Years
n (YearMonthDay (forall a. Num a => a -> a -> a
(+) Years
n -> Years
y') Years
2 Years
29)
    | Bool -> Bool
not (Years -> Bool
isLeapYear Years
y') = Years -> Years -> Years -> YearMonthDay
YearMonthDay Years
y' Years
2 Years
28
gregorianYearsClip Years
n (YearMonthDay Years
y Years
m Years
d) = Years -> Years -> Years -> YearMonthDay
YearMonthDay (Years
y forall a. Num a => a -> a -> a
+ Years
n) Years
m Years
d

-- | Add years, matching month and day, with /February 29th/ rolled over to
-- /March 1st/ if necessary.
--
-- See also 'addGregorianYearsRollover'.
--
-- @
-- > 'gregorianYearsRollover' 2 $ 'YearMonthDay' 2004 2 29
-- 'YearMonthDay' {'ymdYear' = 2006, 'ymdMonth' = 3, 'ymdDay' = 1}
-- @
{-# INLINEABLE gregorianYearsRollover #-}
gregorianYearsRollover :: Years -> YearMonthDay -> YearMonthDay
gregorianYearsRollover :: Years -> YearMonthDay -> YearMonthDay
gregorianYearsRollover Years
n (YearMonthDay (forall a. Num a => a -> a -> a
(+) Years
n -> Years
y') Years
2 Years
29)
    | Bool -> Bool
not (Years -> Bool
isLeapYear Years
y') = Years -> Years -> Years -> YearMonthDay
YearMonthDay Years
y' Years
3 Years
1
gregorianYearsRollover Years
n (YearMonthDay Years
y Years
m Years
d) = Years -> Years -> Years -> YearMonthDay
YearMonthDay (Years
y forall a. Num a => a -> a -> a
+ Years
n) Years
m Years
d

-- * Compatibility

-- | Add some 'Days' to a calendar 'Day' to get a new 'Day'.
--
-- @
-- 'addDays' = 'flip' ('.+^')
-- 'addDays' n d ≡ d '.+^' n
-- @
--
-- See also the 'AffineSpace' instance for 'Day'.
{-# INLINE addDays #-}
addDays :: Days -> Day -> Day
addDays :: Years -> Day -> Day
addDays = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall p. AffineSpace p => p -> Diff p -> p
(.+^)

-- | Subtract two calendar 'Day's for the difference in 'Days'.
--
-- @
-- 'diffDays' = ('.-.')
-- 'diffDays' a b = a '.-.' b
-- @
--
-- See also the 'AffineSpace' instance for 'Day'.
{-# INLINE diffDays #-}
diffDays :: Day -> Day -> Days
diffDays :: Day -> Day -> Years
diffDays = forall p. AffineSpace p => p -> p -> Diff p
(.-.)

-- | Convert a 'Day' to its Gregorian 'Year', 'Month', and 'DayOfMonth'.
--
-- @
-- 'toGregorian' ('view' 'gregorian' -> 'YearMonthDay' y m d) = (y, m, d)
-- @
{-# INLINE toGregorian #-}
toGregorian :: Day -> (Year, Month, DayOfMonth)
toGregorian :: Day -> (Years, Years, Years)
toGregorian (forall a s. Getting a s a -> s -> a
view Iso' Day YearMonthDay
gregorian -> YearMonthDay Years
y Years
m Years
d) = (Years
y, Years
m, Years
d)

-- | Construct a 'Day' from a Gregorian calendar date.
-- Does not validate the input.
--
-- @
-- 'fromGregorian' y m d = 'gregorian' 'Control.Lens.#' 'YearMonthDay' y m d
-- @
{-# INLINE fromGregorian #-}
fromGregorian :: Year -> Month -> DayOfMonth -> Day
fromGregorian :: Years -> Years -> Years -> Day
fromGregorian Years
y Years
m Years
d = Iso' Day YearMonthDay
gregorian forall s t a b. AReview s t a b -> b -> t
# Years -> Years -> Years -> YearMonthDay
YearMonthDay Years
y Years
m Years
d

-- | Construct a 'Day' from a Gregorian calendar date.
-- Returns 'Nothing' for invalid input.
--
-- @
-- 'fromGregorianValid' y m d = 'gregorianValid' ('YearMonthDay' y m d)
-- @
{-# INLINE fromGregorianValid #-}
fromGregorianValid :: Year -> Month -> DayOfMonth -> Maybe Day
fromGregorianValid :: Years -> Years -> Years -> Maybe Day
fromGregorianValid Years
y Years
m Years
d = YearMonthDay -> Maybe Day
gregorianValid (Years -> Years -> Years -> YearMonthDay
YearMonthDay Years
y Years
m Years
d)

-- | Add some number of 'Months' to the given 'Day'; if the original
-- 'DayOfMonth' exceeds that of the new 'Month', it will be clipped to the
-- last day of the new 'Month'.
--
-- @
-- 'addGregorianMonthsClip' n = 'gregorian' '%~' 'gregorianMonthsClip' n
-- @
{-# INLINE addGregorianMonthsClip #-}
addGregorianMonthsClip :: Months -> Day -> Day
addGregorianMonthsClip :: Years -> Day -> Day
addGregorianMonthsClip Years
n = Iso' Day YearMonthDay
gregorian forall s t a b. Setter s t a b -> (a -> b) -> s -> t
%~ Years -> YearMonthDay -> YearMonthDay
gregorianMonthsClip Years
n

-- | Add some number of 'Months' to the given 'Day'; if the original
-- 'DayOfMonth' exceeds that of the new 'Month', it will be rolled over into
-- the following 'Month'.
--
-- @
-- 'addGregorianMonthsRollover' n = 'gregorian' '%~' 'gregorianMonthsRollover' n
-- @
{-# INLINE addGregorianMonthsRollover #-}
addGregorianMonthsRollover :: Months -> Day -> Day
addGregorianMonthsRollover :: Years -> Day -> Day
addGregorianMonthsRollover Years
n = Iso' Day YearMonthDay
gregorian forall s t a b. Setter s t a b -> (a -> b) -> s -> t
%~ Years -> YearMonthDay -> YearMonthDay
gregorianMonthsRollover Years
n

-- | Add some number of 'Years' to the given 'Day', with /February 29th/
-- clipped to /February 28th/ if necessary.
--
-- @
-- 'addGregorianYearsClip' n = 'gregorian' '%~' 'gregorianYearsClip' n
-- @
{-# INLINE addGregorianYearsClip #-}
addGregorianYearsClip :: Years -> Day -> Day
addGregorianYearsClip :: Years -> Day -> Day
addGregorianYearsClip Years
n = Iso' Day YearMonthDay
gregorian forall s t a b. Setter s t a b -> (a -> b) -> s -> t
%~ Years -> YearMonthDay -> YearMonthDay
gregorianYearsClip Years
n

-- | Add some number of 'Years' to the given 'Day', with /February 29th/
-- rolled over to /March 1st/ if necessary.
--
-- @
-- 'addGregorianYearsRollover' n = 'gregorian' '%~' 'gregorianYearsRollover' n
-- @
{-# INLINE addGregorianYearsRollover #-}
addGregorianYearsRollover :: Years -> Day -> Day
addGregorianYearsRollover :: Years -> Day -> Day
addGregorianYearsRollover Years
n = Iso' Day YearMonthDay
gregorian forall s t a b. Setter s t a b -> (a -> b) -> s -> t
%~ Years -> YearMonthDay -> YearMonthDay
gregorianYearsRollover Years
n