{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "thyme.h"

-- | '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
    ( Years, Months, Days
    -- * Days
    , Day (..), modifiedJulianDay
    -- * Gregorian calendar
    , Year, Month, DayOfMonth
    , YearMonthDay (..)
    , isLeapYear
    , yearMonthDay, gregorian, gregorianValid, showGregorian
    , module Data.Thyme.Calendar
    ) where

import Prelude hiding ((.))
import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Lens
import Control.Monad
import Data.AdditiveGroup
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 = UTCTime
forall a. Bounded a => a
minBound UTCTime -> Getting Day UTCTime Day -> Day
forall s a. s -> Getting a s a -> a
^. Getting Day UTCTime Day
Lens' UTCTime Day
_utctDay
    maxBound :: Day
maxBound = UTCTime
forall a. Bounded a => a
maxBound UTCTime -> Getting Day UTCTime Day -> Day
forall s a. s -> Getting a s a -> a
^. Getting Day UTCTime Day
Lens' UTCTime Day
_utctDay

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

instance Random Day where
    randomR :: (Day, Day) -> g -> (Day, g)
randomR r :: (Day, Day)
r = (UTCTime -> Day) -> (UTCTime, g) -> (Day, g)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (UTCTime -> Getting Day UTCTime Day -> Day
forall s a. s -> Getting a s a -> a
^. Getting Day UTCTime Day
Lens' UTCTime Day
_utctDay) ((UTCTime, g) -> (Day, g)) -> (g -> (UTCTime, g)) -> g -> (Day, g)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (UTCTime, UTCTime) -> g -> (UTCTime, g)
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 (Day -> UTCTime)
-> (Day -> UTCTime) -> (Day, Day) -> (UTCTime, UTCTime)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** UTCTime -> UTCTime
forall a. Enum a => a -> a
pred (UTCTime -> UTCTime) -> (Day -> UTCTime) -> Day -> UTCTime
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 (Day -> UTCTime) -> (Day -> Day) -> Day -> UTCTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Day -> Day
forall a. Enum a => a -> a
succ
        toMidnight :: Day -> UTCTime
toMidnight = (Overloaded Reviewed Identity UTCTime UTCTime UTCView UTCView
Iso' UTCTime UTCView
utcTime Overloaded Reviewed Identity UTCTime UTCTime UTCView UTCView
-> UTCView -> UTCTime
forall s t a b. AReview s t a b -> b -> t
#) (UTCView -> UTCTime) -> (Day -> UTCView) -> Day -> UTCTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Day -> DiffTime -> UTCView) -> DiffTime -> Day -> UTCView
forall a b c. (a -> b -> c) -> b -> a -> c
flip Day -> DiffTime -> UTCView
UTCTime DiffTime
forall v. AdditiveGroup v => v
zeroV
    random :: g -> (Day, g)
random = (Day, Day) -> g -> (Day, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Day
forall a. Bounded a => a
minBound, Day
forall a. Bounded a => a
maxBound)

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

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

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

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

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

{-# INLINE gregorianMonthLength #-}
gregorianMonthLength :: Year -> Month -> Days
gregorianMonthLength :: Int -> Int -> Int
gregorianMonthLength = Bool -> Int -> Int
monthLength (Bool -> Int -> Int) -> (Int -> Bool) -> Int -> Int -> Int
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> Bool
isLeapYear

{-# INLINEABLE gregorianMonthsClip #-}
gregorianMonthsClip :: Months -> YearMonthDay -> YearMonthDay
gregorianMonthsClip :: Int -> YearMonthDay -> YearMonthDay
gregorianMonthsClip n :: Int
n (YearMonthDay y :: Int
y m :: Int
m d :: Int
d) = Int -> Int -> Int -> YearMonthDay
YearMonthDay Int
y' Int
m'
        (Int -> YearMonthDay) -> Int -> YearMonthDay
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int -> Int -> Int
gregorianMonthLength Int
y' Int
m') Int
d where
    (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
y -> Int
y', Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) 1 -> Int
m') = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) 12

{-# ANN gregorianMonthsRollover "HLint: ignore Use if" #-}
{-# INLINEABLE gregorianMonthsRollover #-}
gregorianMonthsRollover :: Months -> YearMonthDay -> YearMonthDay
gregorianMonthsRollover :: Int -> YearMonthDay -> YearMonthDay
gregorianMonthsRollover n :: Int
n (YearMonthDay y :: Int
y m :: Int
m d :: Int
d) = case Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len of
    True -> Int -> Int -> Int -> YearMonthDay
YearMonthDay Int
y' Int
m' Int
d
    False -> case Int
m' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 12 of
        True -> Int -> Int -> Int -> YearMonthDay
YearMonthDay Int
y' (Int
m' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len)
        False -> Int -> Int -> Int -> YearMonthDay
YearMonthDay (Int
y' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) 1 (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len)
  where
    (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
y -> Int
y', Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) 1 -> Int
m') = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) 12
    len :: Int
len = Int -> Int -> Int
gregorianMonthLength Int
y' Int
m'

{-# INLINEABLE gregorianYearsClip #-}
gregorianYearsClip :: Years -> YearMonthDay -> YearMonthDay
gregorianYearsClip :: Int -> YearMonthDay -> YearMonthDay
gregorianYearsClip n :: Int
n (YearMonthDay (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
n -> Int
y') 2 29)
    | Bool -> Bool
not (Int -> Bool
isLeapYear Int
y') = Int -> Int -> Int -> YearMonthDay
YearMonthDay Int
y' 2 28
gregorianYearsClip n :: Int
n (YearMonthDay y :: Int
y m :: Int
m d :: Int
d) = Int -> Int -> Int -> YearMonthDay
YearMonthDay (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int
m Int
d

{-# INLINEABLE gregorianYearsRollover #-}
gregorianYearsRollover :: Years -> YearMonthDay -> YearMonthDay
gregorianYearsRollover :: Int -> YearMonthDay -> YearMonthDay
gregorianYearsRollover n :: Int
n (YearMonthDay (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
n -> Int
y') 2 29)
    | Bool -> Bool
not (Int -> Bool
isLeapYear Int
y') = Int -> Int -> Int -> YearMonthDay
YearMonthDay Int
y' 3 1
gregorianYearsRollover n :: Int
n (YearMonthDay y :: Int
y m :: Int
m d :: Int
d) = Int -> Int -> Int -> YearMonthDay
YearMonthDay (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Int
m Int
d

-- * Lenses
LENS(YearMonthDay,ymdYear,Year)
LENS(YearMonthDay,ymdMonth,Month)
LENS(YearMonthDay,ymdDay,DayOfMonth)