From f1f510c24cbf9ae54d6d1c71b1bb7e138be8f4c9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 30 Sep 2021 11:35:32 +0200 Subject: [PATCH] chore(terms): add holiday presets; fix term edit error messages --- src/Handler/Term.hs | 27 +++++--- src/Handler/Utils/DateTime.hs | 7 +- src/Utils/Holidays.hs | 123 ++++++++++++++++++++++++++++++++++ src/index.md | 3 + 4 files changed, 151 insertions(+), 9 deletions(-) create mode 100644 src/Utils/Holidays.hs diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index ff57fc8ce..45c820818 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -7,6 +7,7 @@ module Handler.Term import Import import Utils.Course (mayViewCourse) +import Utils.Holidays (bankHolidaysAreaSet, Feiertagsgebiet(..)) import Handler.Utils @@ -140,13 +141,22 @@ postTermEditR = do let template = case mbLastTerm of Nothing -> mempty (Just Entity{ entityVal=Term{..}}) - -> let ntid = succ termName + -> let ntid = succ termName + tStart = guessDay ntid TermDayStart + tEnd = guessDay ntid TermDayEnd + tLecStart = guessDay ntid TermDayLectureStart + tLecEnd = guessDay ntid TermDayLectureEnd + tHolys = Set.toAscList $ + Set.filter (tStart <=) $ + Set.filter (tEnd >=) $ + Set.unions $ bankHolidaysAreaSet Fraport <$> [getYear tStart..getYear tEnd] in mempty - { tftName = Just ntid - , tftStart = Just $ guessDay ntid TermDayStart - , tftEnd = Just $ guessDay ntid TermDayEnd - , tftLectureStart = Just $ guessDay ntid TermDayLectureStart - , tftLectureEnd = Just $ guessDay ntid TermDayLectureEnd + { tftName = Just ntid + , tftStart = Just tStart + , tftEnd = Just tEnd + , tftLectureStart = Just tLecStart + , tftLectureEnd = Just tLecEnd + , tftHolidays = Just tHolys } termEditHandler Nothing template @@ -195,8 +205,9 @@ termEditHandler mtid template = do lift . audit $ TransactionTermEdit tid addMessageI Success $ MsgTermEdited tid redirect TermShowR - FormMissing -> return () - (FormFailure _) -> addMessageI Warning MsgInvalidInput + FormMissing -> return () + FormFailure [] -> addMessageI Error MsgInvalidInput + FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) defaultLayout $ do setTitleI MsgTermEditHeading wrapForm formWidget def diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 7b7dfd322..c39d24103 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -15,7 +15,7 @@ module Handler.Utils.DateTime , addLocalDays , addOneWeek, addWeeks , weeksToAdd - , setYear + , setYear, getYear , ceilingQuarterHour , formatGregorianW ) where @@ -219,6 +219,11 @@ setYear year date = fromGregorian year m d where (_,m,d) = toGregorian date +getYear :: Day -> Integer +getYear date = y + where + (y,_,_) = toGregorian date + addOneWeek :: UTCTime -> UTCTime addOneWeek = addWeeks 1 diff --git a/src/Utils/Holidays.hs b/src/Utils/Holidays.hs new file mode 100644 index 000000000..71235acf6 --- /dev/null +++ b/src/Utils/Holidays.hs @@ -0,0 +1,123 @@ +{-| +Module: Utils.Holidays +Description: German bank holidays + +Following module Data.Time.Calendar.BankHoliday.EnglandAndWales +-} +module Utils.Holidays + ( Feiertagsgebiet(..) + , feiertage + , bankHolidays, bankHolidaysArea, bankHolidaysAreaSet + , isBankHoliday, isBankHolidayArea + ) where + +import Import.NoModel + +import qualified Data.Set as Set (Set, member, unions) +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, Typeable) + 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 a lazy cache for 2020--2075 +isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool +isBankHolidayArea land dd = dd `Set.member` holidays + where + (year, _, _) = toGregorian dd + holidays + | year >= cacheMinYear + , year <= cacheMaxYear + , (Just hds) <- Map.lookup land cacheHolidays = hds + | otherwise = bankHolidaysAreaSet land year + +cacheMinYear, cacheMaxYear :: Integer +cacheMinYear = 2020 +cacheMaxYear = 2075 + +cacheHolidays :: Map.Map Feiertagsgebiet (Set.Set Day) +cacheHolidays = Map.fromList [ (land, Set.unions $ bankHolidaysAreaSet land <$> [cacheMinYear..cacheMaxYear]) | land <- universeF ] diff --git a/src/index.md b/src/index.md index 4dceca669..c796619da 100644 --- a/src/index.md +++ b/src/index.md @@ -33,6 +33,9 @@ Utils.DateTime : Template Haskell code-generatoren zum compile-time einbinden von Zeitzone und `TimeLocale` +Utils.Holidays + : Definition deutscher Feiertage + Handler.Utils, Handler.Utils.* : Hilfsfunktionien, importieren `Import`