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

fix(fill): correct term start day guessing

Browse Source
This commit is contained in:
Steffen Jost 2021-09-30 09:41:23 +02:00
parent 30d5af00bf
commit 538aa5b3b9
2 changed files with 12 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Model/Types/DateTime.hs
View File

@ -167,10 +167,10 @@ guessDay TermIdentifier{ year, season = Q2 } TermDayStart = fromGregorian year
guessDay TermIdentifier{ year, season = Q3 } TermDayStart = fromGregorian year 7 1 guessDay TermIdentifier{ year, season = Q3 } TermDayStart = fromGregorian year 7 1
guessDay TermIdentifier{ year, season = Q4 } TermDayStart = fromGregorian year 10 1 guessDay TermIdentifier{ year, season = Q4 } TermDayStart = fromGregorian year 10 1
guessDay tid TermDayEnd = pred $ guessDay (succ tid) TermDayStart guessDay tid TermDayEnd = pred $ guessDay (succ tid) TermDayStart
guessDay tid@TermIdentifier{ year } TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter guessDay tid TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter
where (_, weekStart, _) = toWeekDate $ guessDay tid TermDayStart where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayStart
guessDay tid@TermIdentifier{ year } TermDayLectureEnd = fromWeekDate year weekStart 5 -- Friday of last week within Quarter guessDay tid TermDayLectureEnd = fromWeekDate year weekStart 5 -- Friday of last week within Quarter
where (_, weekStart, _) = toWeekDate $ guessDay tid TermDayEnd where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayEnd
withinTerm :: Day -> TermIdentifier -> Bool withinTerm :: Day -> TermIdentifier -> Bool
withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd

16
test/Database/Fill.hs
View File

@ -66,7 +66,7 @@ fillDb = do
prevTerm = pred currentTerm prevTerm = pred currentTerm
prevPrevTerm = pred prevTerm prevPrevTerm = pred prevTerm
seasonTerm next wSeason = until (((==) wSeason) . season) prog currentTerm seasonTerm next wSeason = until ((wSeason ==) . season) prog currentTerm
where prog | next = succ where prog | next = succ
| otherwise = pred | otherwise = pred
@ -597,7 +597,7 @@ fillDb = do
|] |]
, courseLinkExternal = Nothing , courseLinkExternal = Nothing
, courseShorthand = "F" , courseShorthand = "F"
, courseTerm = TermKey $ currentTerm , courseTerm = TermKey currentTerm
, courseSchool = avn , courseSchool = avn
, courseCapacity = Nothing , courseCapacity = Nothing
, courseVisibleFrom = Just now , courseVisibleFrom = Just now
@ -618,10 +618,10 @@ fillDb = do
forM_ [(Monday)..Thursday] $ \td -> do forM_ [(Monday)..Thursday] $ \td -> do
forM_ [(1::Int)..(4*4)] $ \tw -> do forM_ [(1::Int)..(4*4)] $ \tw -> do
let firstTT = utctDay $ termTime True (season currentTerm) (toRational $ tw - 1) False td (toMorning) let firstTT = utctDay $ termTime True (season currentTerm) (toRational $ tw - 1) False td toMorning
secondTT = utctDay $ termTime True (season currentTerm) (toRational $ tw - 1) False (succ td) (toMorning) secondTT = utctDay $ termTime True (season currentTerm) (toRational $ tw - 1) False (succ td) toMorning
tut1 <- insert Tutorial tut1 <- insert Tutorial
{ tutorialName = CI.mk $ Text.pack $ "KW" ++ (show $ snd3 $ toWeekDate firstTT) ++ (take 3 $ show td) { tutorialName = CI.mk $ Text.pack $ "KW" ++ show (snd3 $ toWeekDate firstTT) ++ take 3 (show td)
, tutorialCourse = fdf , tutorialCourse = fdf
, tutorialType = "Schulung" , tutorialType = "Schulung"
, tutorialCapacity = Just 16 , tutorialCapacity = Just 16
@ -647,8 +647,8 @@ fillDb = do
] ]
} }
, tutorialRegGroup = Just "schulung" , tutorialRegGroup = Just "schulung"
, tutorialRegisterFrom = Just $ termTime True (season currentTerm) (toRational $ tw - 9) False td (toMorning) , tutorialRegisterFrom = Just $ termTime True (season currentTerm) (toRational $ tw - 9) False td toMorning
, tutorialRegisterTo = Just $ termTime True (season currentTerm) (toRational $ tw - 2) False td (toMorning) , tutorialRegisterTo = Just $ termTime True (season currentTerm) (toRational $ tw - 2) False td toMorning
, tutorialDeregisterUntil = Nothing , tutorialDeregisterUntil = Nothing
, tutorialLastChanged = now , tutorialLastChanged = now
, tutorialTutorControlled = True , tutorialTutorControlled = True
@ -951,7 +951,7 @@ fillDb = do
, let uploadEmptyOk = False , let uploadEmptyOk = False
] ]
sheetCombinations = ((,,) <$> shTypes <*> shGroupings <*> shSubModes) sheetCombinations = (,,) <$> shTypes <*> shGroupings <*> shSubModes
forM_ (zip [0..] sheetCombinations) $ \(shNr, (sheetType, sheetGrouping, sheetSubmissionMode)) -> do forM_ (zip [0..] sheetCombinations) $ \(shNr, (sheetType, sheetGrouping, sheetSubmissionMode)) -> do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer