fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(terms): better prediction of term dates

Browse Source
This commit is contained in:
Gregor Kleen 2020-06-16 10:53:49 +02:00
parent cf06f79807
commit e5732df1b6
1 changed files with 42 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
src/Handler/Term.hs
View File

@ -13,15 +13,40 @@ import qualified Database.Esqueleto as E
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Control.Monad.State.Class as State import qualified Control.Monad.State.Class as State
-- | Default start day of term for season, import Data.Time.Calendar.WeekDate
-- @True@: start of term, @False@: end of term
defaultDay :: Bool -> Season -> Day
defaultDay True Winter = fromGregorian 2020 10 1 data TermDay
defaultDay False Winter = fromGregorian 2020 3 31 = TermDayStart | TermDayEnd
defaultDay True Summer = fromGregorian 2020 4 1 | TermDayLectureStart | TermDayLectureEnd
defaultDay False Summer = fromGregorian 2020 9 30 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) validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
@ -133,16 +158,15 @@ postTermEditR = do
mbLastTerm <- runDB $ selectFirst [] [Desc TermName] mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
let template = case mbLastTerm of let template = case mbLastTerm of
Nothing -> mempty Nothing -> mempty
(Just Entity{ entityVal=Term{..}}) -> let (Just Entity{ entityVal=Term{..}})
ntid = succ termName -> let ntid = succ termName
seas = season ntid in mempty
yr = year ntid { tftName = Just ntid
yr' = if seas == Summer then yr else succ yr , tftStart = Just $ guessDay ntid TermDayStart
in mempty , tftEnd = Just $ guessDay ntid TermDayEnd
{ tftName = Just ntid , tftLectureStart = Just $ guessDay ntid TermDayLectureStart
, tftStart = Just $ defaultDay True seas & setYear yr , tftLectureEnd = Just $ guessDay ntid TermDayLectureEnd
, tftEnd = Just $ defaultDay False seas & setYear yr' }
}
termEditHandler Nothing template termEditHandler Nothing template
getTermEditExistR, postTermEditExistR :: TermId -> Handler Html getTermEditExistR, postTermEditExistR :: TermId -> Handler Html