diff --git a/src/Utils/Schedule.hs b/src/Utils/Schedule.hs index 2cb91787c..afab06d66 100644 --- a/src/Utils/Schedule.hs +++ b/src/Utils/Schedule.hs @@ -8,6 +8,10 @@ import Import import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E +import Handler.Utils.Course (showCourseEventRoom) +import Handler.Utils.Exam (showExamOccurrenceRoom) +import Handler.Utils.Tutorial (showTutorialRoom) + import Utils.Course import Utils.Tutorial @@ -25,21 +29,27 @@ fetchCourseEventsScheduleInfo muid ata now = E.select $ E.from $ \(course `E.Inn E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse E.where_ $ courseEventShouldBeDisplayedInSchedule muid ata course courseEvent E.&&. mayViewCourse muid ata now course Nothing -- should not be necessary, but let's be on the safe side - return (course, courseEvent) + let showRoom = maybe E.false (flip showCourseEventRoom courseEvent . E.val) muid + E.||. E.not_ (courseEvent E.^. CourseEventRoomHidden) + return (course, courseEvent, showRoom) fetchTutorialsScheduleInfo :: MonadHandler m => Maybe UserId -> AuthTagActive -> UTCTime -> ReaderT SqlBackend m [ScheduleTutorialInfo] fetchTutorialsScheduleInfo muid ata now = E.select $ E.from $ \(course `E.InnerJoin` tutorial) -> do E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse E.where_ $ tutorialShouldBeDisplayedInSchedule muid ata course tutorial E.&&. mayViewCourse muid ata now course Nothing -- should not be necessary, but let's be on the safe side - return (course, tutorial) + let showRoom = maybe E.false (flip showTutorialRoom tutorial . E.val) muid + E.||. E.not_ (tutorial E.^. TutorialRoomHidden) + return (course, tutorial, showRoom) fetchExamOccurrencesScheduleInfo :: MonadHandler m => Maybe UserId -> AuthTagActive -> UTCTime -> ReaderT SqlBackend m [ScheduleExamOccurrenceInfo] fetchExamOccurrencesScheduleInfo muid ata now = E.select $ E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examOccurrence) -> do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ exam E.^. ExamId E.==. examOccurrence E.^. ExamOccurrenceExam E.where_ $ examOccurrenceShouldBeDisplayedInSchedule muid ata now course exam examOccurrence - return (course, exam, examOccurrence) + let showRoom = maybe E.false (flip showExamOccurrenceRoom examOccurrence . E.val) muid + E.||. E.not_ (examOccurrence E.^. ExamOccurrenceRoomHidden) + return (course, exam, examOccurrence, showRoom) courseEventShouldBeDisplayedInSchedule :: Maybe UserId -> AuthTagActive -> E.SqlExpr (Entity Course) -> E.SqlExpr (Entity CourseEvent) -> E.SqlExpr (E.Value Bool) diff --git a/src/Utils/Schedule/Types.hs b/src/Utils/Schedule/Types.hs index 9fe8bdf9f..791f6c72e 100644 --- a/src/Utils/Schedule/Types.hs +++ b/src/Utils/Schedule/Types.hs @@ -4,6 +4,8 @@ module Utils.Schedule.Types import Import +import qualified Database.Esqueleto as E + import Utils.Schedule.Types.ScheduleEntry as Utils.Schedule.Types import Utils.Schedule.Types.ScheduleView as Utils.Schedule.Types import Utils.Schedule.Types.ScheduleOffset as Utils.Schedule.Types @@ -11,7 +13,25 @@ import Utils.Schedule.Types.ScheduleOptions as Utils.Schedule.Types -- TODO: replace Info types with one joined type and fetch info in one single runDB -type ScheduleCourseEventInfo = (Entity Course, Entity CourseEvent) -type ScheduleTutorialInfo = (Entity Course, Entity Tutorial) -type ScheduleExamOccurrenceInfo = (Entity Course, Entity Exam, Entity ExamOccurrence) -type ScheduleExamOccurrenceJoinedInfo = (Entity Course, Entity Exam, NonEmpty (Entity ExamOccurrence)) + +type ScheduleCourseEventInfo = ( Entity Course + , Entity CourseEvent + , E.Value Bool -- showRoom + ) + +type ScheduleTutorialInfo = ( Entity Course + , Entity Tutorial + , E.Value Bool -- showRoom + ) + +type ScheduleExamOccurrenceInfo = ( Entity Course + , Entity Exam + , Entity ExamOccurrence + , E.Value Bool -- showRoom + ) +type ScheduleExamOccurrenceJoinedInfo = ( Entity Course + , Entity Exam + , NonEmpty ( Entity ExamOccurrence + , E.Value Bool -- showRoom + ) + ) diff --git a/src/Utils/Schedule/Types/ScheduleEntry.hs b/src/Utils/Schedule/Types/ScheduleEntry.hs index 3365d3a68..e2edf21d5 100644 --- a/src/Utils/Schedule/Types/ScheduleEntry.hs +++ b/src/Utils/Schedule/Types/ScheduleEntry.hs @@ -9,7 +9,7 @@ data ScheduleEntry = ScheduleCourseEvent { sceCourse :: Entity Course , sceType :: CourseEventType , sceRoom :: Maybe RoomReference - , sceRoomHidden :: Bool + , sceShowRoom :: Bool , sceOccurrence :: Either OccurrenceException OccurrenceSchedule , sceNoOccur :: Set LocalTime , sceTerm :: Entity Term @@ -19,7 +19,7 @@ data ScheduleEntry = ScheduleCourseEvent , stName :: TutorialName , stType :: TutorialType , stRoom :: Maybe RoomReference - , stRoomHidden :: Bool + , stShowRoom :: Bool , stOccurrence :: Either OccurrenceException OccurrenceSchedule , stNoOccur :: Set LocalTime , stTerm :: Entity Term @@ -27,7 +27,7 @@ data ScheduleEntry = ScheduleCourseEvent | ScheduleExamOccurrence { seoCourse :: Entity Course , seoExamName :: ExamName - , seoRooms :: NonEmpty (Maybe RoomReference) -- TODO: remove Nothing values and use NonEmpty RoomReference instead -- TODO: NonEmpty (RoomReference, Bool) for hidden + , seoRooms :: NonEmpty (Maybe RoomReference, Bool) -- TODO: remove Nothing values and use NonEmpty (RoomReference, Bool) instead? , seoStart :: UTCTime , seoEnd :: Maybe UTCTime } diff --git a/src/Utils/Schedule/Week.hs b/src/Utils/Schedule/Week.hs index fc297f143..bcca0bbd3 100644 --- a/src/Utils/Schedule/Week.hs +++ b/src/Utils/Schedule/Week.hs @@ -9,6 +9,8 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Database.Esqueleto as E + import Handler.Utils.DateTime (formatTimeRangeW, formatTimeW, utcToLocalTime, localTimeToUTCSimple) import Handler.Utils.Widgets (roomReferenceWidget) @@ -101,7 +103,7 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u holidays = concatMap (termHolidays . entityVal) activeTerms courseEventToScheduleEntries :: ScheduleCourseEventInfo -> [ScheduleEntry] - courseEventToScheduleEntries (sceCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType=sceType,courseEventRoom=sceRoom,courseEventRoomHidden=sceRoomHidden,courseEventTime=Occurrences{..}}) + courseEventToScheduleEntries (sceCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType=sceType,courseEventRoom=sceRoom,courseEventTime=Occurrences{..}}, E.Value sceShowRoom) | [sceTerm] <- filter ((== courseTerm) . entityKey) activeTerms , termActive $ entityVal sceTerm = let scheduleds @@ -115,7 +117,7 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u | otherwise = mempty tutorialToScheduleEntries :: ScheduleTutorialInfo -> [ScheduleEntry] - tutorialToScheduleEntries (stCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialName=stName,tutorialType=stType,tutorialRoom=stRoom,tutorialRoomHidden=stRoomHidden,tutorialTime=Occurrences{..}}) + tutorialToScheduleEntries (stCourse@(Entity _ Course{..}), Entity _ Tutorial{tutorialName=stName,tutorialType=stType,tutorialRoom=stRoom,tutorialTime=Occurrences{..}}, E.Value stShowRoom) | [stTerm] <- filter ((== courseTerm) . entityKey) activeTerms , termActive $ entityVal stTerm = let scheduleds @@ -133,16 +135,16 @@ weekSchedule now user@(Entity uid User{userScheduleWeekDays = ScheduleWeekDays u joinParallelExamOccurrences :: [ScheduleExamOccurrenceInfo] -> [ScheduleExamOccurrenceJoinedInfo] 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') = + go acc (examOcc@(course, exam, occ, showRoom):examOccs) = + let ((((\(_,_,o,s) -> (o,s)) <$>) -> parallel), other) = partition (examOcc `isParallelTo`) examOccs + in go ((course, exam, (occ,showRoom):|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 :: ScheduleExamOccurrenceJoinedInfo -> ScheduleEntry - examOccurrenceToScheduleEntry (seoCourse@(Entity _ Course{}), Entity _ Exam{examName=seoExamName}, examOccs@((Entity _ occ):|_)) = - let seoRooms = (examOccurrenceRoom . entityVal) <$> examOccs + examOccurrenceToScheduleEntry (seoCourse@(Entity _ Course{}), Entity _ Exam{examName=seoExamName}, examOccs@((Entity _ occ, _):|_)) = + let seoRooms = (\(Entity _ ExamOccurrence{examOccurrenceRoom}, E.Value showRoom) -> (examOccurrenceRoom, showRoom)) <$> examOccs seoStart = examOccurrenceStart occ -- multiple exam occurrences are joined on equality of start and end, seoEnd = examOccurrenceEnd occ -- so taking the timestamps of the first occurrence suffices in ScheduleExamOccurrence{..} diff --git a/templates/schedule/week.hamlet b/templates/schedule/week.hamlet index 4b70743de..80af7a39f 100644 --- a/templates/schedule/week.hamlet +++ b/templates/schedule/week.hamlet @@ -26,19 +26,20 @@ $newline never
$case scheduleEntry - $of ScheduleCourseEvent{sceCourse=Entity _ Course{courseName},sceType,sceRoom,sceRoomHidden,sceOccurrence} + $of ScheduleCourseEvent{sceCourse=Entity _ Course{courseName},sceType,sceRoom,sceShowRoom,sceOccurrence} #{CI.original courseName}: #{CI.original sceType} # $if slotAssocIsCont slotAssociation (_{MsgScheduleWeekSlotIsCont})
- $if (not sceRoomHidden) + $if sceShowRoom + _{MsgScheduleRoom}: # $maybe room <- sceRoom - _{MsgScheduleRoom}: ^{roomReferenceWidget room} + ^{roomReferenceWidget room} $nothing _{MsgCourseEventRoomIsUnset}
^{formatEitherOccurrenceW sceOccurrence} - $of ScheduleTutorial{stCourse=Entity _ Course{courseName},stName,stType,stRoom,stRoomHidden,stOccurrence} + $of ScheduleTutorial{stCourse=Entity _ Course{courseName},stName,stType,stRoom,stShowRoom,stOccurrence} #{CI.original courseName}: #{stName} # ( #{CI.original stType} @@ -46,9 +47,10 @@ $newline never , _{MsgScheduleWeekSlotIsCont} )
- $if (not stRoomHidden) + $if stShowRoom + _{MsgScheduleRoom}: # $maybe room <- stRoom - _{MsgScheduleRoom}: ^{roomReferenceWidget room} + ^{roomReferenceWidget room} $nothing _{MsgTutorialRoomIsUnset}
@@ -58,16 +60,17 @@ $newline never $if slotAssocIsCont slotAssociation (_{MsgScheduleWeekSlotIsCont})
- $case catMaybes (toList seoRooms) - $of [room] - _{MsgScheduleRoom}: ^{roomReferenceWidget room} -
+ $case toList seoRooms + $of [(mRoom,showRoom)] + $if showRoom + _{MsgScheduleRoom}: ^{maybe mempty roomReferenceWidget mRoom} +
$of more _{MsgScheduleRooms}: # - $forall room <- more - ^{roomReferenceWidget room} + $forall (mRoom,showRoom) <- more + $if showRoom + ^{maybe mempty roomReferenceWidget mRoom}
- $of [] _{MsgScheduleOccur}: # $if Just (utctDay seoStart) == fmap utctDay seoEnd ^{formatTimeRangeW SelFormatTime seoStart seoEnd}