{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "thyme.h"
#if HLINT
#include "cabal_macros.h"
#endif
module Data.Thyme.Calendar
(
Day (..), modifiedJulianDay
, Year, Month, DayOfMonth
, YearMonthDay (..), _ymdYear, _ymdMonth, _ymdDay
, Years, Months, Days
, 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
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
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
{-# 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
{-# 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
{-# 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'
{-# 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
{-# 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
{-# 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
(.+^)
{-# INLINE diffDays #-}
diffDays :: Day -> Day -> Days
diffDays :: Day -> Day -> Years
diffDays = forall p. AffineSpace p => p -> p -> Diff p
(.-.)
{-# 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)
{-# 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
{-# 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)
{-# 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
{-# 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
{-# 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
{-# 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