{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
#include "thyme.h"
module Data.Thyme.Calendar.WeekdayOfMonth
( Year, Month, DayOfWeek
, module Data.Thyme.Calendar.WeekdayOfMonth
) 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.Thyme.Calendar
import Data.Thyme.Calendar.Internal
#if __GLASGOW_HASKELL__ == 704
import qualified Data.Vector.Generic
import qualified Data.Vector.Generic.Mutable
#endif
import Data.Vector.Unboxed.Deriving
import GHC.Generics (Generic)
import System.Random
import Test.QuickCheck hiding ((.&.))
data WeekdayOfMonth = WeekdayOfMonth
{ WeekdayOfMonth -> Year
womYear :: {-# UNPACK #-}!Year
, WeekdayOfMonth -> Year
womMonth :: {-# UNPACK #-}!Month
, WeekdayOfMonth -> Year
womNth :: {-# UNPACK #-}!Int
, WeekdayOfMonth -> Year
womDayOfWeek :: {-# UNPACK #-}!DayOfWeek
} deriving (INSTANCES_USUAL, Show)
derivingUnbox "WeekdayOfMonth"
[t| WeekdayOfMonth -> Int |]
[| \ WeekdayOfMonth {..} -> shiftL womYear 11 .|. shiftL womMonth 7
.|. shiftL (womNth + 5) 3 .|. womDayOfWeek |]
[| \ n -> WeekdayOfMonth (shiftR n 11) (shiftR n 7 .&. 0xf)
(shiftR n 3 - 5) (n .&. 0x7) |]
instance NFData WeekdayOfMonth
instance Bounded WeekdayOfMonth where
minBound :: WeekdayOfMonth
minBound = Day
forall a. Bounded a => a
minBound Day -> Getting WeekdayOfMonth Day WeekdayOfMonth -> WeekdayOfMonth
forall s a. s -> Getting a s a -> a
^. Getting WeekdayOfMonth Day WeekdayOfMonth
Iso' Day WeekdayOfMonth
weekdayOfMonth
maxBound :: WeekdayOfMonth
maxBound = Day
forall a. Bounded a => a
maxBound Day -> Getting WeekdayOfMonth Day WeekdayOfMonth -> WeekdayOfMonth
forall s a. s -> Getting a s a -> a
^. Getting WeekdayOfMonth Day WeekdayOfMonth
Iso' Day WeekdayOfMonth
weekdayOfMonth
instance Random WeekdayOfMonth where
randomR :: (WeekdayOfMonth, WeekdayOfMonth) -> g -> (WeekdayOfMonth, g)
randomR = Iso' Day WeekdayOfMonth
-> (WeekdayOfMonth, WeekdayOfMonth) -> g -> (WeekdayOfMonth, g)
forall s g a.
(Random s, RandomGen g) =>
Iso' s a -> (a, a) -> g -> (a, g)
randomIsoR Iso' Day WeekdayOfMonth
weekdayOfMonth
random :: g -> (WeekdayOfMonth, g)
random = (Day -> WeekdayOfMonth) -> (Day, g) -> (WeekdayOfMonth, g)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Day -> Getting WeekdayOfMonth Day WeekdayOfMonth -> WeekdayOfMonth
forall s a. s -> Getting a s a -> a
^. Getting WeekdayOfMonth Day WeekdayOfMonth
Iso' Day WeekdayOfMonth
weekdayOfMonth) ((Day, g) -> (WeekdayOfMonth, g))
-> (g -> (Day, g)) -> g -> (WeekdayOfMonth, g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g -> (Day, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random
instance Arbitrary WeekdayOfMonth where
arbitrary :: Gen WeekdayOfMonth
arbitrary = Getting WeekdayOfMonth Day WeekdayOfMonth -> Day -> WeekdayOfMonth
forall a s. Getting a s a -> s -> a
view Getting WeekdayOfMonth Day WeekdayOfMonth
Iso' Day WeekdayOfMonth
weekdayOfMonth (Day -> WeekdayOfMonth) -> Gen Day -> Gen WeekdayOfMonth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Day
forall a. Arbitrary a => Gen a
arbitrary
shrink :: WeekdayOfMonth -> [WeekdayOfMonth]
shrink wom :: WeekdayOfMonth
wom = Getting WeekdayOfMonth Day WeekdayOfMonth -> Day -> WeekdayOfMonth
forall a s. Getting a s a -> s -> a
view Getting WeekdayOfMonth Day WeekdayOfMonth
Iso' Day WeekdayOfMonth
weekdayOfMonth (Day -> WeekdayOfMonth) -> [Day] -> [WeekdayOfMonth]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Day -> [Day]
forall a. Arbitrary a => a -> [a]
shrink (Overloaded Reviewed Identity Day Day WeekdayOfMonth WeekdayOfMonth
Iso' Day WeekdayOfMonth
weekdayOfMonth Overloaded Reviewed Identity Day Day WeekdayOfMonth WeekdayOfMonth
-> WeekdayOfMonth -> Day
forall s t a b. AReview s t a b -> b -> t
# WeekdayOfMonth
wom)
instance CoArbitrary WeekdayOfMonth where
coarbitrary :: WeekdayOfMonth -> Gen b -> Gen b
coarbitrary (WeekdayOfMonth y :: Year
y m :: Year
m n :: Year
n d :: Year
d)
= Year -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary Year
y (Gen b -> Gen b) -> (Gen b -> Gen b) -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Year -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary Year
m
(Gen b -> Gen b) -> (Gen b -> Gen b) -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Year -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary Year
n (Gen b -> Gen b) -> (Gen b -> Gen b) -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Year -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary Year
d
{-# INLINE weekdayOfMonth #-}
weekdayOfMonth :: Iso' Day WeekdayOfMonth
weekdayOfMonth :: Overloaded p f Day Day WeekdayOfMonth WeekdayOfMonth
weekdayOfMonth = (Day -> WeekdayOfMonth)
-> (WeekdayOfMonth -> Day) -> Iso' Day WeekdayOfMonth
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Day -> WeekdayOfMonth
toWeekday WeekdayOfMonth -> Day
fromWeekday where
{-# INLINEABLE toWeekday #-}
toWeekday :: Day -> WeekdayOfMonth
toWeekday :: Day -> WeekdayOfMonth
toWeekday day :: Day
day@(Getting OrdinalDate Day OrdinalDate -> Day -> OrdinalDate
forall a s. Getting a s a -> s -> a
view Getting OrdinalDate Day OrdinalDate
Iso' Day OrdinalDate
ordinalDate -> OrdinalDate
ord) = Year -> Year -> Year -> Year -> WeekdayOfMonth
WeekdayOfMonth Year
y Year
m Year
n Year
wd where
YearMonthDay y :: Year
y m :: Year
m d :: Year
d = OrdinalDate
ord OrdinalDate
-> Getting YearMonthDay OrdinalDate YearMonthDay -> YearMonthDay
forall s a. s -> Getting a s a -> a
^. Getting YearMonthDay OrdinalDate YearMonthDay
Iso' OrdinalDate YearMonthDay
yearMonthDay
WeekDate _ _ wd :: Year
wd = OrdinalDate -> Day -> WeekDate
toWeekOrdinal OrdinalDate
ord Day
day
n :: Year
n = 1 Year -> Year -> Year
forall a. Num a => a -> a -> a
+ Year -> Year -> Year
forall a. Integral a => a -> a -> a
div (Year
d Year -> Year -> Year
forall a. Num a => a -> a -> a
- 1) 7
{-# INLINEABLE fromWeekday #-}
fromWeekday :: WeekdayOfMonth -> Day
fromWeekday :: WeekdayOfMonth -> Day
fromWeekday (WeekdayOfMonth y :: Year
y m :: Year
m n :: Year
n wd :: Year
wd) = Day
refDay Day -> Diff Day -> Day
forall p. AffineSpace p => p -> Diff p -> p
.+^ Year
s Year -> Year -> Year
forall a. Num a => a -> a -> a
* Year
offset where
refOrd :: OrdinalDate
refOrd = Overloaded
Reviewed Identity OrdinalDate OrdinalDate YearMonthDay YearMonthDay
Iso' OrdinalDate YearMonthDay
yearMonthDay Overloaded
Reviewed Identity OrdinalDate OrdinalDate YearMonthDay YearMonthDay
-> YearMonthDay -> OrdinalDate
forall s t a b. AReview s t a b -> b -> t
# Year -> Year -> Year -> YearMonthDay
YearMonthDay Year
y Year
m
(if Year
n Year -> Year -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then Bool -> Year -> Year
monthLength (Year -> Bool
isLeapYear Year
y) Year
m else 1)
refDay :: Day
refDay = Overloaded Reviewed Identity Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate Overloaded Reviewed Identity Day Day OrdinalDate OrdinalDate
-> OrdinalDate -> Day
forall s t a b. AReview s t a b -> b -> t
# OrdinalDate
refOrd
WeekDate _ _ wd1 :: Year
wd1 = OrdinalDate -> Day -> WeekDate
toWeekOrdinal OrdinalDate
refOrd Day
refDay
s :: Year
s = Year -> Year
forall a. Num a => a -> a
signum Year
n
wo :: Year
wo = Year
s Year -> Year -> Year
forall a. Num a => a -> a -> a
* (Year
wd Year -> Year -> Year
forall a. Num a => a -> a -> a
- Year
wd1)
offset :: Year
offset = (Year -> Year
forall a. Num a => a -> a
abs Year
n Year -> Year -> Year
forall a. Num a => a -> a -> a
- 1) Year -> Year -> Year
forall a. Num a => a -> a -> a
* 7 Year -> Year -> Year
forall a. Num a => a -> a -> a
+ if Year
wo Year -> Year -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then Year
wo Year -> Year -> Year
forall a. Num a => a -> a -> a
+ 7 else Year
wo
{-# INLINEABLE weekdayOfMonthValid #-}
weekdayOfMonthValid :: WeekdayOfMonth -> Maybe Day
weekdayOfMonthValid :: WeekdayOfMonth -> Maybe Day
weekdayOfMonthValid (WeekdayOfMonth y :: Year
y m :: Year
m n :: Year
n wd :: Year
wd) = (Day
refDay Day -> Diff Day -> Day
forall p. AffineSpace p => p -> Diff p -> p
.+^ Year
s Year -> Year -> Year
forall a. Num a => a -> a -> a
* Year
offset)
Day -> Maybe () -> Maybe Day
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Year
n Year -> Year -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 Bool -> Bool -> Bool
&& 1 Year -> Year -> Bool
forall a. Ord a => a -> a -> Bool
<= Year
wd Bool -> Bool -> Bool
&& Year
wd Year -> Year -> Bool
forall a. Ord a => a -> a -> Bool
<= 7 Bool -> Bool -> Bool
&& Year
offset Year -> Year -> Bool
forall a. Ord a => a -> a -> Bool
< Year
len) where
len :: Year
len = Bool -> Year -> Year
monthLength (Year -> Bool
isLeapYear Year
y) Year
m
refOrd :: OrdinalDate
refOrd = Overloaded
Reviewed Identity OrdinalDate OrdinalDate YearMonthDay YearMonthDay
Iso' OrdinalDate YearMonthDay
yearMonthDay Overloaded
Reviewed Identity OrdinalDate OrdinalDate YearMonthDay YearMonthDay
-> YearMonthDay -> OrdinalDate
forall s t a b. AReview s t a b -> b -> t
# Year -> Year -> Year -> YearMonthDay
YearMonthDay Year
y Year
m (if Year
n Year -> Year -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then Year
len else 1)
refDay :: Day
refDay = Overloaded Reviewed Identity Day Day OrdinalDate OrdinalDate
Iso' Day OrdinalDate
ordinalDate Overloaded Reviewed Identity Day Day OrdinalDate OrdinalDate
-> OrdinalDate -> Day
forall s t a b. AReview s t a b -> b -> t
# OrdinalDate
refOrd
WeekDate _ _ wd1 :: Year
wd1 = OrdinalDate -> Day -> WeekDate
toWeekOrdinal OrdinalDate
refOrd Day
refDay
s :: Year
s = Year -> Year
forall a. Num a => a -> a
signum Year
n
wo :: Year
wo = Year
s Year -> Year -> Year
forall a. Num a => a -> a -> a
* (Year
wd Year -> Year -> Year
forall a. Num a => a -> a -> a
- Year
wd1)
offset :: Year
offset = (Year -> Year
forall a. Num a => a -> a
abs Year
n Year -> Year -> Year
forall a. Num a => a -> a -> a
- 1) Year -> Year -> Year
forall a. Num a => a -> a -> a
* 7 Year -> Year -> Year
forall a. Num a => a -> a -> a
+ if Year
wo Year -> Year -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then Year
wo Year -> Year -> Year
forall a. Num a => a -> a -> a
+ 7 else Year
wo
LENS(WeekdayOfMonth,womYear,Year)
LENS(WeekdayOfMonth,womMonth,Month)
LENS(WeekdayOfMonth,womNth,Int)
LENS(WeekdayOfMonth,womDayOfWeek,DayOfWeek)