feat(schedule): include exam occurrences (WIP)
This commit is contained in:
Sarah Vaupel
parent
3254d34dc4
commit
3416e63f6f
@ -1,184 +1,5 @@
|
||||
module Utils.Schedule
|
||||
( weekSchedule
|
||||
( module Utils.Schedule
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
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)
|
||||
|
||||
import Utils.Schedule.Types
|
||||
import Utils.Course (mayViewCourse)
|
||||
|
||||
|
||||
-- TODO: very temporary slot representation
|
||||
type TimeSlot = Int
|
||||
firstSlot, lastSlot, slotStep :: Int
|
||||
firstSlot = 8
|
||||
lastSlot = 20
|
||||
slotStep = 2
|
||||
|
||||
slotsToDisplay :: [TimeSlot]
|
||||
slotsToDisplay = [firstSlot,firstSlot+slotStep..lastSlot]
|
||||
|
||||
slotToDisplayTime :: TimeSlot -> Widget
|
||||
slotToDisplayTime t = formatTimeRangeW SelFormatTime (TimeOfDay t 0 0) $ Just $ TimeOfDay (t + slotStep) 0 0
|
||||
|
||||
|
||||
-- TODO: implement weekOffset
|
||||
weekSchedule :: UserId -> Maybe Int -> Widget
|
||||
weekSchedule uid _weekOffset = do
|
||||
now <- liftIO getCurrentTime
|
||||
ata <- getSessionActiveAuthTags
|
||||
|
||||
-- TODO: single runDB for all fetches below?
|
||||
|
||||
activeTerms <- liftHandler . runDB $ E.select $ E.from $ \term -> do
|
||||
E.where_ $ term E.^. TermActive
|
||||
return $ term E.^. TermId
|
||||
|
||||
-- TODO: fetch course events for this week only?
|
||||
courseEvents <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse
|
||||
E.where_ $ (E.exists $ E.from $ \courseParticipant -> E.where_ $
|
||||
courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
E.&&. courseParticipant E.^. CourseParticipantUser E.==. E.val uid
|
||||
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
E.&&. mayViewCourse (Just uid) ata now course Nothing
|
||||
) E.||. (E.exists $ E.from $ \lecturer -> E.where_ $
|
||||
lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. lecturer E.^. LecturerUser E.==. E.val uid
|
||||
)
|
||||
return (course, courseEvent)
|
||||
|
||||
tutorials <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` tutorial) -> do
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ (E.exists $ E.from $ \tutorialParticipant -> E.where_ $
|
||||
tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
|
||||
) E.||. (E.exists $ E.from $ \tutor -> E.where_ $
|
||||
tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.&&. tutor E.^. TutorUser E.==. E.val uid
|
||||
)
|
||||
return (course, tutorial)
|
||||
|
||||
-- TODO: fetch exam occurrences for exam participants and lecturers?
|
||||
|
||||
let
|
||||
courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry]
|
||||
courseEventToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) =
|
||||
let seType = SETCourseEvent { setceType = courseEventType }
|
||||
seRoom = Just courseEventRoom
|
||||
scheduleds
|
||||
-- omit regular occurrences if the course's term is not currently active
|
||||
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
|
||||
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
|
||||
let seOccurrence = Right scheduled in ScheduleEntry{..}
|
||||
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
||||
let seOccurrence = Left exception in ScheduleEntry{..}
|
||||
in scheduleds <> exceptions
|
||||
|
||||
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
|
||||
scheduleds
|
||||
-- omit regular occurrences if the course's term is not currently active
|
||||
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
|
||||
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
|
||||
let seOccurrence = Right scheduled in ScheduleEntry{..}
|
||||
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
||||
let seOccurrence = Left exception in ScheduleEntry{..}
|
||||
in scheduleds <> exceptions
|
||||
|
||||
seOccurrenceIsInSlot :: Day -> TimeSlot -> ScheduleEntryOccurrence -> Bool
|
||||
seOccurrenceIsInSlot day slot seOcc =
|
||||
let
|
||||
(day', start, _mEnd) = case seOcc of
|
||||
Right ScheduleWeekly{..} -> (scheduleDayOfWeek `dayOfWeekToDayWith` now, scheduleStart, Just scheduleEnd)
|
||||
Left ExceptOccur{..} -> (exceptDay, exceptStart, Just exceptEnd)
|
||||
Left ExceptNoOccur{exceptTime=LocalTime{..}} -> (localDay, localTimeOfDay, Nothing)
|
||||
in day == day' && TimeOfDay slot 0 0 <= start && start < TimeOfDay (slot+slotStep) 0 0
|
||||
|
||||
events' :: Map Day (Map TimeSlot [ScheduleEntry])
|
||||
events' = Map.fromList $ currentWeek <&> \day ->
|
||||
( day
|
||||
, Map.fromList $ slotsToDisplay <&> \slot ->
|
||||
( slot
|
||||
, filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $
|
||||
(courseEventToScheduleEntries <$> courseEvents)
|
||||
<> (tutorialToScheduleEntries <$> tutorials)
|
||||
-- TODO: incluse exams (maybe)
|
||||
)
|
||||
)
|
||||
|
||||
events :: Map Day (Map TimeSlot [ScheduleEntry])
|
||||
events = events' <&> \slotsPerDay -> slotsPerDay <&> \occurrencesInSlot ->
|
||||
let
|
||||
isRegularWithoutException :: ScheduleEntry -> Bool
|
||||
isRegularWithoutException = \case
|
||||
-- remove regular occurrences if there is a NoOccur exception for the occurrence of this week
|
||||
ScheduleEntry{seOccurrence=Right ScheduleWeekly{..}} ->
|
||||
-- TODO: is equality on scheduleStart sane?
|
||||
not $ Left (ExceptNoOccur $ LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` now) scheduleStart)
|
||||
`elem` (seOccurrence <$> occurrencesInSlot)
|
||||
-- remove NoOccur exceptions if there is no regular occurrence to override
|
||||
ScheduleEntry{seOccurrence=Left ExceptNoOccur{exceptTime=LocalTime{..}}} ->
|
||||
any (\case
|
||||
-- TODO: is equality on scheduleStart sane?
|
||||
Right ScheduleWeekly{..} -> scheduleDayOfWeek `dayOfWeekToDayWith` now == localDay
|
||||
&& scheduleStart == localTimeOfDay
|
||||
_ -> False
|
||||
) (seOccurrence <$> occurrencesInSlot)
|
||||
_ -> True -- TODO: maybe filter out ExceptNoOccurs? (Should NoOccurs be displayed or not?)
|
||||
in filter isRegularWithoutException occurrencesInSlot
|
||||
|
||||
currentWeek :: [Day]
|
||||
currentWeek = currentWeekAux $ utctDay now
|
||||
where currentWeekAux day
|
||||
| Monday <- dayOfWeek day = [day .. toEnum (fromEnum day + 6)]
|
||||
| otherwise = currentWeekAux $ pred day
|
||||
|
||||
-- TODO: Internationalize week start (and/or make configurable)
|
||||
-- TODO: auto-hide saturday and sunday (if there are no events scheduled)?
|
||||
-- TODO: weekday messages deprecated / not used => remove
|
||||
weekDays :: [(Day, UniWorXMessage, Text)]
|
||||
weekDays = zipWith (\x (y,z) -> (x,y,z)) currentWeek
|
||||
[ (MsgScheduleWeekDayMonday , "mon")
|
||||
, (MsgScheduleWeekDayTuesday , "tue")
|
||||
, (MsgScheduleWeekDayWednesday , "wed")
|
||||
, (MsgScheduleWeekDayThursday , "thu")
|
||||
, (MsgScheduleWeekDayFriday , "fri")
|
||||
, (MsgScheduleWeekDaySaturday , "sat")
|
||||
, (MsgScheduleWeekDaySunday , "sun")
|
||||
]
|
||||
|
||||
formatOccurrenceW :: ScheduleEntryOccurrence -> Widget
|
||||
formatOccurrenceW = \case
|
||||
Right ScheduleWeekly{..} -> [whamlet| _{MsgScheduleTime}: |] <> formatTimeRangeW SelFormatTime scheduleStart (Just scheduleEnd)
|
||||
Left ExceptOccur{..} -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime (LocalTime exceptDay exceptStart) (Just (LocalTime exceptDay exceptEnd))
|
||||
Left ExceptNoOccur{} -> [whamlet| _{MsgScheduleNoOccur} |] -- <> formatTimeW SelFormatDateTime exceptTime
|
||||
|
||||
scheduleEntryToHref :: ScheduleEntry -> Route UniWorX
|
||||
scheduleEntryToHref ScheduleEntry{seCourse=Entity _ Course{..},seType} = case seType of
|
||||
SETCourseEvent{} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to events table? (TODO currently has no id)
|
||||
SETTutorial{} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to table with id "tutorials"?
|
||||
SETExam{..} -> CExamR courseTerm courseSchool courseShorthand seteName EShowR
|
||||
|
||||
$(widgetFile "widgets/schedule/week")
|
||||
|
||||
|
||||
-- Helper functions for this module
|
||||
|
||||
-- | Convert from DayOfWeek to Day of this week using the current time (as UTCTime)
|
||||
dayOfWeekToDayWith :: DayOfWeek -> UTCTime -> Day
|
||||
dayOfWeekToDayWith weekDay = go . utctDay where
|
||||
go day | weekDay' == weekDay = day
|
||||
| weekDay' > weekDay = go $ pred day
|
||||
| otherwise = go $ succ day
|
||||
where weekDay' = dayOfWeek day
|
||||
import Utils.Schedule.Week as Utils.Schedule
|
||||
|
||||
@ -3,6 +3,7 @@ module Utils.Schedule.Types
|
||||
, ScheduleEntryType(..)
|
||||
, ScheduleEntryRoom
|
||||
, ScheduleEntryOccurrence
|
||||
, ScheduleEntryExamOccurrence(..)
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -14,15 +15,28 @@ data ScheduleEntry = ScheduleEntry
|
||||
, seRoom :: ScheduleEntryRoom
|
||||
, seOccurrence :: ScheduleEntryOccurrence
|
||||
}
|
||||
deriving (Generic, Typeable)
|
||||
|
||||
data ScheduleEntryType = SETCourseEvent { setceType :: CI Text } -- TODO: CourseEventType not possible here (comes from data family instance)
|
||||
| SETTutorial { settType :: CI Text
|
||||
, settName :: TutorialName
|
||||
data ScheduleEntryType = SETCourseEvent { setceType :: CI Text
|
||||
} -- TODO: CourseEventType not possible here (comes from data family instance)
|
||||
| SETTutorial { settType :: CI Text
|
||||
, settName :: TutorialName
|
||||
} -- TODO: TutorialType not possible here (comes from data family instance)
|
||||
| SETExam { seteName :: ExamName }
|
||||
| SETExamOccurrence { seteoExamName :: ExamName
|
||||
, seteoOccurrenceName :: ExamOccurrenceName
|
||||
}
|
||||
-- TODO: more?
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
type ScheduleEntryRoom = Maybe Text -- TODO: is Maybe Text okay for every ScheduleEntryType?
|
||||
|
||||
type ScheduleEntryOccurrence = Either OccurrenceException OccurrenceSchedule
|
||||
-- TODO: maybe introduce sum new type instead
|
||||
type ScheduleEntryOccurrence = Either ScheduleEntryExamOccurrence (Either OccurrenceException OccurrenceSchedule)
|
||||
|
||||
-- Similar to OccurrenceException, but with Maybe as end
|
||||
data ScheduleEntryExamOccurrence = ScheduleEntryExamOccurrence
|
||||
{ seeoDay :: Day
|
||||
, seeoStart :: TimeOfDay
|
||||
, seeoEnd :: Maybe TimeOfDay
|
||||
}
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
214
src/Utils/Schedule/Week.hs
Normal file
214
src/Utils/Schedule/Week.hs
Normal file
@ -0,0 +1,214 @@
|
||||
module Utils.Schedule.Week
|
||||
( weekSchedule
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
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)
|
||||
|
||||
import Utils.Schedule.Types
|
||||
import Utils.Course (mayViewCourse, isCourseLecturer)
|
||||
|
||||
|
||||
-- TODO: very temporary slot representation
|
||||
type TimeSlot = Int
|
||||
firstSlot, lastSlot, slotStep :: Int
|
||||
firstSlot = 8
|
||||
lastSlot = 20
|
||||
slotStep = 2
|
||||
|
||||
slotsToDisplay :: [TimeSlot]
|
||||
slotsToDisplay = [firstSlot,firstSlot+slotStep..lastSlot]
|
||||
|
||||
slotToDisplayTime :: TimeSlot -> Widget
|
||||
slotToDisplayTime t = formatTimeRangeW SelFormatTime (TimeOfDay t 0 0) $ Just $ TimeOfDay (t + slotStep) 0 0
|
||||
|
||||
|
||||
-- TODO: implement weekOffset
|
||||
weekSchedule :: UserId -> Maybe Int -> Widget
|
||||
weekSchedule uid _weekOffset = do
|
||||
now <- liftIO getCurrentTime
|
||||
ata <- getSessionActiveAuthTags
|
||||
|
||||
-- TODO: single runDB for all fetches below?
|
||||
|
||||
activeTerms <- liftHandler . runDB $ E.select $ E.from $ \term -> do
|
||||
E.where_ $ term E.^. TermActive
|
||||
return $ term E.^. TermId
|
||||
|
||||
-- TODO: fetch course events for this week only?
|
||||
courseEvents <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` courseEvent) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseEvent E.^. CourseEventCourse
|
||||
E.where_ $ (E.exists $ E.from $ \courseParticipant -> E.where_ $
|
||||
courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
E.&&. courseParticipant E.^. CourseParticipantUser E.==. E.val uid
|
||||
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
E.&&. mayViewCourse (Just uid) ata now course Nothing -- should not be necessary, but let's be on the safe side
|
||||
) E.||. (E.exists $ E.from $ \lecturer -> E.where_ $
|
||||
lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. lecturer E.^. LecturerUser E.==. E.val uid
|
||||
)
|
||||
return (course, courseEvent)
|
||||
|
||||
tutorials <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` tutorial) -> do
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ (E.exists $ E.from $ \tutorialParticipant -> E.where_ $
|
||||
tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
|
||||
E.&&. mayViewCourse (Just uid) ata now course Nothing -- should not be necessary, but let's be on the safe side
|
||||
) E.||. (E.exists $ E.from $ \tutor -> E.where_ $
|
||||
tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.&&. tutor E.^. TutorUser E.==. E.val uid
|
||||
)
|
||||
return (course, tutorial)
|
||||
|
||||
-- TODO: this makes the exam table redundant once the weekOffset is implemented
|
||||
-- TODO: check for exam visibility for participants!
|
||||
exams <- liftHandler . runDB $ E.select $ E.from $ \(course `E.InnerJoin` (exam `E.InnerJoin` examOccurrence) `E.LeftOuterJoin` examRegistration) -> do
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.on $ exam E.^. ExamId E.==. examOccurrence E.^. ExamOccurrenceExam
|
||||
E.on $ E.just (exam E.^. ExamId) E.==. examRegistration E.?. ExamRegistrationExam
|
||||
E.where_ $ isCourseLecturer (Just uid) ata (course E.^. CourseId)
|
||||
E.||. (examRegistration E.?. ExamRegistrationUser E.==. E.just (E.val uid)
|
||||
E.&&. mayViewCourse (Just uid) ata now course Nothing) -- do NOT remove, this is actually necessary here!
|
||||
-- (There can be exam participants that are
|
||||
-- not enrolled, me thinks)
|
||||
return (course, exam, examOccurrence, examRegistration)
|
||||
|
||||
let
|
||||
courseEventToScheduleEntries :: (Entity Course, Entity CourseEvent) -> [ScheduleEntry]
|
||||
courseEventToScheduleEntries (seCourse@(Entity _ Course{..}), Entity _ CourseEvent{courseEventType,courseEventRoom,courseEventTime=Occurrences{..}}) =
|
||||
let seType = SETCourseEvent { setceType = courseEventType }
|
||||
seRoom = Just courseEventRoom
|
||||
scheduleds
|
||||
-- omit regular occurrences if the course's term is not currently active
|
||||
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
|
||||
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
|
||||
let seOccurrence = Right (Right scheduled) in ScheduleEntry{..}
|
||||
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
||||
let seOccurrence = Right (Left exception) in ScheduleEntry{..}
|
||||
in scheduleds <> exceptions
|
||||
|
||||
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
|
||||
scheduleds
|
||||
-- omit regular occurrences if the course's term is not currently active
|
||||
| not (courseTerm `elem` (E.unValue <$> activeTerms)) = mempty
|
||||
| otherwise = Set.toList occurrencesScheduled <&> \scheduled ->
|
||||
let seOccurrence = Right (Right scheduled) in ScheduleEntry{..}
|
||||
exceptions = Set.toList occurrencesExceptions <&> \exception ->
|
||||
let seOccurrence = Right (Left exception) in ScheduleEntry{..}
|
||||
in scheduleds <> exceptions
|
||||
|
||||
-- TODO: work in progress
|
||||
-- TODO: maybe exam registration is not even necessary here => refactor select to exists check for registration
|
||||
examToScheduleEntries :: (Entity Course, Entity Exam, Entity ExamOccurrence, Maybe (Entity ExamRegistration)) -> [ScheduleEntry]
|
||||
examToScheduleEntries (seCourse@(Entity _ Course{}), Entity _ Exam{..}, Entity _ ExamOccurrence{..}, _mbExamRegistration) =
|
||||
let seType = SETExamOccurrence
|
||||
{ seteoExamName = examName
|
||||
, seteoOccurrenceName = examOccurrenceName
|
||||
}
|
||||
seRoom = Just examOccurrenceRoom
|
||||
seOccurrence = Left $ ScheduleEntryExamOccurrence
|
||||
{ seeoDay = utctDay examOccurrenceStart
|
||||
, seeoStart = timeToTimeOfDay $ utctDayTime examOccurrenceStart
|
||||
, seeoEnd = (timeToTimeOfDay . utctDayTime) <$> examOccurrenceEnd
|
||||
}
|
||||
in pure $ ScheduleEntry{..}
|
||||
|
||||
seOccurrenceIsInSlot :: Day -> TimeSlot -> ScheduleEntryOccurrence -> Bool
|
||||
seOccurrenceIsInSlot day slot seOcc =
|
||||
let
|
||||
(day', start, _mEnd) = case seOcc of
|
||||
Right (Right ScheduleWeekly{..}) -> (scheduleDayOfWeek `dayOfWeekToDayWith` now, scheduleStart, Just scheduleEnd)
|
||||
Right (Left ExceptOccur{..}) -> (exceptDay, exceptStart, Just exceptEnd)
|
||||
Right (Left ExceptNoOccur{exceptTime=LocalTime{..}}) -> (localDay, localTimeOfDay, Nothing)
|
||||
Left ScheduleEntryExamOccurrence{..} -> (seeoDay, seeoStart, seeoEnd)
|
||||
in day == day' && TimeOfDay slot 0 0 <= start && start < TimeOfDay (slot+slotStep) 0 0
|
||||
|
||||
events' :: Map Day (Map TimeSlot [ScheduleEntry])
|
||||
events' = Map.fromList $ currentWeek <&> \day ->
|
||||
( day
|
||||
, Map.fromList $ slotsToDisplay <&> \slot ->
|
||||
( slot
|
||||
, filter (seOccurrenceIsInSlot day slot . seOccurrence) $ join $
|
||||
(courseEventToScheduleEntries <$> courseEvents)
|
||||
<> (tutorialToScheduleEntries <$> tutorials)
|
||||
<> (examToScheduleEntries <$> exams)
|
||||
)
|
||||
)
|
||||
|
||||
events :: Map Day (Map TimeSlot [ScheduleEntry])
|
||||
events = events' <&> \slotsPerDay -> slotsPerDay <&> \occurrencesInSlot ->
|
||||
let
|
||||
isRegularWithoutException :: ScheduleEntry -> Bool
|
||||
isRegularWithoutException = \case
|
||||
-- remove regular occurrences if there is a NoOccur exception for the occurrence of this week
|
||||
ScheduleEntry{seOccurrence=Right (Right ScheduleWeekly{..})} ->
|
||||
-- TODO: is equality on scheduleStart sane?
|
||||
not $ Right (Left $ ExceptNoOccur $ LocalTime (scheduleDayOfWeek `dayOfWeekToDayWith` now) scheduleStart)
|
||||
`elem` (seOccurrence <$> occurrencesInSlot)
|
||||
-- remove NoOccur exceptions if there is no regular occurrence to override
|
||||
ScheduleEntry{seOccurrence=Right (Left ExceptNoOccur{exceptTime=LocalTime{..}})} ->
|
||||
any (\case
|
||||
-- TODO: is equality on scheduleStart sane?
|
||||
Right (Right ScheduleWeekly{..}) -> scheduleDayOfWeek `dayOfWeekToDayWith` now == localDay
|
||||
&& scheduleStart == localTimeOfDay
|
||||
_ -> False
|
||||
) (seOccurrence <$> occurrencesInSlot)
|
||||
_ -> True -- TODO: maybe filter out ExceptNoOccurs? (Should NoOccurs be displayed or not?)
|
||||
in filter isRegularWithoutException occurrencesInSlot
|
||||
|
||||
currentWeek :: [Day]
|
||||
currentWeek = currentWeekAux $ utctDay now
|
||||
where currentWeekAux day
|
||||
| Monday <- dayOfWeek day = [day .. toEnum (fromEnum day + 6)]
|
||||
| otherwise = currentWeekAux $ pred day
|
||||
|
||||
-- TODO: Internationalize week start (and/or make configurable)
|
||||
-- TODO: auto-hide saturday and sunday (if there are no events scheduled)?
|
||||
-- TODO: weekday messages deprecated / not used => remove
|
||||
weekDays :: [(Day, UniWorXMessage, Text)]
|
||||
weekDays = zipWith (\x (y,z) -> (x,y,z)) currentWeek
|
||||
[ (MsgScheduleWeekDayMonday , "mon")
|
||||
, (MsgScheduleWeekDayTuesday , "tue")
|
||||
, (MsgScheduleWeekDayWednesday , "wed")
|
||||
, (MsgScheduleWeekDayThursday , "thu")
|
||||
, (MsgScheduleWeekDayFriday , "fri")
|
||||
, (MsgScheduleWeekDaySaturday , "sat")
|
||||
, (MsgScheduleWeekDaySunday , "sun")
|
||||
]
|
||||
|
||||
formatOccurrenceW :: ScheduleEntryOccurrence -> Widget
|
||||
formatOccurrenceW = \case
|
||||
Right (Right ScheduleWeekly{..}) -> [whamlet| _{MsgScheduleTime}: |] <> formatTimeRangeW SelFormatTime scheduleStart (Just scheduleEnd)
|
||||
Right (Left ExceptOccur{..}) -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime (LocalTime exceptDay exceptStart) (Just $ LocalTime exceptDay exceptEnd)
|
||||
Right (Left ExceptNoOccur{}) -> [whamlet| _{MsgScheduleNoOccur} |] -- <> formatTimeW SelFormatDateTime exceptTime
|
||||
Left ScheduleEntryExamOccurrence{..} -> [whamlet| _{MsgScheduleOccur}: |] <> formatTimeRangeW SelFormatTime (LocalTime seeoDay seeoStart) (LocalTime seeoDay <$> seeoEnd)
|
||||
|
||||
scheduleEntryToHref :: ScheduleEntry -> Route UniWorX
|
||||
scheduleEntryToHref ScheduleEntry{seCourse=Entity _ Course{..},seType} = case seType of
|
||||
SETCourseEvent{} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to events table? (TODO currently has no id)
|
||||
SETTutorial{} -> CourseR courseTerm courseSchool courseShorthand CShowR -- TODO: link to table with id "tutorials"?
|
||||
SETExamOccurrence{..} -> CExamR courseTerm courseSchool courseShorthand seteoExamName EShowR
|
||||
|
||||
$(widgetFile "widgets/schedule/week")
|
||||
|
||||
|
||||
-- Helper functions for this module
|
||||
|
||||
-- | Convert from DayOfWeek to Day of this week using the current time (as UTCTime)
|
||||
dayOfWeekToDayWith :: DayOfWeek -> UTCTime -> Day
|
||||
dayOfWeekToDayWith weekDay = go . utctDay where
|
||||
go day | weekDay' == weekDay = day
|
||||
| weekDay' > weekDay = go $ pred day
|
||||
| otherwise = go $ succ day
|
||||
where weekDay' = dayOfWeek day
|
||||
@ -1,2 +0,0 @@
|
||||
$newline never
|
||||
_{MsgExceptionKindNoOccur}: #{exceptTime'}
|
||||
@ -1,2 +0,0 @@
|
||||
$newline never
|
||||
_{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'}
|
||||
@ -28,8 +28,9 @@ $newline never
|
||||
$of SETTutorial{..}
|
||||
#{settName} #
|
||||
(#{CI.original settType})
|
||||
$of SETExam{..}
|
||||
#{seteName}
|
||||
$of SETExamOccurrence{..}
|
||||
#{seteoExamName} #
|
||||
(#{seteoOccurrenceName})
|
||||
<br>
|
||||
|
||||
$maybe room <- seRoom
|
||||
|
||||
Reference in New Issue
Block a user