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

feat(schedule-week): join multiple parallel exam occurrences (WIP)

Browse Source
This commit is contained in:
Sarah Vaupel 2020-08-23 21:05:08 +02:00
parent 7856aba24d
commit 280a19865c
5 changed files with 35 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/de-de-formal.msg
View File

@ -107,6 +107,7 @@ NewsHeadlineSchedule: Terminübersicht
ScheduleTableHeadTime: Zeit
ScheduleRoom: Raum
ScheduleRooms: Räume
ScheduleTime: Zeit
ScheduleOccur: Findet statt

1
messages/uniworx/en-eu.msg
View File

@ -107,6 +107,7 @@ NewsHeadlineSchedule: Schedule
ScheduleTableHeadTime: Time
ScheduleRoom: Room
ScheduleRooms: Rooms
ScheduleTime: Time
ScheduleOccur: Does occur

6
src/Utils/Schedule/Types.hs
View File

@ -12,7 +12,9 @@ import Import
data ScheduleEntry = ScheduleEntry
{ seCourse :: Entity Course -- TODO: just course?; TODO: Maybe?
, seType :: ScheduleEntryType
, seRoom :: ScheduleEntryRoom
, seRooms :: [ScheduleEntryRoom] -- multiple rooms in case of multiple parallel exam occurrences,
-- no room in case of no room info (Nothing) for tutorials
-- TODO: encode in ScheduleEntryType instead
, seOccurrence :: ScheduleEntryOccurrence
}
deriving (Generic, Typeable)
@ -26,7 +28,7 @@ data ScheduleEntryType = SETCourseEvent { setceType :: CI Text
}
deriving (Eq, Ord, Show, Read, Generic, Typeable)
type ScheduleEntryRoom = Maybe Text -- TODO: is Maybe Text okay for every ScheduleEntryType?
type ScheduleEntryRoom = Text
-- TODO: maybe introduce sum new type instead
type ScheduleEntryOccurrence = Either ScheduleEntryExamOccurrence (Either OccurrenceException OccurrenceSchedule)

31
src/Utils/Schedule/Week.hs
View File

@ -76,7 +76,7 @@ weekSchedule uid dayOffset = do
courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry]
courseEventToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) =
let seType = SETCourseEvent { setceType = courseEventType }
seRoom = Just courseEventRoom
seRooms = pure $ courseEventRoom
scheduleds
-- omit regular occurrences if the course's term is not currently active
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
@ -89,7 +89,7 @@ weekSchedule uid dayOffset = do
tutorialToScheduleEntries :: (Entity Course, Entity Tutorial) -> [ScheduleEntry]
tutorialToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialType,tutorialName,tutorialRoom,tutorialTime=Occurrences{..}}) =
let seType = SETTutorial { settType = tutorialType, settName = tutorialName }
seRoom = tutorialRoom
seRooms = maybe mempty pure tutorialRoom
scheduleds
-- omit regular occurrences if the course's term is not currently active
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
@ -99,15 +99,26 @@ weekSchedule uid dayOffset = do
let seOccurrence = Right (Left exception) in ScheduleEntry{..}
in scheduleds <> exceptions
examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, Entity ExamOccurrence) -> ScheduleEntry
examOccurrenceToScheduleEntry (seCourse@(Entity _ Course{}), Entity _ Exam{..}, Entity _ ExamOccurrence{..}) =
let seType = SETExamOccurrence
-- TODO: introduce type synonym for (Entity Course, Entity Exam, Entity ExamOccurrence)?
joinParallelExamOccurrences :: [(Entity Course, Entity Exam, Entity ExamOccurrence)] -> [(Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence))]
joinParallelExamOccurrences = go [] where
go acc [] = acc
go acc (examOcc@(course, exam, occ):examOccs) =
let ((((view _3) <$>) -> parallel), other) = partition (examOcc `isParallelTo`) examOccs
in go ((course, exam, occ:|parallel):acc) other
(Entity cid _, Entity eid _, Entity _ occ) `isParallelTo` (Entity cid' _, Entity eid' _, Entity _ occ') =
cid == cid' && eid == eid'
&& examOccurrenceStart occ == examOccurrenceStart occ' && examOccurrenceEnd occ == examOccurrenceEnd occ'
examOccurrenceToScheduleEntry :: (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence)) -> ScheduleEntry
examOccurrenceToScheduleEntry (seCourse@(Entity _ Course{}), Entity _ Exam{..}, examOccs@((Entity _ occ):|_)) =
let seType = SETExamOccurrence
{ seteoExamName = examName
}
seRoom = Just examOccurrenceRoom
seOccurrence = Left $ ScheduleEntryExamOccurrence
{ seeoStart = examOccurrenceStart
, seeoEnd = examOccurrenceEnd
seRooms = toList $ (examOccurrenceRoom . entityVal) <$> examOccs
seOccurrence = Left $ ScheduleEntryExamOccurrence -- multiple exam occurrences are joined on equality
{ seeoStart = examOccurrenceStart occ -- of start and end, so taking the timstamps of the first
, seeoEnd = examOccurrenceEnd occ -- occurrence suffices
}
in ScheduleEntry{..}
@ -131,7 +142,7 @@ weekSchedule uid dayOffset = do
, filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $
(courseEventToScheduleEntries <$> courseEvents)
<> (tutorialToScheduleEntries <$> tutorials)
<> pure (examOccurrenceToScheduleEntry <$> examOccurrences)
<> pure (examOccurrenceToScheduleEntry <$> (joinParallelExamOccurrences examOccurrences))
)
)

11
templates/widgets/schedule/week.hamlet
View File

@ -18,7 +18,7 @@ $newline never
<div .table__td-content>
$maybe dayEvents <- Map.lookup day events
$maybe slotEvents <- Map.lookup slot dayEvents
$forall se@ScheduleEntry{seCourse=Entity _ Course{courseName},seType,seRoom,seOccurrence} <- slotEvents
$forall se@ScheduleEntry{seCourse=Entity _ Course{courseName},seType,seRooms,seOccurrence} <- slotEvents
<a href=@{scheduleEntryToHref se} .schedule--entry-link>
<div .schedule--entry>
#{CI.original courseName}: #
@ -32,7 +32,12 @@ $newline never
#{seteoExamName} #
<br>
$maybe room <- seRoom
_{MsgScheduleRoom}: #{room} <br/>
$case seRooms
$of []
$of [room]
_{MsgScheduleRoom}: #{room}
$of rooms
_{MsgScheduleRooms}: #{intercalate ", " rooms}
<br>
^{formatOccurrenceW seOccurrence}