fradrive-old/src/Utils/Holidays.hs

-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-|
Module: Utils.Holidays
Description: German bank holidays

Interfaces follows module Data.Time.Calendar.BankHoliday.EnglandAndWales 
isBankHolidayArea uses laziness to provide some simple memoization for a fixed range of years
-}
module Utils.Holidays
  ( Feiertagsgebiet(..)  
  , feiertage
  , bankHolidays, bankHolidaysArea, bankHolidaysAreaSet
  , isBankHoliday, isBankHolidayArea 
  , isWeekend
  , addBusinessDays
  ) where

import Import.NoModel

import qualified Data.Set as Set (Set, member)
import qualified Data.Map as Map

--import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.Easter (gregorianEaster)


-- | Some areas / companies within Germany.
-- | The datatype is not yet complete.
data Feiertagsgebiet = Deutschland | Hessen | Bayern | Munich | Fraport 
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
  deriving anyclass (Universe, Finite)

-- | List the bank holidays for the given year >= 1995, in ascending order. 
-- | Holidays on a weekend are legally considered holidays in some German states, hence
-- | the behaviour differs from Data.Time.Calendar.BankHoliday.EnglandAndWales by including holidays on Sundays.
-- | Included for compatibility with Data.Time.Calendar.BankHoliday.EnglandAndWales 
bankHolidays :: Integer -> [Day]
bankHolidays = bankHolidaysArea Deutschland

-- | Bank holidays for a region within Germany and a given year >= 1995.
-- | Holidays may occur on a sunday.
-- | For convenience and compatibility.
bankHolidaysArea :: Feiertagsgebiet -> Integer -> [Day]
bankHolidaysArea land year = Map.keys $ feiertage land year 

-- | Bank holidays for a region within Germany and a given year >= 1995.
-- | Holidays may occur on a sunday.
bankHolidaysAreaSet :: Feiertagsgebiet -> Integer -> Set.Set Day
bankHolidaysAreaSet land year = Map.keysSet $ feiertage land year 

-- | Bank holidays for a region within Germany and a given year >= 1995, 
-- | mapped to the german name of each day.
-- | Holidays may occur on a sunday.
feiertage :: Feiertagsgebiet -> Integer -> Map.Map Day String
feiertage land year = case land of     
    Deutschland -> standardHolidays
    Bayern      -> bavarianHolidays
    Munich      ->   munichHolidays
    Hessen      ->  hessianHolidays
    Fraport     ->  fraportHolidays
  where
    easterSunday = gregorianEaster year 
    easterSundayPlus = flip addDays easterSunday

    standardHolidays = Map.fromList
      [ (fromGregorian year  1  1, "Neujahr")      
      , (easterSundayPlus (-2)   , "Karfreitag")
      , (easterSunday            , "Ostersonntag")
      , (easterSundayPlus   1    , "Ostermontag")
      , (fromGregorian year  5  1, "Erster Mai")      
      , (easterSundayPlus 39     , "Himmelfahrt")
      , (easterSundayPlus 49     , "Pfingstsonntag")
      , (easterSundayPlus 50     , "Pfingstmontag")      
      , (fromGregorian year 10  3, "Tag der deutschen Einheit")
      , (fromGregorian year 12 25, "Erster Weihnachtstag")
      , (fromGregorian year 12 26, "Zweiter Weihnachtstag")
      ]

    hessianHolidays = standardHolidays <> map_singleton 
        (easterSundayPlus 60     , "Fronleichnam")      

    bavarianHolidays = hessianHolidays <> Map.fromList
      [ (fromGregorian year  1  6, "Heilige Drei Könige")
      , (fromGregorian year 11  1, "Allerheiligen")
      ]

    munichHolidays = bavarianHolidays <> map_singleton
        (fromGregorian year  8 15, "Maria Himmelfahrt")
    
    fraportHolidays = hessianHolidays <> Map.fromList
      [ (fromGregorian year 12 24, "Heiligabend")
      , (fromGregorian year 12 31, "Sylvester")
      ]

    map_singleton = uncurry Map.singleton

-- | For compatibility with with Data.Time.Calendar.BankHoliday.EnglandAndWales 
-- | only for works for year >= 1995
isBankHoliday :: Day -> Bool
isBankHoliday = isBankHolidayArea Deutschland 

{-- Inefficient, since entire year of holidays is computed for each call 
isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool
isBankHolidayArea land dd = dd `Set.member` holidays
  where 
    (year, _, _) = toGregorian dd
    holidays = bankHolidaysAreaSet land year
-}

-- | Returns whether a day is a bank holiday for years >= 1995
-- | Repeated calls are handled efficiently using lazy memoization 
isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool
isBankHolidayArea land = ibha
  where 
    landHoliday = Map.lookup land memoHolidays 
    ibha dd     = dd `Set.member` holidays
      where 
        (year, _, _) = toGregorian dd
        holidays 
          | (Just hys) <- landHoliday
          , (Just hds) <- index hys $ fromInteger $ year2index year = hds
          | otherwise = bankHolidaysAreaSet land year 

-- memoize holidays 
memoHolidays :: Map.Map Feiertagsgebiet [Set.Set Day]
memoHolidays = Map.fromList  [(land,
                                  [bankHolidaysAreaSet land year
                                  | i <- [0..], let year = index2year i]) 
                              | land <- universeF]    

-- year with fastest access
memoTip :: Integer
memoTip = 2030

year2index :: Integer -> Integer
year2index y 
  | y < memoTip = 2 * (memoTip - y) - 1  
  | otherwise   = 2 * (y - memoTip)

index2year :: Integer -> Integer
index2year y = result
  where 
    (x,r) = y `divMod` 2 
    result | r == 0    = memoTip + x 
           | otherwise = memoTip - x - 1

-- | Test for Saturday/Sunday 
isWeekend :: Day -> Bool
isWeekend = isWeekend' . dayOfWeek 
  where 
    isWeekend' :: WeekDay -> Bool
    isWeekend' Sunday   = True 
    isWeekend' Saturday = True 
    isWeekend' _        = False

-- | Always returns a business day. 
-- | Saturday/Sunday/Holiday treated like next (n>=0) or previous (n<0) working day
addBusinessDays :: Feiertagsgebiet -> Integer -> Day -> Day
addBusinessDays land = abd 
  where 
    ibhal        = isBankHolidayArea land 
    freeday   dd = isWeekend dd || ibhal dd 
    abd n = abd' n
      where         
        (fwd, bwd)  | n >= 0    = (succ, pred)
                    | otherwise = (pred, succ)
        abd' m dd | freeday dd = abd'      m  (fwd dd)              
                  | m == 0     =                   dd
                  | otherwise  = abd' (bwd m) (fwd dd)