chore(terms): add holiday presets; fix term edit error messages

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
+                  { tftName         = Just ntid
-                  , tftStart = Just $ guessDay ntid TermDayStart
+                  , tftStart        = Just tStart 
-                  , tftEnd   = Just $ guessDay ntid TermDayEnd
+                  , tftEnd          = Just tEnd  
-                  , tftLectureStart = Just $ guessDay ntid TermDayLectureStart
+                  , tftLectureStart = Just tLecStart
-                  , tftLectureEnd   = Just $ guessDay ntid TermDayLectureEnd
+                  , 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 ()
+      FormMissing      -> return ()
-      (FormFailure _) -> addMessageI Warning MsgInvalidInput
+      FormFailure []   -> addMessageI Error MsgInvalidInput
+      FormFailure msgs -> forM_ msgs (addMessage Error . toHtml)
     defaultLayout $ do
       setTitleI MsgTermEditHeading
       wrapForm formWidget def

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
 

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 ]

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`