feat(terms): better prediction of term dates

src/Handler/Term.hs

@@ -13,15 +13,40 @@ import qualified Database.Esqueleto as E
 import qualified Data.Set as Set
 
 import qualified Control.Monad.State.Class as State
-  
 
--- | Default start day of term for season,
---   @True@: start of term, @False@: end of term
-defaultDay :: Bool -> Season -> Day
-defaultDay True  Winter = fromGregorian 2020 10  1
-defaultDay False Winter = fromGregorian 2020  3 31
-defaultDay True  Summer = fromGregorian 2020  4  1
-defaultDay False Summer = fromGregorian 2020  9 30
+import Data.Time.Calendar.WeekDate
+
+
+data TermDay
+  = TermDayStart | TermDayEnd
+  | TermDayLectureStart | TermDayLectureEnd
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+guessDay :: TermIdentifier
+         -> TermDay
+         -> Day
+guessDay TermIdentifier{ year, season = Winter } TermDayStart
+  = fromGregorian year 10 1
+guessDay TermIdentifier{ year, season = Winter } TermDayEnd
+  = fromGregorian (succ year) 3 31
+guessDay TermIdentifier{ year, season = Summer } TermDayStart
+  = fromGregorian year 4 1
+guessDay TermIdentifier{ year, season = Summer } TermDayEnd
+  = fromGregorian year 9 30
+guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureStart
+  = fromWeekDate year (wWeekStart + 2) 1
+  where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
+guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureEnd
+  = fromWeekDate (succ year) ((wWeekStart + 21) `div` bool 53 54 longYear) 5
+  where longYear = is _Just $ fromWeekDateValid year 53 1
+        (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart 
+guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureStart
+  = fromWeekDate year (wWeekStart + 2) 1
+  where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart 
+guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureEnd
+  = fromWeekDate year (wWeekStart + 17) 5
+  where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart 
 
 
 validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
@@ -133,16 +158,15 @@ postTermEditR = do
   mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
   let template = case mbLastTerm of
         Nothing -> mempty
-        (Just Entity{ entityVal=Term{..}}) -> let
-            ntid = succ termName
-            seas = season ntid
-            yr   = year   ntid
-            yr'  = if seas == Summer then yr else succ yr
-          in mempty
-              { tftName  = Just   ntid
-              , tftStart = Just $ defaultDay True  seas & setYear yr
-              , tftEnd   = Just $ defaultDay False seas & setYear yr'
-              }
+        (Just Entity{ entityVal=Term{..}})
+          -> let ntid = succ termName
+             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
+                  }
   termEditHandler Nothing template
 
 getTermEditExistR, postTermEditExistR :: TermId -> Handler Html