chore(schedule): add first WIP stub
This commit is contained in:
Sarah Vaupel
parent
336424d369
commit
6b585f8dae
@ -1380,3 +1380,16 @@ a.breadcrumbs__home
|
||||
|
||||
.multi-user-invitation-field__wrapper
|
||||
max-width: 25rem
|
||||
|
||||
|
||||
table.schedule
|
||||
.schedule--entry
|
||||
background-color: var(--color-dark)
|
||||
color: white
|
||||
font-weight: 600
|
||||
border-radius: 15px
|
||||
padding: 10px
|
||||
a.schedule--entry-link
|
||||
text-decoration: none
|
||||
a.schedule--entry-link + a.schedule--entry-link > .schedule--entry
|
||||
margin-top: 5px
|
||||
|
||||
@ -102,6 +102,30 @@ TermLectureEndTooltip: Meistens dauer das Sommersemester 14 Wochen und das Winte
|
||||
TermActive: Aktiv
|
||||
|
||||
|
||||
ScheduleHeadline: Terminübersicht
|
||||
|
||||
ScheduleTableHeadTime: Zeit
|
||||
|
||||
ScheduleRoom: Raum
|
||||
ScheduleTime: Zeit
|
||||
|
||||
ScheduleWeekDayMonday: Montag
|
||||
ScheduleWeekDayTuesday: Dienstag
|
||||
ScheduleWeekDayWednesday: Mittwoch
|
||||
ScheduleWeekDayThursday: Donnerstag
|
||||
ScheduleWeekDayFriday: Freitag
|
||||
ScheduleWeekDaySaturday: Samstag
|
||||
ScheduleWeekDaySunday: Sonntag
|
||||
|
||||
ScheduleWeekDayMondayShort: Mo
|
||||
ScheduleWeekDayTuesdayShort: Di
|
||||
ScheduleWeekDayWednesdayShort: Mi
|
||||
ScheduleWeekDayThursdayShort: Do
|
||||
ScheduleWeekDayFridayShort: Fr
|
||||
ScheduleWeekDaySaturdayShort: Sa
|
||||
ScheduleWeekDaySundayShort: So
|
||||
|
||||
|
||||
SchoolListHeading: Übersicht über verwaltete Institute
|
||||
SchoolHeading school@SchoolName: Übersicht #{school}
|
||||
|
||||
|
||||
@ -102,6 +102,30 @@ TermLectureEndTooltip: Summer semesters are usually 14 weeks; winter semesters 1
|
||||
TermActive: Active
|
||||
|
||||
|
||||
ScheduleHeadline: Schedule
|
||||
|
||||
ScheduleTableHeadTime: Time
|
||||
|
||||
ScheduleRoom: Room
|
||||
ScheduleTime: Time
|
||||
|
||||
ScheduleWeekDayMonday: Monday
|
||||
ScheduleWeekDayTuesday: Tuesday
|
||||
ScheduleWeekDayWednesday: Wednesday
|
||||
ScheduleWeekDayThursday: Thursday
|
||||
ScheduleWeekDayFriday: Friday
|
||||
ScheduleWeekDaySaturday: Saturday
|
||||
ScheduleWeekDaySunday: Sunday
|
||||
|
||||
ScheduleWeekDayMondayShort: Mon
|
||||
ScheduleWeekDayTuesdayShort: Tue
|
||||
ScheduleWeekDayWednesdayShort: Wed
|
||||
ScheduleWeekDayThursdayShort: Thu
|
||||
ScheduleWeekDayFridayShort: Fri
|
||||
ScheduleWeekDaySaturdayShort: Sat
|
||||
ScheduleWeekDaySundayShort: Sun
|
||||
|
||||
|
||||
SchoolListHeading: Department
|
||||
SchoolHeading school: #{school}
|
||||
|
||||
|
||||
@ -7,6 +7,8 @@ import Handler.Utils.News
|
||||
|
||||
import Handler.SystemMessage
|
||||
|
||||
import Utils.Schedule
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Database.Esqueleto.Utils.TH
|
||||
import qualified Database.Esqueleto as E
|
||||
@ -32,6 +34,7 @@ getNewsR = do
|
||||
|
||||
case muid of
|
||||
Just uid -> do
|
||||
newsSchedule uid
|
||||
newsUpcomingExams uid
|
||||
newsUpcomingSheets uid
|
||||
Nothing ->
|
||||
@ -83,6 +86,12 @@ newsSystemMessages = do
|
||||
$(widgetFile "news/system-messages")
|
||||
|
||||
|
||||
-- TODO: persist default schedule in user settings, lookup default and choose schedule accordingly
|
||||
-- TODO: add action to switch schedule (replace widget)
|
||||
newsSchedule :: UserId -> Widget
|
||||
newsSchedule = weekSchedule
|
||||
|
||||
|
||||
newsUpcomingSheets :: UserId -> Widget
|
||||
newsUpcomingSheets uid = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
|
||||
124
src/Utils/Schedule.hs
Normal file
124
src/Utils/Schedule.hs
Normal file
@ -0,0 +1,124 @@
|
||||
module Utils.Schedule
|
||||
( 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)
|
||||
|
||||
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
|
||||
|
||||
|
||||
weekSchedule :: UserId -> Widget
|
||||
weekSchedule uid = do
|
||||
now <- liftIO getCurrentTime
|
||||
ata <- getSessionActiveAuthTags
|
||||
|
||||
-- TODO: single runDB for every fetch below?
|
||||
|
||||
-- TODO: fetch course events for this week only:
|
||||
-- - for regular occurrences: check for active semester
|
||||
-- - also fetch exceptions
|
||||
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)
|
||||
|
||||
-- TODO: fetch registered tutorials
|
||||
-- TODO: also fetch tutorials with user as tutor
|
||||
_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 _exams = []
|
||||
|
||||
let
|
||||
courseEventToScheduleEntry :: (Entity Course, Entity CourseEvent) -> ScheduleEntry
|
||||
courseEventToScheduleEntry (seCourse, Entity _ CourseEvent{..}) =
|
||||
let seType = SETCourseEvent { setceType = courseEventType }
|
||||
seRoom = Just courseEventRoom
|
||||
seOccurrences = courseEventTime
|
||||
in ScheduleEntry{..}
|
||||
|
||||
occursInSlot :: DayOfWeek -> TimeSlot -> ScheduleEntry -> Bool
|
||||
occursInSlot day slot ScheduleEntry{seOccurrences=Occurrences{..}} =
|
||||
isScheduledInSlot day slot occurrencesScheduled && not (exceptNotOccursInSlot day slot occurrencesExceptions)
|
||||
|| exceptOccursInSlot day slot occurrencesExceptions
|
||||
|
||||
isScheduledInSlot :: DayOfWeek -> TimeSlot -> Set OccurrenceSchedule -> Bool
|
||||
isScheduledInSlot _day _slot _schedules = False -- TODO
|
||||
|
||||
exceptOccursInSlot :: DayOfWeek -> TimeSlot -> Set OccurrenceException -> Bool
|
||||
exceptOccursInSlot _day _slot _exceptions = False -- TODO
|
||||
|
||||
exceptNotOccursInSlot :: DayOfWeek -> TimeSlot -> Set OccurrenceException -> Bool
|
||||
exceptNotOccursInSlot _day _slot _exceptions = False -- TODO
|
||||
|
||||
-- TODO: remove
|
||||
--formatTimeRangeOccurrencesInSlotW :: Occurrences -> TimeSlot -> Widget
|
||||
--formatTimeRangeOccurrencesInSlotW Occurrences{..} slot =
|
||||
-- let (start,mEnd) |
|
||||
-- in formatTimeRangeW SelFormatTime start mEnd
|
||||
|
||||
-- TODO: use NonEmpty ScheduleEntry instead of [ScheduleEntry]
|
||||
courseEvents :: Map DayOfWeek (Map TimeSlot [ScheduleEntry])
|
||||
courseEvents = Map.fromList $ [Monday .. Sunday] <&> \day ->
|
||||
( day
|
||||
, Map.fromList $ slotsToDisplay <&> \slot ->
|
||||
( slot
|
||||
, flip filter (courseEventToScheduleEntry <$> courseEvents') $ occursInSlot day slot
|
||||
-- \ScheduleEntry{seOccurrences} -> occursInSlot day slot seOccurrences
|
||||
--seDayOfWeek == day && TimeOfDay slot 0 0 <= seStart && seStart < TimeOfDay (slot + slotStep) 0 0
|
||||
)
|
||||
)
|
||||
|
||||
-- TODO: Internationalize week start (and/or make configurable)
|
||||
-- TODO: auto-hide saturday and sunday (if there are no events scheduled)?
|
||||
weekDays :: [(DayOfWeek,UniWorXMessage,Text)]
|
||||
weekDays = [ (Monday , MsgScheduleWeekDayMonday , "mon")
|
||||
, (Tuesday , MsgScheduleWeekDayTuesday , "tue")
|
||||
, (Wednesday , MsgScheduleWeekDayWednesday , "wed")
|
||||
, (Thursday , MsgScheduleWeekDayThursday , "thu")
|
||||
, (Friday , MsgScheduleWeekDayFriday , "fri")
|
||||
, (Saturday , MsgScheduleWeekDaySaturday , "sat")
|
||||
, (Sunday , MsgScheduleWeekDaySunday , "sun")
|
||||
]
|
||||
|
||||
$(widgetFile "widgets/schedule/week")
|
||||
23
src/Utils/Schedule/Types.hs
Normal file
23
src/Utils/Schedule/Types.hs
Normal file
@ -0,0 +1,23 @@
|
||||
module Utils.Schedule.Types
|
||||
( ScheduleEntry(..)
|
||||
, ScheduleEntryType(..)
|
||||
, ScheduleEntryRoom
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
|
||||
data ScheduleEntry = ScheduleEntry
|
||||
{ seCourse :: Entity Course -- TODO: just course?; TODO: Maybe?
|
||||
, seType :: ScheduleEntryType
|
||||
, seRoom :: ScheduleEntryRoom
|
||||
, seOccurrences :: Occurrences -- TODO: will require converting exam occurrences to an ExceptOccur OccurrenceException
|
||||
}
|
||||
|
||||
data ScheduleEntryType = SETCourseEvent { setceType :: CI Text } -- TODO: CourseEventType not possible here (comes from data family instance)
|
||||
| SETTutorial { settType :: CI Text } -- TODO: TutorialType not possible here (comes from data family instance)
|
||||
| SETExamOccurrence { seteoExamName :: ExamName }
|
||||
-- TODO: more?
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
type ScheduleEntryRoom = Maybe Text -- TODO: is Maybe Text okay for every ScheduleEntryType?
|
||||
48
templates/widgets/schedule/week.hamlet
Normal file
48
templates/widgets/schedule/week.hamlet
Normal file
@ -0,0 +1,48 @@
|
||||
$newline never
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgScheduleHeadline}
|
||||
|
||||
<div uw-hide-columns="schedule-week">
|
||||
<table .table .table--striped .table--hover .schedule>
|
||||
<thead>
|
||||
<tr .table__row .table__row--head>
|
||||
<th .table__th uw-hide-column-header="time">
|
||||
_{MsgScheduleTableHeadTime}
|
||||
$forall (_, weekDayTitle, weekDayIdent) <- weekDays
|
||||
<th .table__th uw-hide-column-header=#{weekDayIdent}>
|
||||
_{weekDayTitle}
|
||||
<tbody>
|
||||
$forall slot <- slotsToDisplay
|
||||
<tr .table__row>
|
||||
<td .table__td>
|
||||
^{slotToDisplayTime slot}
|
||||
$forall (weekDay, _, _) <- weekDays
|
||||
<td .table__td>
|
||||
<div .table__td-content>
|
||||
$maybe dayEvents <- Map.lookup weekDay courseEvents
|
||||
$maybe slotEvents <- Map.lookup slot dayEvents
|
||||
$forall ScheduleEntry{seCourse=Entity _ Course{courseTerm,courseSchool,courseShorthand,courseName},seType,seRoom,seOccurrences=Occurrences{..}} <- slotEvents
|
||||
<a href=@{CourseR courseTerm courseSchool courseShorthand CShowR} .schedule--entry-link>
|
||||
<div .schedule--entry>
|
||||
#{CI.original courseName}: #
|
||||
$case seType
|
||||
$of SETCourseEvent{..}
|
||||
#{CI.original setceType}
|
||||
$of SETTutorial{..}
|
||||
#{CI.original settType}
|
||||
$of SETExamOccurrence{..}
|
||||
#{seteoExamName}
|
||||
<br>
|
||||
|
||||
$maybe room <- seRoom
|
||||
_{MsgScheduleRoom}: #{room} <br/>
|
||||
|
||||
_{MsgScheduleTime}: #
|
||||
$if isScheduledInSlot weekDay slot occurrencesScheduled
|
||||
$if exceptNotOccursInSlot weekDay slot occurrencesExceptions
|
||||
TODO does not occur
|
||||
$else
|
||||
TODO scheduled
|
||||
$elseif exceptOccursInSlot weekDay slot occurrencesExceptions
|
||||
TODO except occurs
|
||||
Reference in New Issue
Block a user