module Data.Time.Calendar.BankHoliday.EnglandAndWales
( bankHolidays
, isBankHoliday
, countBankHolidays
) where
import Data.List ((\\))
import Data.Time
( Day
, addDays
, fromGregorian
, toGregorian
, toModifiedJulianDay
)
import Data.Time.Calendar.Easter (gregorianEaster)
import qualified Data.Set as S
( Set
, (\\)
, fromList
, member
, split
, toList
, union
)
bankHolidays :: Integer -> [Day]
bankHolidays :: Integer -> [Day]
bankHolidays Integer
yy = Set Day -> [Day]
forall a. Set a -> [a]
S.toList (Set Day -> [Day]) -> Set Day -> [Day]
forall a b. (a -> b) -> a -> b
$ Set Day
standardHolidays Set Day -> Set Day -> Set Day
forall a. Ord a => Set a -> Set a -> Set a
S.\\ Integer -> Set Day -> Set Day
filterByYear Integer
yy Set Day
skipped Set Day -> Set Day -> Set Day
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Integer -> Set Day -> Set Day
filterByYear Integer
yy Set Day
extras
where
standardHolidays :: Set Day
standardHolidays = [Day] -> Set Day
forall a. Ord a => [a] -> Set a
S.fromList
([Day] -> Set Day) -> [Day] -> Set Day
forall a b. (a -> b) -> a -> b
$ [ Day
newYearsDay
, (Int -> Day) -> Day
forall t. Num t => (t -> Day) -> Day
firstMondayIn Int -> Day
may
, Day -> Day
weekBefore (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ (Int -> Day) -> Day
forall t. Num t => (t -> Day) -> Day
firstMondayIn Int -> Day
jun
, Day -> Day
weekBefore (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ (Int -> Day) -> Day
forall t. Num t => (t -> Day) -> Day
firstMondayIn Int -> Day
sep ]
[Day] -> [Day] -> [Day]
forall a. [a] -> [a] -> [a]
++ [Day]
easter
[Day] -> [Day] -> [Day]
forall a. [a] -> [a] -> [a]
++ [Day]
christmas
newYearsDay :: Day
newYearsDay = case (Int -> Day) -> Int -> Integer
forall t. (t -> Day) -> t -> Integer
wd Int -> Day
jan Int
1 of
Integer
3 -> Int -> Day
jan Int
3
Integer
4 -> Int -> Day
jan Int
2
Integer
_ -> Int -> Day
jan Int
1
easter :: [Day]
easter = let easterSunday :: Day
easterSunday = Integer -> Day
gregorianEaster Integer
yy in [Integer -> Day -> Day
addDays (-Integer
2) Day
easterSunday, Integer -> Day -> Day
addDays Integer
1 Day
easterSunday]
christmas :: [Day]
christmas = case (Int -> Day) -> Int -> Integer
forall t. (t -> Day) -> t -> Integer
wd Int -> Day
dec Int
25 of
Integer
2 -> [Int -> Day
dec Int
25, Int -> Day
dec Int
28]
Integer
3 -> [Int -> Day
dec Int
27, Int -> Day
dec Int
28]
Integer
4 -> [Int -> Day
dec Int
26, Int -> Day
dec Int
27]
Integer
_ -> [Int -> Day
dec Int
25, Int -> Day
dec Int
26]
[Int -> Day
jan, Int -> Day
may, Int -> Day
jun, Int -> Day
sep, Int -> Day
dec] = (Int -> Int -> Day) -> [Int] -> [Int -> Day]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Int -> Int -> Day
fromGregorian Integer
yy)
[Int
1, Int
5, Int
6, Int
9, Int
12]
firstMondayIn :: (t -> Day) -> Day
firstMondayIn t -> Day
mm = Integer -> Day -> Day
addDays (Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ (t -> Day) -> t -> Integer
forall t. (t -> Day) -> t -> Integer
wd t -> Day
mm t
02) (t -> Day
mm t
07)
wd :: (t -> Day) -> t -> Integer
wd t -> Day
mm t
dd = Day -> Integer
toModifiedJulianDay (t -> Day
mm t
dd) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
7
weekBefore :: Day -> Day
weekBefore = Integer -> Day -> Day
addDays (-Integer
7)
filterByYear :: Integer -> S.Set Day -> S.Set Day
filterByYear :: Integer -> Set Day -> Set Day
filterByYear Integer
y Set Day
s0 = Set Day
s2
where
(Set Day
s1, Set Day
_) = Day -> Set Day -> (Set Day, Set Day)
forall a. Ord a => a -> Set a -> (Set a, Set a)
S.split (Integer -> Int -> Int -> Day
fromGregorian (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) Int
1 Int
1) Set Day
s0
(Set Day
_ ,Set Day
s2) = Day -> Set Day -> (Set Day, Set Day)
forall a. Ord a => a -> Set a -> (Set a, Set a)
S.split (Integer -> Day -> Day
addDays (-Integer
1) (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
1 Int
1) Set Day
s1
skipped :: S.Set Day
skipped :: Set Day
skipped = [Day] -> Set Day
forall a. Ord a => [a] -> Set a
S.fromList [ Integer -> Int -> Int -> Day
fromGregorian Integer
1995 Int
05 Int
1
, Integer -> Int -> Int -> Day
fromGregorian Integer
2002 Int
05 Int
27
, Integer -> Int -> Int -> Day
fromGregorian Integer
2012 Int
05 Int
28
, Integer -> Int -> Int -> Day
fromGregorian Integer
2020 Int
05 Int
04
, Integer -> Int -> Int -> Day
fromGregorian Integer
2022 Int
05 Int
30
]
extras :: S.Set Day
= [Day] -> Set Day
forall a. Ord a => [a] -> Set a
S.fromList [ Integer -> Int -> Int -> Day
fromGregorian Integer
1995 Int
05 Int
08
, Integer -> Int -> Int -> Day
fromGregorian Integer
1999 Int
12 Int
31
, Integer -> Int -> Int -> Day
fromGregorian Integer
2002 Int
06 Int
03
, Integer -> Int -> Int -> Day
fromGregorian Integer
2002 Int
06 Int
04
, Integer -> Int -> Int -> Day
fromGregorian Integer
2011 Int
04 Int
29
, Integer -> Int -> Int -> Day
fromGregorian Integer
2012 Int
06 Int
04
, Integer -> Int -> Int -> Day
fromGregorian Integer
2012 Int
06 Int
05
, Integer -> Int -> Int -> Day
fromGregorian Integer
2020 Int
05 Int
08
, Integer -> Int -> Int -> Day
fromGregorian Integer
2022 Int
06 Int
02
, Integer -> Int -> Int -> Day
fromGregorian Integer
2022 Int
06 Int
03
]
extraYears :: [Integer]
= Set Day -> [Integer]
yearsOf Set Day
extras [Integer] -> [Integer] -> [Integer]
forall a. Eq a => [a] -> [a] -> [a]
\\ Set Day -> [Integer]
yearsOf Set Day
skipped
where
yearsOf :: Set Day -> [Integer]
yearsOf Set Day
s = [Integer
y | (Integer
y,Int
_,Int
_) <- (Day -> (Integer, Int, Int)) -> [Day] -> [(Integer, Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Day -> (Integer, Int, Int)
toGregorian ([Day] -> [(Integer, Int, Int)]) -> [Day] -> [(Integer, Int, Int)]
forall a b. (a -> b) -> a -> b
$ Set Day -> [Day]
forall a. Set a -> [a]
S.toList Set Day
s]
isBankHoliday :: Day -> Bool
isBankHoliday :: Day -> Bool
isBankHoliday Day
d = (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Day -> Set Day -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Day
d Set Day
skipped) Bool -> Bool -> Bool
&& (Day -> Set Day -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Day
d Set Day
extras Bool -> Bool -> Bool
|| Bool
isStandardHoliday)
where
(Integer
yy,Int
mm,Int
dd) = Day -> (Integer, Int, Int)
toGregorian Day
d
dayOfWeek :: Integer
dayOfWeek = Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod (Day -> Integer
toModifiedJulianDay Day
d) Integer
7
isMonday :: Bool
isMonday = Integer
dayOfWeek Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
5
isWeekend :: Bool
isWeekend = Integer
dayOfWeek Integer -> [Integer] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Integer
3,Integer
4]
easterSunday :: Day
easterSunday = Integer -> Day
gregorianEaster Integer
yy
isStandardHoliday :: Bool
isStandardHoliday
| Bool
isWeekend = Bool
False
| Bool
isMonday = (Int
mm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
dd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3)
Bool -> Bool -> Bool
|| (Int
mm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 Bool -> Bool -> Bool
&& (Int
dd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
7 Bool -> Bool -> Bool
|| Int
31Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
7 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
dd))
Bool -> Bool -> Bool
|| (Int
mm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 Bool -> Bool -> Bool
&& Int
31Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
7 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
dd)
Bool -> Bool -> Bool
|| (Int
mm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
12 Bool -> Bool -> Bool
&& Int
25 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
dd Bool -> Bool -> Bool
&& Int
dd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
29)
Bool -> Bool -> Bool
|| Day
d Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Day -> Day
addDays Integer
1 Day
easterSunday
| Bool
otherwise = (Int
mm,Int
dd) (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1,Int
1)
Bool -> Bool -> Bool
|| (Int
mm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
12 Bool -> Bool -> Bool
&& Int
25 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
dd Bool -> Bool -> Bool
&& (Int
dd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
27 Bool -> Bool -> Bool
|| (Integer
dayOfWeek Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
6 Bool -> Bool -> Bool
&& Int
dd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
29)))
Bool -> Bool -> Bool
|| Day
d Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Day -> Day
addDays (-Integer
2) Day
easterSunday
countBankHolidays :: Day -> Day -> Integer
countBankHolidays :: Day -> Day -> Integer
countBankHolidays Day
d0 Day
d1
= if Day
d0 Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<= Day
d1 then
if Integer
y0 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
y1
then Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [Day] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Day] -> Int) -> [Day] -> Int
forall a b. (a -> b) -> a -> b
$ (Day -> Bool) -> [Day] -> [Day]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<Day
d1) ([Day] -> [Day]) -> [Day] -> [Day]
forall a b. (a -> b) -> a -> b
$ (Day -> Bool) -> [Day] -> [Day]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<Day
d0) ([Day] -> [Day]) -> [Day] -> [Day]
forall a b. (a -> b) -> a -> b
$ Integer -> [Day]
bankHolidays Integer
y0
else Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Day] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Day -> Bool) -> [Day] -> [Day]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<Day
d1) ([Day] -> [Day]) -> [Day] -> [Day]
forall a b. (a -> b) -> a -> b
$ Integer -> [Day]
bankHolidays Integer
y1)
Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Day] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Day -> Bool) -> [Day] -> [Day]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
<Day
d0) ([Day] -> [Day]) -> [Day] -> [Day]
forall a b. (a -> b) -> a -> b
$ Integer -> [Day]
bankHolidays Integer
y0)
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Integer] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Integer -> Bool) -> [Integer] -> [Integer]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<Integer
y0) ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$ (Integer -> Bool) -> [Integer] -> [Integer]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<Integer
y1) [Integer]
extraYears))
Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
y1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
y0)
else Integer -> Integer
forall a. Num a => a -> a
negate (Day -> Day -> Integer
countBankHolidays Day
d1 Day
d0)
where
(Integer
y0,Int
_,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
d0
(Integer
y1,Int
_,Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
d1