{-# 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"
#if HLINT
#include "cabal_macros.h"
#endif

module Data.Thyme.Calendar.Internal where

import Prelude
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Arrow
import Control.DeepSeq
import Control.Lens
import Control.Monad
import Data.AffineSpace
import Data.Bits
import Data.Data
import Data.Hashable
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 ((.&.))

-- | A duration/count of years.
type Years = Int

-- | A duration/count of months.
type Months = Int

-- | A duration/count of days.
type Days = Int

-- | A calendar-agnostic day, internally represented as a count of days
-- since /1858-11-17/, the
-- <https://en.wikipedia.org/wiki/Julian_day#Variants Modified Julian Day>
-- (MJD) epoch.
--
-- To convert a 'Day' to the corresponding 'YearMonthDay' in the W_GREGORIAN
-- calendar, see 'gregorian'.
--
-- @
-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1
-- 2016-03-01
-- @
--
-- 'Day' is an instance of 'AffineSpace' where @'Diff' 'Day' = 'Days'@, so
-- arithmetic on 'Day' and 'Days' can be performed with the '.-.', '.+^',
-- and '.-^' operators.
--
-- @
-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1  '.-.'  'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 2 1
-- 29
-- @
--
-- @
-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '.-^' 1
-- 2016-02-29
-- @
--
-- Other ways of viewing a 'Day' include 'ordinalDate', and 'weekDate'.
newtype Day = ModifiedJulianDay
    { Day -> Year
toModifiedJulianDay :: Int
    } deriving (INSTANCES_NEWTYPE, CoArbitrary)

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

-- | Convert between a 'Day' and the corresponding count of days from
-- 1858-11-17, the MJD epoch.
--
-- @
-- 'modifiedJulianDay' = 'iso' 'toModifiedJulianDay' 'ModifiedJulianDay'
-- @
--
-- @
-- > 'modifiedJulianDay' 'Control.Lens.#' 0
-- 1858-11-17
-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '&' 'modifiedJulianDay' '%~' 'subtract' 1
-- 2016-02-29
-- @
{-# INLINE modifiedJulianDay #-}
modifiedJulianDay :: Iso' Day Int
modifiedJulianDay :: Iso' Day Year
modifiedJulianDay = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Day -> Year
toModifiedJulianDay Year -> Day
ModifiedJulianDay

-- | Conversion between a W_GREGORIAN 'OrdinalDate' and the corresponding
-- 'YearMonthDay'.
--
-- @
-- > 'OrdinalDate' 2016 32 '^.' 'yearMonthDay'
-- 'YearMonthDay' {ymdYear = 2016, ymdMonth = 2, ymdDay = 1}
-- @
--
-- @
-- > 'yearMonthDay' 'Control.Lens.#' 'YearMonthDay' 2016 2 1
-- 'OrdinalDate' {odYear = 2016, odDay = 32}
-- @
{-# INLINE yearMonthDay #-}
yearMonthDay :: Iso' OrdinalDate YearMonthDay
yearMonthDay :: Iso' 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 Year
y Year
yd) = Year -> Year -> Year -> YearMonthDay
YearMonthDay Year
y Year
m Year
d where
        MonthDay Year
m Year
d = Year
yd forall s a. s -> Getting a s a -> a
^. Bool -> Iso' Year MonthDay
monthDay (Year -> Bool
isLeapYear Year
y)

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

-- | Conversion between a 'Day' and its 'YearMonthDay'.
--
-- @
-- 'gregorian' = 'ordinalDate' . 'yearMonthDay'
-- @
--
-- @
-- > 'ModifiedJulianDay' 0 '^.' 'gregorian'
-- 'YearMonthDay' {ymdYear = 1858, ymdMonth = 11, ymdDay = 17}
-- @
--
-- @
-- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 1858 11 17
-- 1858-11-17
-- @
{-# INLINE gregorian #-}
gregorian :: Iso' Day YearMonthDay
gregorian :: Iso' Day YearMonthDay
gregorian = Iso' Day OrdinalDate
ordinalDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' OrdinalDate YearMonthDay
yearMonthDay

-- | Conversion between a 'YearMonthDay' and the corresponding 'Day'.
-- Returns 'Nothing' for invalid input.
--
-- @
-- > 'gregorianValid' ('YearMonthDay' 2015 2 28)
-- 'Just' 2015-02-28
-- @
--
-- @
-- > 'gregorianValid' ('YearMonthDay' 2015 2 29)
-- 'Nothing'
-- @
{-# INLINEABLE gregorianValid #-}
gregorianValid :: YearMonthDay -> Maybe Day
gregorianValid :: YearMonthDay -> Maybe Day
gregorianValid (YearMonthDay Year
y Year
m Year
d) = forall s t a b. AReview s t a b -> b -> t
review Iso' Day OrdinalDate
ordinalDate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Year -> Year -> OrdinalDate
OrdinalDate Year
y
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> MonthDay -> Maybe Year
monthDayValid (Year -> Bool
isLeapYear Year
y) (Year -> Year -> MonthDay
MonthDay Year
m Year
d)

-- | Shows a 'Day' in
-- <https://en.wikipedia.org/wiki/ISO_8601#Calendar_dates ISO 8601>
-- /YYYY-MM-DD/ format.
--
-- See "Data.Thyme.Format" for other possibilities.
{-# INLINEABLE showGregorian #-}
showGregorian :: Day -> String
showGregorian :: Day -> String
showGregorian (forall a s. Getting a s a -> s -> a
view Iso' Day YearMonthDay
gregorian -> YearMonthDay Year
y Year
m Year
d) =
    Year -> String -> String
showsYear Year
y forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Char
'-' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Year -> String -> String
shows02 Year
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Char
'-' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Year -> String -> String
shows02 Year
d forall a b. (a -> b) -> a -> b
$ String
""

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

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

-- | Calendar year.
type Year = Int

-- | Calendar month. /January = 1/
type Month = Int

-- | Calendar day-of-month, starting from /1/.
type DayOfMonth = Int

-- | A strict triple of a 'Year', a 'Day', and a 'Month'.
data YearMonthDay = YearMonthDay
    { YearMonthDay -> Year
ymdYear :: {-# UNPACK #-}!Year
    , YearMonthDay -> Year
ymdMonth :: {-# UNPACK #-}!Month
    , YearMonthDay -> Year
ymdDay :: {-# UNPACK #-}!DayOfMonth
    } deriving (INSTANCES_USUAL, Show)

LENS(YearMonthDay,ymdYear,Year)
LENS(YearMonthDay,ymdMonth,Month)
LENS(YearMonthDay,ymdDay,DayOfMonth)

instance Hashable YearMonthDay
instance NFData YearMonthDay

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

-- | Is it a leap year according to the W_GREGORIAN calendar?
isLeapYear :: Year -> Bool
isLeapYear :: Year -> Bool
isLeapYear Year
y = Year
y forall a. Bits a => a -> a -> a
.&. Year
3 forall a. Eq a => a -> a -> Bool
== Year
0 Bool -> Bool -> Bool
&& (Year
r100 forall a. Eq a => a -> a -> Bool
/= Year
0 Bool -> Bool -> Bool
|| Year
q100 forall a. Bits a => a -> a -> a
.&. Year
3 forall a. Eq a => a -> a -> Bool
== Year
0) where
    (Year
q100, Year
r100) = Year
y forall a. Integral a => a -> a -> (a, a)
`quotRem` Year
100

-- | The day of the year, with /1 = January 1st/.
type DayOfYear = Int

-- | An
-- <https://en.wikipedia.org/wiki/ISO_8601#Ordinal_dates ISO 8601 ordinal date>.
data OrdinalDate = OrdinalDate
    { OrdinalDate -> Year
odYear :: {-# UNPACK #-}!Year
    , OrdinalDate -> Year
odDay :: {-# UNPACK #-}!DayOfYear
    } deriving (INSTANCES_USUAL, Show)

LENS(OrdinalDate,odYear,Year)
LENS(OrdinalDate,odDay,DayOfYear)

instance Hashable OrdinalDate
instance NFData OrdinalDate

-- | Conversion between the MJD 'Day' and 'OrdinalDate'.
--
-- @
-- > 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32
-- 2016-02-01
-- @
--
-- @
-- > 'toModifiedJulianDay' $ 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32
-- 57419
-- @
--
-- @
-- > 'ModifiedJulianDay' 57419 '^.' 'ordinalDate'
-- 'OrdinalDate' {odYear = 2016, odDay = 32}
-- @
{-# INLINE ordinalDate #-}
ordinalDate :: Iso' Day OrdinalDate
ordinalDate :: Iso' Day OrdinalDate
ordinalDate = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Day -> OrdinalDate
toOrd OrdinalDate -> Day
fromOrd where

-- Brief description of the toOrd computation
--
-- The length of the years in the 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:
--
--  * The 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
-- on 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 /0001-01-01/). For earlier dates we translate by an
-- integral number of /400/ year periods, do the computation and
-- translate back.

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

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

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

    {-# INLINEABLE fromOrd #-}
    fromOrd :: OrdinalDate -> Day
    fromOrd :: OrdinalDate -> Day
fromOrd (OrdinalDate Year
year Year
yd) = Year -> Day
ModifiedJulianDay Year
mjd where
        years :: Year
years = Year
year forall a. Num a => a -> a -> a
- Year
1
        centuries :: Year
centuries = Year
years forall a. Integral a => a -> a -> a
`div` Year
100
        leaps :: Year
leaps = Year
years forall a. Bits a => a -> Year -> a
`shiftR` Year
2 forall a. Num a => a -> a -> a
- Year
centuries forall a. Num a => a -> a -> a
+ Year
centuries forall a. Bits a => a -> Year -> a
`shiftR` Year
2
        mjd :: Year
mjd = Year
365 forall a. Num a => a -> a -> a
* Year
years forall a. Num a => a -> a -> a
+ Year
leaps forall a. Num a => a -> a -> a
- Year
678576
            forall a. Num a => a -> a -> a
+ forall {c}. Ord c => c -> c -> c -> c
clip Year
1 (if Year -> Bool
isLeapYear Year
year then Year
366 else Year
365) Year
yd
        clip :: c -> c -> c -> c
clip c
a c
b = forall a. Ord a => a -> a -> a
max c
a forall b c a. (b -> c) -> (a -> b) -> a -> 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 Year
monthLengths     = forall a. Unbox a => [a] -> Vector a
VU.fromList [Year
31,Year
28,Year
31,Year
30,Year
31,Year
30,Year
31,Year
31,Year
30,Year
31,Year
30,Year
31]
monthLengthsLeap :: Vector Year
monthLengthsLeap = forall a. Unbox a => [a] -> Vector a
VU.fromList [Year
31,Year
29,Year
31,Year
30,Year
31,Year
30,Year
31,Year
31,Year
30,Year
31,Year
30,Year
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 = forall a. Unbox a => Year -> (Year -> a) -> Vector a
VU.generate Year
365 forall {a} {b}. (Num a, Num b) => Year -> (a, b)
go where
    dom01 :: Vector Year
dom01 = forall a b.
(Unbox a, Unbox b) =>
(a -> b -> a) -> a -> Vector b -> Vector a
VU.prescanl' forall a. Num a => a -> a -> a
(+) Year
0 Vector Year
monthLengths
    go :: Year -> (a, b)
go Year
yd = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Year
m, forall a b. (Integral a, Num b) => a -> b
fromIntegral Year
d) where
        m :: Year
m = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Year
12 forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => (a -> Bool) -> Vector a -> Maybe Year
VU.findIndex (Year
yd forall a. Ord a => a -> a -> Bool
<) Vector Year
dom01
        d :: Year
d = forall a. Enum a => a -> a
succ Year
yd forall a. Num a => a -> a -> a
- forall a. Unbox a => Vector a -> Year -> a
VU.unsafeIndex Vector Year
dom01 (forall a. Enum a => a -> a
pred Year
m)

{-# ANN monthDaysLeap "HLint: ignore Use fromMaybe" #-}
{-# NOINLINE monthDaysLeap #-}
monthDaysLeap :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8)
monthDaysLeap :: Vector (Int8, Int8)
monthDaysLeap = forall a. Unbox a => Year -> (Year -> a) -> Vector a
VU.generate Year
366 forall {a} {b}. (Num a, Num b) => Year -> (a, b)
go where
    dom01 :: Vector Year
dom01 = forall a b.
(Unbox a, Unbox b) =>
(a -> b -> a) -> a -> Vector b -> Vector a
VU.prescanl' forall a. Num a => a -> a -> a
(+) Year
0 Vector Year
monthLengthsLeap
    go :: Year -> (a, b)
go Year
yd = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Year
m, forall a b. (Integral a, Num b) => a -> b
fromIntegral Year
d) where
        m :: Year
m = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Year
12 forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => (a -> Bool) -> Vector a -> Maybe Year
VU.findIndex (Year
yd forall a. Ord a => a -> a -> Bool
<) Vector Year
dom01
        d :: Year
d = forall a. Enum a => a -> a
succ Year
yd forall a. Num a => a -> a -> a
- forall a. Unbox a => Vector a -> Year -> a
VU.unsafeIndex Vector Year
dom01 (forall a. Enum a => a -> a
pred Year
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 :: forall s g a.
(Random s, RandomGen g) =>
Iso' s a -> (a, a) -> g -> (a, g)
randomIsoR Iso' s a
l (a
x, a
y) = 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' s a
l) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Iso' s a
l forall s t a b. AReview s t a b -> b -> t
# a
x, Iso' s a
l forall s t a b. AReview s t a b -> b -> t
# a
y)

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

-- | A strict pair of a 'Month' and a 'DayOfMonth'.
data MonthDay = MonthDay
    { MonthDay -> Year
mdMonth :: {-# UNPACK #-}!Month
    , MonthDay -> Year
mdDay :: {-# UNPACK #-}!DayOfMonth
    } deriving (INSTANCES_USUAL, Show)

LENS(MonthDay,mdMonth,Month)
LENS(MonthDay,mdDay,DayOfMonth)

instance Hashable MonthDay
instance NFData MonthDay

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

instance Random MonthDay where
    randomR :: forall g. RandomGen g => (MonthDay, MonthDay) -> g -> (MonthDay, g)
randomR (MonthDay, MonthDay)
r g
g = forall s g a.
(Random s, RandomGen g) =>
Iso' s a -> (a, a) -> g -> (a, g)
randomIsoR (Bool -> Iso' Year MonthDay
monthDay Bool
leap) (MonthDay, MonthDay)
r g
g' where
        (Year -> Bool
isLeapYear -> Bool
leap, g
g') = forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
g
    random :: forall g. RandomGen g => g -> (MonthDay, 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 Arbitrary MonthDay where
    arbitrary :: Gen MonthDay
arbitrary = forall a. Random a => (a, a) -> Gen a
choose (forall a. Bounded a => a
minBound, forall a. Bounded a => a
maxBound)
    shrink :: MonthDay -> [MonthDay]
shrink MonthDay
md = forall a s. Getting a s a -> s -> a
view (Bool -> Iso' Year MonthDay
monthDay Bool
True) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink (Bool -> Iso' Year MonthDay
monthDay Bool
True forall s t a b. AReview s t a b -> b -> t
# MonthDay
md)

instance CoArbitrary MonthDay where
    coarbitrary :: forall b. MonthDay -> Gen b -> Gen b
coarbitrary (MonthDay Year
m Year
d) = forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary Year
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary Year
d

-- | Predicated on whether or not it's a leap year, convert between an
-- ordinal 'DayOfYear' and the corresponding 'Month' and 'DayOfMonth'.
--
-- @
-- > 60 '^.' 'monthDay' ('isLeapYear' 2015)
-- 'MonthDay' {'mdMonth' = 3, 'mdDay' = 1}
-- @
--
-- @
-- > 60 '^.' 'monthDay' ('isLeapYear' 2016)
-- 'MonthDay' {'mdMonth' = 2, 'mdDay' = 29}
-- @
--
-- @
-- > 'monthDay' ('isLeapYear' 2016) 'Control.Lens.#' 'MonthDay' 2 29
-- 60
-- @
--
-- @
-- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 28
-- 59
-- @
--
-- Note that 'monthDay' is an improper 'Iso', as the following example
-- shows. To handle this case correctly, use 'monthDayValid'.
--
-- @
-- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 29
-- 59
-- @
{-# INLINE monthDay #-}
monthDay
    :: Bool -- ^ 'isLeapYear'?
    -> Iso' DayOfYear MonthDay
monthDay :: Bool -> Iso' Year MonthDay
monthDay Bool
leap = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Year -> MonthDay
fromOrdinal MonthDay -> Year
toOrdinal where
    (Year
lastDay, Vector Year
lengths, Vector (Int8, Int8)
table, Year
ok) = if Bool
leap
        then (Year
365, Vector Year
monthLengthsLeap, Vector (Int8, Int8)
monthDaysLeap, -Year
1)
        else (Year
364, Vector Year
monthLengths, Vector (Int8, Int8)
monthDays, -Year
2)

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

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

-- | Predicated on whether or not it's a leap year, convert a 'MonthDay' to
-- an ordinal 'DayOfYear'.
--
-- @
-- > 'monthDayValid' ('isLeapYear' 2016) ('MonthDay' 2 29)
-- 'Just' 60
-- @
--
-- @
-- > 'monthDayValid' ('isLeapYear' 2015) ('MonthDay' 2 29)
-- 'Nothing'
-- @
{-# INLINEABLE monthDayValid #-}
monthDayValid
    :: Bool -- ^ 'isLeapYear'?
    -> MonthDay
    -> Maybe DayOfYear
monthDayValid :: Bool -> MonthDay -> Maybe Year
monthDayValid Bool
leap md :: MonthDay
md@(MonthDay Year
m Year
d) = Bool -> Iso' Year MonthDay
monthDay Bool
leap forall s t a b. AReview s t a b -> b -> t
# MonthDay
md
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Year
1 forall a. Ord a => a -> a -> Bool
<= Year
m Bool -> Bool -> Bool
&& Year
m forall a. Ord a => a -> a -> Bool
<= Year
12 Bool -> Bool -> Bool
&& Year
1 forall a. Ord a => a -> a -> Bool
<= Year
d Bool -> Bool -> Bool
&& Year
d forall a. Ord a => a -> a -> Bool
<= Bool -> Year -> Year
monthLength Bool
leap Year
m)

-- | Predicated on whether or not the year is a leap year, return the number
-- of 'Days' in the given 'Month'.
--
-- @
-- > monthLength ('isLeapYear' 2015) 2
--   28
-- @
--
-- @
-- > monthLength ('isLeapYear' 2016) 2
--   29
-- @
{-# INLINEABLE monthLength #-}
monthLength
    :: Bool -- ^ 'isLeapYear'?
    -> Month
    -> Days
monthLength :: Bool -> Year -> Year
monthLength Bool
leap = forall a. Unbox a => Vector a -> Year -> a
VU.unsafeIndex Vector Year
ls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max Year
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min Year
11 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
pred where
    ls :: Vector Year
ls = if Bool
leap then Vector Year
monthLengthsLeap else Vector Year
monthLengths

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

-- | Week of the year.
--
-- Meaning of values depends on context; see 'wdWeek', 'swWeek', 'mwWeek'.
type WeekOfYear = Int

-- | Day of the week.
--
-- [/0/] /Sunday/ for 'SundayWeek'
--
-- [/1/…/6/] /Monday/…/Saturday/
--
-- [/7/] /Sunday/ for 'WeekDate', 'MondayWeek', and 'Data.Thyme.Calendar.WeekdayOfMonth.WeekdayOfMonth'
type DayOfWeek = Int

-- | <https://en.wikipedia.org/wiki/ISO_week_date ISO 8601 Week Date>.
--
-- Note that week /01/ is defined as the week with the first Thursday, thus
-- 'wdYear' may differ from the Gregorian year between /December 29th/ and
-- /January 3rd/.
data WeekDate = WeekDate
    { WeekDate -> Year
wdYear :: {-# UNPACK #-}!Year
    , WeekDate -> Year
wdWeek :: {-# UNPACK #-}!WeekOfYear
        -- ^ Numbered /01/ to /53/. Days before week /01/ are considered to
        -- belong to the previous year.
    , WeekDate -> Year
wdDay :: {-# UNPACK #-}!DayOfWeek
        -- ^ /1 = Monday/ … /7 = Sunday/.
    } deriving (INSTANCES_USUAL, Show)

LENS(WeekDate,wdYear,Year)
LENS(WeekDate,wdWeek,WeekOfYear)
LENS(WeekDate,wdDay,DayOfWeek)

instance Hashable WeekDate
instance NFData WeekDate

-- | Convert between a 'Day' and an ISO 8601 'WeekDate'.
--
-- @
-- > 'YearMonthDay' 2016 1 1 '^.' 'from' 'gregorian' '.' 'weekDate'
-- 'WeekDate' {'wdYear' = 2015, 'wdWeek' = 53, 'wdDay' = 5}
-- @
{-# INLINE weekDate #-}
weekDate :: Iso' Day WeekDate
weekDate :: Iso' 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 = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (OrdinalDate -> Day -> WeekDate
toWeekOrdinal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view Iso' Day OrdinalDate
ordinalDate)

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

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

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

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

-- | Convert a 'WeekDate' to a 'Day', or 'Nothing' for invalid 'WeekDate'.
{-# INLINEABLE weekDateValid #-}
weekDateValid :: WeekDate -> Maybe Day
weekDateValid :: WeekDate -> Maybe Day
weekDateValid wd :: WeekDate
wd@(WeekDate (Year -> Year
lastWeekOfYear -> Year
wMax) Year
w Year
d) =
    Year -> WeekDate -> Day
fromWeekLast Year
wMax WeekDate
wd forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Year
1 forall a. Ord a => a -> a -> Bool
<= Year
d Bool -> Bool -> Bool
&& Year
d forall a. Ord a => a -> a -> Bool
<= Year
7 Bool -> Bool -> Bool
&& Year
1 forall a. Ord a => a -> a -> Bool
<= Year
w Bool -> Bool -> Bool
&& Year
w forall a. Ord a => a -> a -> Bool
<= Year
wMax)

-- | Shows a 'Day' using the @yyyy-Www-d@ ISO 8601 Week Date format.
--
-- @
-- > 'showWeekDate' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2006 11 15)
-- "2006-W46-3"
-- @
{-# INLINEABLE showWeekDate #-}
showWeekDate :: Day -> String
showWeekDate :: Day -> String
showWeekDate (forall a s. Getting a s a -> s -> a
view Iso' Day WeekDate
weekDate -> WeekDate Year
y Year
w Year
d) =
    Year -> String -> String
showsYear Year
y forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++) String
"-W" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Year -> String -> String
shows02 Year
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Char
'-' forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Year
d

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

-- | Week-based calendar date with the first /Sunday/ of the year as the first
-- day of week /01/. This corresponds to @%U@ and @%w@ of
-- @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime(3)>@.
--
-- The final week of a given year and week /00/ of the next both refer to
-- the same week.
data SundayWeek = SundayWeek
    { SundayWeek -> Year
swYear :: {-# UNPACK #-}!Year
        -- ^ Coincides with that of 'gregorian'.
    , SundayWeek -> Year
swWeek :: {-# UNPACK #-}!WeekOfYear
        -- ^ Weeks numbered from /00/ to /53/, starting with the first
        -- /Sunday/ of the year as the first day of week /01/.
    , SundayWeek -> Year
swDay :: {-# UNPACK #-}!DayOfWeek
        -- ^ /0 = Sunday/.
    } deriving (INSTANCES_USUAL, Show)

LENS(SundayWeek,swYear,Year)
LENS(SundayWeek,swWeek,WeekOfYear)
LENS(SundayWeek,swDay,DayOfWeek)

instance Hashable SundayWeek
instance NFData SundayWeek

-- | Conversion between 'Day' and 'SundayWeek'.
--
-- @
-- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'sundayWeek'
-- 'SundayWeek' {'swYear' = 2016, 'swWeek' = 1, 'swDay' = 0}
-- @
{-# INLINE sundayWeek #-}
sundayWeek :: Iso' Day SundayWeek
sundayWeek :: Iso' 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 = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (OrdinalDate -> Day -> SundayWeek
toSundayOrdinal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view Iso' Day OrdinalDate
ordinalDate)

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

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

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

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

-- | Week-based calendar date with the first /Monday/ of the year as the first
-- day of week /01/. This corresponds to @%W@ and @%u@ of
-- @<http://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html#index-strftime strftime(3)>@.
--
-- The final week of a given year and week /00/ of the next both refer to
-- the same week.
data MondayWeek = MondayWeek
    { MondayWeek -> Year
mwYear :: {-# UNPACK #-}!Year
        -- ^ Coincides with that of 'gregorian'.
    , MondayWeek -> Year
mwWeek :: {-# UNPACK #-}!WeekOfYear
        -- ^ Weeks numbered from /00/ to /53/, starting with the first
        -- /Monday/ of the year as the first day of week /01/.
    , MondayWeek -> Year
mwDay :: {-# UNPACK #-}!DayOfWeek
        -- ^ /7 = Sunday/.
    } deriving (INSTANCES_USUAL, Show)

LENS(MondayWeek,mwYear,Year)
LENS(MondayWeek,mwWeek,WeekOfYear)
LENS(MondayWeek,mwDay,DayOfWeek)

instance Hashable MondayWeek
instance NFData MondayWeek

-- | Conversion between 'Day' and 'MondayWeek'.
--
-- @
-- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'mondayWeek'
-- 'MondayWeek' {'mwYear' = 2016, 'mwWeek' = 0, 'mwDay' = 7}
-- @
{-# INLINE mondayWeek #-}
mondayWeek :: Iso' Day MondayWeek
mondayWeek :: Iso' 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 = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (OrdinalDate -> Day -> MondayWeek
toMondayOrdinal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view Iso' Day OrdinalDate
ordinalDate)

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

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

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