@@ -0,0 +1,43 @@
1+-- {-# OPTIONS_GHC -fwarn-name-shadowing #-}
2+
3+module Data.Time.Holidays
4+ ( addTimeExcludingHolidays
5+ ) where
6+
7+import Data.Proxy
8+import qualified Data.Set as S
9+import Data.Time
10+import Data.Time.Calendar.OrdinalDate
11+import Data.Time.LocalTime.TimeZone.Series
12+
13+
14+addTimeExcludingHolidays
15+ :: S.Set Day
16+ -> TimeZoneSeries
17+ -> DiffTime
18+ -> UTCTime
19+ -> UTCTime
20+addTimeExcludingHolidays hDays tz dTime =
21+ addLocalTime' dTime . utcToLocalTime' tz
22+ where
23+ shouldSkip day = weekday `elem` [6, 7] || day `S.member` hDays
24+ where (_, weekday) = mondayStartWeek day
25+ dayPicoseconds =
26+ diffTimeToPicoseconds . secondsToDiffTime $ 60 * 60 * 24
27+ addLocalTime' :: DiffTime -> LocalTime -> UTCTime
28+ addLocalTime' dTime' (LocalTime lDay' lTime') =
29+ let
30+ actualDays = filter (not . shouldSkip) [lDay'..]
31+ -- Jumps to nearest day if `now` is a holiday
32+ lTime = if shouldSkip lDay'
33+ then midnight
34+ else lTime'
35+ -- At this point the head of `actualDays` and `lTime`
36+ -- is the day from which we should be counting
37+ (dDays, dPicoSeconds) =
38+ (diffTimeToPicoseconds $ dTime' + (timeOfDayToTime lTime))
39+ `divMod` dayPicoseconds
40+ resultDay = head . drop (fromIntegral dDays) $ actualDays
41+ resultTime =
42+ timeToTimeOfDay . picosecondsToDiffTime $ dPicoSeconds
43+ in localTimeToUTC' tz $ LocalTime resultDay resultTime