{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
#if SHOW_INTERNAL
{-# LANGUAGE StandaloneDeriving #-}
#endif
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_HADDOCK hide #-}

#include "thyme.h"

module Data.Thyme.Calendar.Internal where

import Prelude
import Control.Applicative
import Control.Arrow
import Control.DeepSeq
import Control.Lens
import Control.Monad
import Data.AffineSpace
import Data.Bits
import Data.Data
import Data.Int
import Data.Ix
import Data.Thyme.Format.Internal
#if __GLASGOW_HASKELL__ == 704
import qualified Data.Vector.Generic
import qualified Data.Vector.Generic.Mutable
#endif
import qualified Data.Vector.Unboxed as VU
import Data.Vector.Unboxed.Deriving
import GHC.Generics (Generic)
import System.Random
import Test.QuickCheck hiding ((.&.))

type Years = Int
type Months = Int
type Days = Int

-- | The Modified Julian Day is a standard count of days, with zero being
-- the day 1858-11-17.
newtype Day = ModifiedJulianDay
    { Day -> Int
toModifiedJulianDay :: Int
    } deriving (INSTANCES_NEWTYPE, CoArbitrary)

instance AffineSpace Day where
    type Diff Day = Days
    {-# INLINE (.-.) #-}
    .-. :: Day -> Day -> Diff Day
(.-.) = \ (ModifiedJulianDay a :: Int
a) (ModifiedJulianDay b :: Int
b) -> Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b
    {-# INLINE (.+^) #-}
    .+^ :: Day -> Diff Day -> Day
(.+^) = \ (ModifiedJulianDay a :: Int
a) d :: Diff Day
d -> Int -> Day
ModifiedJulianDay (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
Diff Day
d)

{-# INLINE modifiedJulianDay #-}
modifiedJulianDay :: Iso' Day Int
modifiedJulianDay :: Overloaded p f Day Day Int Int
modifiedJulianDay = (Day -> Int) -> (Int -> Day) -> Iso Day Day Int Int
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Day -> Int
toModifiedJulianDay Int -> Day
ModifiedJulianDay

{-# INLINE yearMonthDay #-}
yearMonthDay :: Iso' OrdinalDate YearMonthDay
yearMonthDay :: Overloaded p f OrdinalDate OrdinalDate YearMonthDay YearMonthDay
yearMonthDay = (OrdinalDate -> YearMonthDay)
-> (YearMonthDay -> OrdinalDate)
-> Iso OrdinalDate OrdinalDate YearMonthDay YearMonthDay
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso OrdinalDate -> YearMonthDay
fromOrdinal YearMonthDay -> OrdinalDate
toOrdinal where

    {-# INLINEABLE fromOrdinal #-}
    fromOrdinal :: OrdinalDate -> YearMonthDay
    fromOrdinal :: OrdinalDate -> YearMonthDay
fromOrdinal (OrdinalDate y :: Int
y yd :: Int
yd) = Int -> Int -> Int -> YearMonthDay
YearMonthDay Int
y Int
m Int
d where
        MonthDay m :: Int
m d :: Int
d = Int
yd Int -> Getting MonthDay Int MonthDay -> MonthDay
forall s a. s -> Getting a s a -> a
^. Bool -> Iso' Int MonthDay
monthDay (Int -> Bool
isLeapYear Int
y)

    {-# INLINEABLE toOrdinal #-}
    toOrdinal :: YearMonthDay -> OrdinalDate
    toOrdinal :: YearMonthDay -> OrdinalDate
toOrdinal (YearMonthDay y :: Int
y m :: Int
m d :: Int
d) = Int -> Int -> OrdinalDate
OrdinalDate Int
y (Int -> OrdinalDate) -> Int -> OrdinalDate
forall a b. (a -> b) -> a -> b
$
        Bool -> Iso' Int MonthDay
monthDay (Int -> Bool
isLeapYear Int
y) Overloaded Reviewed Identity Int Int MonthDay MonthDay
-> MonthDay -> Int
forall s t a b. AReview s t a b -> b -> t
# Int -> Int -> MonthDay
MonthDay Int
m Int
d

{-# INLINE gregorian #-}
gregorian :: Iso' Day YearMonthDay
gregorian :: Overloaded p f Day Day YearMonthDay YearMonthDay
gregorian = Overloaded p f Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate Overloaded p f Day Day OrdinalDate OrdinalDate
-> (p YearMonthDay (f YearMonthDay)
    -> p OrdinalDate (f OrdinalDate))
-> Overloaded p f Day Day YearMonthDay YearMonthDay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p YearMonthDay (f YearMonthDay) -> p OrdinalDate (f OrdinalDate)
Iso OrdinalDate OrdinalDate YearMonthDay YearMonthDay
yearMonthDay

{-# INLINEABLE gregorianValid #-}
gregorianValid :: YearMonthDay -> Maybe Day
gregorianValid :: YearMonthDay -> Maybe Day
gregorianValid (YearMonthDay y :: Int
y m :: Int
m d :: Int
d) = AReview Day Day OrdinalDate OrdinalDate -> OrdinalDate -> Day
forall s t a b. AReview s t a b -> b -> t
review AReview Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate (OrdinalDate -> Day) -> (Int -> OrdinalDate) -> Int -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> OrdinalDate
OrdinalDate Int
y
    (Int -> Day) -> Maybe Int -> Maybe Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> MonthDay -> Maybe Int
monthDayValid (Int -> Bool
isLeapYear Int
y) (Int -> Int -> MonthDay
MonthDay Int
m Int
d)

{-# INLINEABLE showGregorian #-}
showGregorian :: Day -> String
showGregorian :: Day -> String
showGregorian (Getting YearMonthDay Day YearMonthDay -> Day -> YearMonthDay
forall a s. Getting a s a -> s -> a
view Getting YearMonthDay Day YearMonthDay
Iso' Day YearMonthDay
gregorian -> YearMonthDay y :: Int
y m :: Int
m d :: Int
d) =
    Int -> ShowS
showsYear Int
y ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) '-' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
shows02 Int
m ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) '-' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
shows02 Int
d ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ""

#if SHOW_INTERNAL
deriving instance Show Day
#else
instance Show Day where show :: Day -> String
show = Day -> String
showGregorian
#endif

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

type Year = Int
type Month = Int
type DayOfMonth = Int

data YearMonthDay = YearMonthDay
    { YearMonthDay -> Int
ymdYear :: {-# UNPACK #-}!Year
    , YearMonthDay -> Int
ymdMonth :: {-# UNPACK #-}!Month
    , YearMonthDay -> Int
ymdDay :: {-# UNPACK #-}!DayOfMonth
    } deriving (INSTANCES_USUAL, Show)

instance NFData YearMonthDay

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

-- | Gregorian leap year?
isLeapYear :: Year -> Bool
isLeapYear :: Int -> Bool
isLeapYear y :: Int
y = Int
y Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& (Int
r100 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 Bool -> Bool -> Bool
|| Int
q100 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) where
    (q100 :: Int
q100, r100 :: Int
r100) = Int
y Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 100

type DayOfYear = Int
data OrdinalDate = OrdinalDate
    { OrdinalDate -> Int
odYear :: {-# UNPACK #-}!Year
    , OrdinalDate -> Int
odDay :: {-# UNPACK #-}!DayOfYear
    } deriving (INSTANCES_USUAL, Show)

instance NFData OrdinalDate

-- Brief description of the toOrdinal computation.
--
-- The length of the years in Gregorian calendar is periodic with
-- period of 400 years. There are 100 - 4 + 1 = 97 leap years in a
-- period, so the average length of a year is 365 + 97/400 =
-- 146097/400 days.
--
-- Now, if you consider these -- let's call them nominal -- years,
-- then for any point in time, for any linear day number we can
-- determine which nominal year does it fall into by a single
-- division. Moreover, if we align the start of the calendar year 1
-- with the start of the nominal year 1, then the calendar years and
-- nominal years never get too much out of sync. Specifically:
--
--  * start of the first day of a calendar year might fall into the
--    preceding nominal year, but never more than by 1.5 days (591/400
--    days, to be precise)
--  * the start of the last day of a calendar year always falls into
--    its nominal year (even for the leap years).
--
-- So, to find out the calendar year for a given day, we calculate
-- which nominal year does its start fall. And, if we are not too
-- close to the end of year, we have the right calendar
-- year. Othewise, we just check whether it falls within the next
-- calendar year.
--
-- Notes: to make the reasoning simpler and more efficient ('quot' is
-- faster than 'div') we do the computation directly only for positive
-- years (days after 1-1-1). For earlier dates we "transate" by an
-- integral number of 400 year periods, do the computation and
-- translate back.

{-# INLINE ordinalDate #-}
ordinalDate :: Iso' Day OrdinalDate
ordinalDate :: Overloaded p f Day Day OrdinalDate OrdinalDate
ordinalDate = (Day -> OrdinalDate)
-> (OrdinalDate -> Day) -> Iso' Day OrdinalDate
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Day -> OrdinalDate
toOrd OrdinalDate -> Day
fromOrd where

    {-# INLINEABLE toOrd #-}
    toOrd :: Day -> OrdinalDate
    toOrd :: Day -> OrdinalDate
toOrd (ModifiedJulianDay mjd :: Int
mjd)
      | Int
dayB0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = case Int -> OrdinalDate
toOrdB0 Int
dayInQC of
        OrdinalDate y :: Int
y yd :: Int
yd -> Int -> Int -> OrdinalDate
OrdinalDate (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
quadCent Int -> Int -> Int
forall a. Num a => a -> a -> a
* 400) Int
yd
      | Bool
otherwise = Int -> OrdinalDate
toOrdB0 Int
dayB0
      where
        dayB0 :: Int
dayB0 = Int
mjd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 678575
        (quadCent :: Int
quadCent, dayInQC :: Int
dayInQC) = Int
dayB0 Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` 146097

    -- Input: days since 1-1-1. Precondition: has to be positive!
    {-# INLINE toOrdB0 #-}
    toOrdB0 :: Int -> OrdinalDate
    toOrdB0 :: Int -> OrdinalDate
toOrdB0 dayB0 :: Int
dayB0 = OrdinalDate
res
      where
        (y0 :: Int
y0, r :: Int
r) = (400 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
dayB0) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 146097
        d0 :: Int
d0 = Int -> Int -> Int
dayInYear Int
y0 Int
dayB0
        d1 :: Int
d1 = Int -> Int -> Int
dayInYear (Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int
dayB0
        res :: OrdinalDate
res = if Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 146097 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 600 Bool -> Bool -> Bool
&& Int
d1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
              then Int -> Int -> OrdinalDate
OrdinalDate (Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int
d1
              else Int -> Int -> OrdinalDate
OrdinalDate (Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int
d0

    -- Input: (year - 1) (day as days since 1-1-1)
    -- Precondition: year is positive!
    {-# INLINE dayInYear #-}
    dayInYear :: Int -> Int -> Int
    dayInYear :: Int -> Int -> Int
dayInYear y0 :: Int
y0 dayB0 :: Int
dayB0 = Int
dayB0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 365 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leaps Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
      where
        leaps :: Int
leaps = Int
y0 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
centuries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
centuries Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` 2
        centuries :: Int
centuries = Int
y0 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` 100

    {-# INLINEABLE fromOrd #-}
    fromOrd :: OrdinalDate -> Day
    fromOrd :: OrdinalDate -> Day
fromOrd (OrdinalDate year :: Int
year yd :: Int
yd) = Int -> Day
ModifiedJulianDay Int
mjd where
        years :: Int
years = Int
year Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
        centuries :: Int
centuries = Int
years Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 100
        leaps :: Int
leaps = Int
years Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
centuries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
centuries Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` 2
        mjd :: Int
mjd = 365 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
years Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
leaps Int -> Int -> Int
forall a. Num a => a -> a -> a
- 678576
            Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int -> Int
forall c. Ord c => c -> c -> c -> c
clip 1 (if Int -> Bool
isLeapYear Int
year then 366 else 365) Int
yd
        clip :: c -> c -> c -> c
clip a :: c
a b :: c
b = c -> c -> c
forall a. Ord a => a -> a -> a
max c
a (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> c -> c
forall a. Ord a => a -> a -> a
min c
b

------------------------------------------------------------------------
-- Lookup tables for Data.Thyme.Calendar.MonthDay

{-# NOINLINE monthLengths #-}
{-# NOINLINE monthLengthsLeap #-}
monthLengths, monthLengthsLeap :: VU.Vector Days
monthLengths :: Vector Int
monthLengths     = [Int] -> Vector Int
forall a. Unbox a => [a] -> Vector a
VU.fromList [31,28,31,30,31,30,31,31,30,31,30,31]
monthLengthsLeap :: Vector Int
monthLengthsLeap = [Int] -> Vector Int
forall a. Unbox a => [a] -> Vector a
VU.fromList [31,29,31,30,31,30,31,31,30,31,30,31]
                            -- J  F  M  A  M  J  J  A  S  O  N  D

{-# ANN monthDays "HLint: ignore Use fromMaybe" #-}
{-# NOINLINE monthDays #-}
monthDays :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8)
monthDays :: Vector (Int8, Int8)
monthDays = Int -> (Int -> (Int8, Int8)) -> Vector (Int8, Int8)
forall a. Unbox a => Int -> (Int -> a) -> Vector a
VU.generate 365 Int -> (Int8, Int8)
forall a b. (Num a, Num b) => Int -> (a, b)
go where
    dom01 :: Vector Int
dom01 = (Int -> Int -> Int) -> Int -> Vector Int -> Vector Int
forall a b.
(Unbox a, Unbox b) =>
(a -> b -> a) -> a -> Vector b -> Vector a
VU.prescanl' Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) 0 Vector Int
monthLengths
    go :: Int -> (a, b)
go yd :: Int
yd = (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m, Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d) where
        m :: Int
m = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 12 Int -> Int
forall a. a -> a
id (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> Vector Int -> Maybe Int
forall a. Unbox a => (a -> Bool) -> Vector a -> Maybe Int
VU.findIndex (Int
yd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<) Vector Int
dom01
        d :: Int
d = Int -> Int
forall a. Enum a => a -> a
succ Int
yd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
VU.unsafeIndex Vector Int
dom01 (Int -> Int
forall a. Enum a => a -> a
pred Int
m)

{-# ANN monthDaysLeap "HLint: ignore Use fromMaybe" #-}
{-# NOINLINE monthDaysLeap #-}
monthDaysLeap :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8)
monthDaysLeap :: Vector (Int8, Int8)
monthDaysLeap = Int -> (Int -> (Int8, Int8)) -> Vector (Int8, Int8)
forall a. Unbox a => Int -> (Int -> a) -> Vector a
VU.generate 366 Int -> (Int8, Int8)
forall a b. (Num a, Num b) => Int -> (a, b)
go where
    dom01 :: Vector Int
dom01 = (Int -> Int -> Int) -> Int -> Vector Int -> Vector Int
forall a b.
(Unbox a, Unbox b) =>
(a -> b -> a) -> a -> Vector b -> Vector a
VU.prescanl' Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) 0 Vector Int
monthLengthsLeap
    go :: Int -> (a, b)
go yd :: Int
yd = (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m, Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d) where
        m :: Int
m = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 12 Int -> Int
forall a. a -> a
id (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> Vector Int -> Maybe Int
forall a. Unbox a => (a -> Bool) -> Vector a -> Maybe Int
VU.findIndex (Int
yd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<) Vector Int
dom01
        d :: Int
d = Int -> Int
forall a. Enum a => a -> a
succ Int
yd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
VU.unsafeIndex Vector Int
dom01 (Int -> Int
forall a. Enum a => a -> a
pred Int
m)

-- | No good home for this within the current hierarchy. This will do.
{-# INLINEABLE randomIsoR #-}
randomIsoR :: (Random s, RandomGen g) => Iso' s a -> (a, a) -> g -> (a, g)
randomIsoR :: Iso' s a -> (a, a) -> g -> (a, g)
randomIsoR l :: Iso' s a
l (x :: a
x, y :: a
y) = (s -> a) -> (s, g) -> (a, g)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (s -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^. Getting a s a
Iso' s a
l) ((s, g) -> (a, g)) -> (g -> (s, g)) -> g -> (a, g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s, s) -> g -> (s, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Overloaded Reviewed Identity s s a a
Iso' s a
l Overloaded Reviewed Identity s s a a -> a -> s
forall s t a b. AReview s t a b -> b -> t
# a
x, Overloaded Reviewed Identity s s a a
Iso' s a
l Overloaded Reviewed Identity s s a a -> a -> s
forall s t a b. AReview s t a b -> b -> t
# a
y)

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

data MonthDay = MonthDay
    { MonthDay -> Int
mdMonth :: {-# UNPACK #-}!Month
    , MonthDay -> Int
mdDay :: {-# UNPACK #-}!DayOfMonth
    } deriving (INSTANCES_USUAL, Show)

instance NFData MonthDay

instance Bounded MonthDay where
    minBound :: MonthDay
minBound = Int -> Int -> MonthDay
MonthDay 1 1
    maxBound :: MonthDay
maxBound = Int -> Int -> MonthDay
MonthDay 12 31

instance Random MonthDay where
    randomR :: (MonthDay, MonthDay) -> g -> (MonthDay, g)
randomR r :: (MonthDay, MonthDay)
r g :: g
g = Iso' Int MonthDay -> (MonthDay, MonthDay) -> g -> (MonthDay, g)
forall s g a.
(Random s, RandomGen g) =>
Iso' s a -> (a, a) -> g -> (a, g)
randomIsoR (Bool -> Iso' Int MonthDay
monthDay Bool
leap) (MonthDay, MonthDay)
r g
g' where
        (Int -> Bool
isLeapYear -> Bool
leap, g' :: g
g') = g -> (Int, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
g
    random :: g -> (MonthDay, g)
random = (MonthDay, MonthDay) -> g -> (MonthDay, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (MonthDay
forall a. Bounded a => a
minBound, MonthDay
forall a. Bounded a => a
maxBound)

instance Arbitrary MonthDay where
    arbitrary :: Gen MonthDay
arbitrary = (MonthDay, MonthDay) -> Gen MonthDay
forall a. Random a => (a, a) -> Gen a
choose (MonthDay
forall a. Bounded a => a
minBound, MonthDay
forall a. Bounded a => a
maxBound)
    shrink :: MonthDay -> [MonthDay]
shrink md :: MonthDay
md = Getting MonthDay Int MonthDay -> Int -> MonthDay
forall a s. Getting a s a -> s -> a
view (Bool -> Iso' Int MonthDay
monthDay Bool
True) (Int -> MonthDay) -> [Int] -> [MonthDay]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink (Bool -> Iso' Int MonthDay
monthDay Bool
True Overloaded Reviewed Identity Int Int MonthDay MonthDay
-> MonthDay -> Int
forall s t a b. AReview s t a b -> b -> t
# MonthDay
md)

instance CoArbitrary MonthDay where
    coarbitrary :: MonthDay -> Gen b -> Gen b
coarbitrary (MonthDay m :: Int
m d :: Int
d) = 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 b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary Int
d

-- | Convert between day of year in the Gregorian or Julian calendars, and
-- month and day of month. First arg is leap year flag.
{-# INLINE monthDay #-}
monthDay :: Bool -> Iso' DayOfYear MonthDay
monthDay :: Bool -> Iso' Int MonthDay
monthDay leap :: Bool
leap = (Int -> MonthDay) -> (MonthDay -> Int) -> Iso' Int MonthDay
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Int -> MonthDay
fromOrdinal MonthDay -> Int
toOrdinal where
    (lastDay :: Int
lastDay, lengths :: Vector Int
lengths, table :: Vector (Int8, Int8)
table, ok :: Int
ok) = if Bool
leap
        then (365, Vector Int
monthLengthsLeap, Vector (Int8, Int8)
monthDaysLeap, -1)
        else (364, Vector Int
monthLengths, Vector (Int8, Int8)
monthDays, -2)

    {-# INLINE fromOrdinal #-}
    fromOrdinal :: DayOfYear -> MonthDay
    fromOrdinal :: Int -> MonthDay
fromOrdinal (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
lastDay (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
pred -> Int
i) = Int -> Int -> MonthDay
MonthDay Int
m Int
d where
        (Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
m, Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
d) = Vector (Int8, Int8) -> Int -> (Int8, Int8)
forall a. Unbox a => Vector a -> Int -> a
VU.unsafeIndex Vector (Int8, Int8)
table Int
i

    {-# INLINE toOrdinal #-}
    toOrdinal :: MonthDay -> DayOfYear
    toOrdinal :: MonthDay -> Int
toOrdinal (MonthDay month :: Int
month day :: Int
day) = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (367 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- 362) 12 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d where
        m :: Int
m = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min 12 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
month
        l :: Int
l = Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
VU.unsafeIndex Vector Int
lengths (Int -> Int
forall a. Enum a => a -> a
pred Int
m)
        d :: Int
d = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
l (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
day
        k :: Int
k = if Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 2 then 0 else Int
ok

{-# INLINEABLE monthDayValid #-}
monthDayValid :: Bool -> MonthDay -> Maybe DayOfYear
monthDayValid :: Bool -> MonthDay -> Maybe Int
monthDayValid leap :: Bool
leap md :: MonthDay
md@(MonthDay m :: Int
m d :: Int
d) = Bool -> Iso' Int MonthDay
monthDay Bool
leap Overloaded Reviewed Identity Int Int MonthDay MonthDay
-> MonthDay -> Int
forall s t a b. AReview s t a b -> b -> t
# MonthDay
md
    Int -> Maybe () -> Maybe Int
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
m Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 12 Bool -> Bool -> Bool
&& 1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
d Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Bool -> Int -> Int
monthLength Bool
leap Int
m)

{-# INLINEABLE monthLength #-}
monthLength :: Bool -> Month -> Days
monthLength :: Bool -> Int -> Int
monthLength leap :: Bool
leap = Vector Int -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
VU.unsafeIndex Vector Int
ls (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min 11 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
pred where
    ls :: Vector Int
ls = if Bool
leap then Vector Int
monthLengthsLeap else Vector Int
monthLengths

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

type WeekOfYear = Int
type DayOfWeek = Int

-- | Weeks numbered 01 to 53, where week 01 is the first week that has at
-- least 4 days in the new year. Days before week 01 are considered to
-- belong to the previous year.
data WeekDate = WeekDate
    { WeekDate -> Int
wdYear :: {-# UNPACK #-}!Year
    , WeekDate -> Int
wdWeek :: {-# UNPACK #-}!WeekOfYear
    , WeekDate -> Int
wdDay :: {-# UNPACK #-}!DayOfWeek
    } deriving (INSTANCES_USUAL, Show)

instance NFData WeekDate

{-# INLINE weekDate #-}
weekDate :: Iso' Day WeekDate
weekDate :: Overloaded p f Day Day WeekDate WeekDate
weekDate = (Day -> WeekDate)
-> (WeekDate -> Day) -> Iso Day Day WeekDate WeekDate
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Day -> WeekDate
toWeek WeekDate -> Day
fromWeek where

    {-# INLINEABLE toWeek #-}
    toWeek :: Day -> WeekDate
    toWeek :: Day -> WeekDate
toWeek = (Day -> Day -> WeekDate) -> Day -> WeekDate
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (OrdinalDate -> Day -> WeekDate
toWeekOrdinal (OrdinalDate -> Day -> WeekDate)
-> (Day -> OrdinalDate) -> Day -> Day -> WeekDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting OrdinalDate Day OrdinalDate -> Day -> OrdinalDate
forall a s. Getting a s a -> s -> a
view Getting OrdinalDate Day OrdinalDate
Iso' Day OrdinalDate
ordinalDate)

    {-# INLINEABLE fromWeek #-}
    fromWeek :: WeekDate -> Day
    fromWeek :: WeekDate -> Day
fromWeek wd :: WeekDate
wd@(WeekDate y :: Int
y _ _) = Int -> WeekDate -> Day
fromWeekLast (Int -> Int
lastWeekOfYear Int
y) WeekDate
wd

{-# INLINE toWeekOrdinal #-}
toWeekOrdinal :: OrdinalDate -> Day -> WeekDate
toWeekOrdinal :: OrdinalDate -> Day -> WeekDate
toWeekOrdinal (OrdinalDate y0 :: Int
y0 yd :: Int
yd) (ModifiedJulianDay mjd :: Int
mjd) =
        Int -> Int -> Int -> WeekDate
WeekDate Int
y1 (Int
w1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int
d7mod Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) where
    -- pilfered and refactored; no idea what foo and bar mean
    d :: Int
d = Int
mjd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2
    (d7div :: Int
d7div, d7mod :: Int
d7mod) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod Int
d 7
    foo :: Year -> {-WeekOfYear-1-}Int
    foo :: Int -> Int
foo y :: Int
y = Day -> Int
bar (Day -> Int) -> Day -> Int
forall a b. (a -> b) -> a -> b
$ AReview Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate AReview Day Day OrdinalDate OrdinalDate -> OrdinalDate -> Day
forall s t a b. AReview s t a b -> b -> t
# Int -> Int -> OrdinalDate
OrdinalDate Int
y 6
    bar :: Day -> {-WeekOfYear-1-}Int
    bar :: Day -> Int
bar (ModifiedJulianDay k :: Int
k) = Int
d7div Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
k 7
    w0 :: Int
w0 = Day -> Int
bar (Day -> Int) -> Day -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Day
ModifiedJulianDay (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
yd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4)
    (y1 :: Int
y1, w1 :: Int
w1) = case Int
w0 of
        -1 -> (Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1, Int -> Int
foo (Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1))
        52 | Int -> Int
foo (Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> (Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, 0)
        _ -> (Int
y0, Int
w0)

{-# INLINE lastWeekOfYear #-}
lastWeekOfYear :: Year -> WeekOfYear
lastWeekOfYear :: Int -> Int
lastWeekOfYear y :: Int
y = if WeekDate -> Int
wdWeek WeekDate
wd Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 53 then 53 else 52 where
    wd :: WeekDate
wd = Int -> Int -> OrdinalDate
OrdinalDate Int
y 365 OrdinalDate -> Getting WeekDate OrdinalDate WeekDate -> WeekDate
forall s a. s -> Getting a s a -> a
^. AnIso Day Day OrdinalDate OrdinalDate
-> Iso OrdinalDate OrdinalDate Day Day
forall s t a b. AnIso s t a b -> Iso b a t s
from AnIso Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate Overloaded (->) (Const WeekDate) OrdinalDate OrdinalDate Day Day
-> ((WeekDate -> Const WeekDate WeekDate)
    -> Day -> Const WeekDate Day)
-> Getting WeekDate OrdinalDate WeekDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WeekDate -> Const WeekDate WeekDate) -> Day -> Const WeekDate Day
Iso Day Day WeekDate WeekDate
weekDate

{-# INLINE fromWeekLast #-}
fromWeekLast :: WeekOfYear -> WeekDate -> Day
fromWeekLast :: Int -> WeekDate -> Day
fromWeekLast wMax :: Int
wMax (WeekDate y :: Int
y w :: Int
w d :: Int
d) = Int -> Day
ModifiedJulianDay Int
mjd where
    -- pilfered and refactored
    ModifiedJulianDay k :: Int
k = AReview Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate AReview Day Day OrdinalDate OrdinalDate -> OrdinalDate -> Day
forall s t a b. AReview s t a b -> b -> t
# Int -> Int -> OrdinalDate
OrdinalDate Int
y 6
    mjd :: Int
mjd = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
k 7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int -> Int
forall c. Ord c => c -> c -> c -> c
clip 1 7 Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int -> Int
forall c. Ord c => c -> c -> c -> c
clip 1 Int
wMax Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* 7
    clip :: c -> c -> c -> c
clip a :: c
a b :: c
b = c -> c -> c
forall a. Ord a => a -> a -> a
max c
a (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> c -> c
forall a. Ord a => a -> a -> a
min c
b

{-# INLINEABLE weekDateValid #-}
weekDateValid :: WeekDate -> Maybe Day
weekDateValid :: WeekDate -> Maybe Day
weekDateValid wd :: WeekDate
wd@(WeekDate (Int -> Int
lastWeekOfYear -> Int
wMax) w :: Int
w d :: Int
d) =
    Int -> WeekDate -> Day
fromWeekLast Int
wMax WeekDate
wd Day -> Maybe () -> Maybe Day
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
d Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 7 Bool -> Bool -> Bool
&& 1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
w Bool -> Bool -> Bool
&& Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
wMax)

{-# INLINEABLE showWeekDate #-}
showWeekDate :: Day -> String
showWeekDate :: Day -> String
showWeekDate (((WeekDate -> Const WeekDate WeekDate)
 -> Day -> Const WeekDate Day)
-> Day -> WeekDate
forall a s. Getting a s a -> s -> a
view (WeekDate -> Const WeekDate WeekDate) -> Day -> Const WeekDate Day
Iso Day Day WeekDate WeekDate
weekDate -> WeekDate y :: Int
y w :: Int
w d :: Int
d) =
    Int -> ShowS
showsYear Int
y ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) "-W" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
shows02 Int
w ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) '-' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
d ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ""

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

-- | Weeks numbered from 0 to 53, starting with the first Sunday of the year
-- as the first day of week 1. The last week of a given year and week 0 of
-- the next both refer to the same week, but not all 'DayOfWeek' are valid.
-- 'Year' coincides with that of 'gregorian'.
data SundayWeek = SundayWeek
    { SundayWeek -> Int
swYear :: {-# UNPACK #-}!Year
    , SundayWeek -> Int
swWeek :: {-# UNPACK #-}!WeekOfYear
    , SundayWeek -> Int
swDay :: {-# UNPACK #-}!DayOfWeek
    } deriving (INSTANCES_USUAL, Show)

instance NFData SundayWeek

{-# INLINE sundayWeek #-}
sundayWeek :: Iso' Day SundayWeek
sundayWeek :: Overloaded p f Day Day SundayWeek SundayWeek
sundayWeek = (Day -> SundayWeek)
-> (SundayWeek -> Day) -> Iso Day Day SundayWeek SundayWeek
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Day -> SundayWeek
toSunday SundayWeek -> Day
fromSunday where

    {-# INLINEABLE toSunday #-}
    toSunday :: Day -> SundayWeek
    toSunday :: Day -> SundayWeek
toSunday = (Day -> Day -> SundayWeek) -> Day -> SundayWeek
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (OrdinalDate -> Day -> SundayWeek
toSundayOrdinal (OrdinalDate -> Day -> SundayWeek)
-> (Day -> OrdinalDate) -> Day -> Day -> SundayWeek
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting OrdinalDate Day OrdinalDate -> Day -> OrdinalDate
forall a s. Getting a s a -> s -> a
view Getting OrdinalDate Day OrdinalDate
Iso' Day OrdinalDate
ordinalDate)

    {-# INLINEABLE fromSunday #-}
    fromSunday :: SundayWeek -> Day
    fromSunday :: SundayWeek -> Day
fromSunday (SundayWeek y :: Int
y w :: Int
w d :: Int
d) = Int -> Day
ModifiedJulianDay (Int
firstDay Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yd) where
        ModifiedJulianDay firstDay :: Int
firstDay = AReview Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate AReview Day Day OrdinalDate OrdinalDate -> OrdinalDate -> Day
forall s t a b. AReview s t a b -> b -> t
# Int -> Int -> OrdinalDate
OrdinalDate Int
y 1
        -- following are all 0-based year days
        firstSunday :: Int
firstSunday = Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstDay) 7
        yd :: Int
yd = Int
firstSunday Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 7 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d

{-# INLINE toSundayOrdinal #-}
toSundayOrdinal :: OrdinalDate -> Day -> SundayWeek
toSundayOrdinal :: OrdinalDate -> Day -> SundayWeek
toSundayOrdinal (OrdinalDate y :: Int
y yd :: Int
yd) (ModifiedJulianDay mjd :: Int
mjd) =
        Int -> Int -> Int -> SundayWeek
SundayWeek Int
y (Int
d7div Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
k 7) Int
d7mod where
    d :: Int
d = Int
mjd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3
    k :: Int
k = Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
yd
    (d7div :: Int
d7div, d7mod :: Int
d7mod) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod Int
d 7

{-# INLINEABLE sundayWeekValid #-}
sundayWeekValid :: SundayWeek -> Maybe Day
sundayWeekValid :: SundayWeek -> Maybe Day
sundayWeekValid (SundayWeek y :: Int
y w :: Int
w d :: Int
d) = Int -> Day
ModifiedJulianDay (Int
firstDay Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yd)
        Day -> Maybe () -> Maybe Day
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
d Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 6 Bool -> Bool -> Bool
&& 0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
yd Bool -> Bool -> Bool
&& Int
yd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lastDay) where
    ModifiedJulianDay firstDay :: Int
firstDay = AReview Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate AReview Day Day OrdinalDate OrdinalDate -> OrdinalDate -> Day
forall s t a b. AReview s t a b -> b -> t
# Int -> Int -> OrdinalDate
OrdinalDate Int
y 1
    -- following are all 0-based year days
    firstSunday :: Int
firstSunday = Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstDay) 7
    yd :: Int
yd = Int
firstSunday Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 7 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d
    lastDay :: Int
lastDay = if Int -> Bool
isLeapYear Int
y then 365 else 364

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

-- | Weeks numbered from 0 to 53, starting with the first Monday of the year
-- as the first day of week 1. The last week of a given year and week 0 of
-- the next both refer to the same week, but not all 'DayOfWeek' are valid.
-- 'Year' coincides with that of 'gregorian'.
data MondayWeek = MondayWeek
    { MondayWeek -> Int
mwYear :: {-# UNPACK #-}!Year
    , MondayWeek -> Int
mwWeek :: {-# UNPACK #-}!WeekOfYear
    , MondayWeek -> Int
mwDay :: {-# UNPACK #-}!DayOfWeek
    } deriving (INSTANCES_USUAL, Show)

instance NFData MondayWeek

{-# INLINE mondayWeek #-}
mondayWeek :: Iso' Day MondayWeek
mondayWeek :: Overloaded p f Day Day MondayWeek MondayWeek
mondayWeek = (Day -> MondayWeek)
-> (MondayWeek -> Day) -> Iso Day Day MondayWeek MondayWeek
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Day -> MondayWeek
toMonday MondayWeek -> Day
fromMonday where

    {-# INLINEABLE toMonday #-}
    toMonday :: Day -> MondayWeek
    toMonday :: Day -> MondayWeek
toMonday = (Day -> Day -> MondayWeek) -> Day -> MondayWeek
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (OrdinalDate -> Day -> MondayWeek
toMondayOrdinal (OrdinalDate -> Day -> MondayWeek)
-> (Day -> OrdinalDate) -> Day -> Day -> MondayWeek
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting OrdinalDate Day OrdinalDate -> Day -> OrdinalDate
forall a s. Getting a s a -> s -> a
view Getting OrdinalDate Day OrdinalDate
Iso' Day OrdinalDate
ordinalDate)

    {-# INLINEABLE fromMonday #-}
    fromMonday :: MondayWeek -> Day
    fromMonday :: MondayWeek -> Day
fromMonday (MondayWeek y :: Int
y w :: Int
w d :: Int
d) = Int -> Day
ModifiedJulianDay (Int
firstDay Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yd) where
        ModifiedJulianDay firstDay :: Int
firstDay = AReview Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate AReview Day Day OrdinalDate OrdinalDate -> OrdinalDate -> Day
forall s t a b. AReview s t a b -> b -> t
# Int -> Int -> OrdinalDate
OrdinalDate Int
y 1
        -- following are all 0-based year days
        firstMonday :: Int
firstMonday = Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (5 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstDay) 7
        yd :: Int
yd = Int
firstMonday Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 7 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1

{-# INLINE toMondayOrdinal #-}
toMondayOrdinal :: OrdinalDate -> Day -> MondayWeek
toMondayOrdinal :: OrdinalDate -> Day -> MondayWeek
toMondayOrdinal (OrdinalDate y :: Int
y yd :: Int
yd) (ModifiedJulianDay mjd :: Int
mjd) =
        Int -> Int -> Int -> MondayWeek
MondayWeek Int
y (Int
d7div Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
k 7) (Int
d7mod Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) where
    d :: Int
d = Int
mjd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2
    k :: Int
k = Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
yd
    (d7div :: Int
d7div, d7mod :: Int
d7mod) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod Int
d 7

{-# INLINEABLE mondayWeekValid #-}
mondayWeekValid :: MondayWeek -> Maybe Day
mondayWeekValid :: MondayWeek -> Maybe Day
mondayWeekValid (MondayWeek y :: Int
y w :: Int
w d :: Int
d) = Int -> Day
ModifiedJulianDay (Int
firstDay Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yd)
        Day -> Maybe () -> Maybe Day
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
d Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 7 Bool -> Bool -> Bool
&& 0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
yd Bool -> Bool -> Bool
&& Int
yd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lastDay) where
    ModifiedJulianDay firstDay :: Int
firstDay = AReview Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate AReview Day Day OrdinalDate OrdinalDate -> OrdinalDate -> Day
forall s t a b. AReview s t a b -> b -> t
# Int -> Int -> OrdinalDate
OrdinalDate Int
y 1
    -- following are all 0-based year days
    firstMonday :: Int
firstMonday = Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (5 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstDay) 7
    yd :: Int
yd = Int
firstMonday Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 7 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
    lastDay :: Int
lastDay = if Int -> Bool
isLeapYear Int
y then 365 else 364

------------------------------------------------------------------------
-- Unbox instances at the end avoids TH-related declaration order issues

derivingUnbox "Day" [t| Day -> Int |]
    [| toModifiedJulianDay |] [| ModifiedJulianDay |]

derivingUnbox "YearMonthDay" [t| YearMonthDay -> Int |]
    [| \ YearMonthDay {..} -> shiftL ymdYear 9 .|. shiftL ymdMonth 5 .|. ymdDay |]
    [| \ n -> YearMonthDay (shiftR n 9) (shiftR n 5 .&. 0xf) (n .&. 0x1f) |]

derivingUnbox "OrdinalDate" [t| OrdinalDate -> Int |]
    [| \ OrdinalDate {..} -> shiftL odYear 9 .|. odDay |]
    [| \ n -> OrdinalDate (shiftR n 9) (n .&. 0x1ff) |]

derivingUnbox "MonthDay" [t| MonthDay -> Int |]
    [| \ MonthDay {..} -> shiftL mdMonth 5 .|. mdDay |]
    [| \ n -> MonthDay (shiftR n 5) (n .&. 0x1f) |]

derivingUnbox "WeekDate" [t| WeekDate -> Int |]
    [| \ WeekDate {..} -> shiftL wdYear 9 .|. shiftL wdWeek 3 .|. wdDay |]
    [| \ n -> WeekDate (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |]

derivingUnbox "SundayWeek" [t| SundayWeek -> Int |]
    [| \ SundayWeek {..} -> shiftL swYear 9 .|. shiftL swWeek 3 .|. swDay |]
    [| \ n -> SundayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |]

derivingUnbox "MondayWeek" [t| MondayWeek -> Int |]
    [| \ MondayWeek {..} -> shiftL mwYear 9 .|. shiftL mwWeek 3 .|. mwDay |]
    [| \ n -> MondayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |]