module WeekDaze.LocationView.Timetable(
Timetable,
fromStudentViewTimetable,
toStudentViewTimetable,
toXHtml
) where
import Data.Map((!))
import qualified Data.Array.IArray
import qualified Data.Foldable
import qualified Data.Map
import qualified Data.Maybe
import qualified Data.Set
import qualified Text.XHtml.Strict
import qualified WeekDaze.Aggregate.LocationCatalogue as Aggregate.LocationCatalogue
import qualified WeekDaze.Data.Course as Data.Course
import qualified WeekDaze.Data.Location as Data.Location
import qualified WeekDaze.LocationView.Lesson as LocationView.Lesson
import qualified WeekDaze.LocationView.LessonResourceIds as LocationView.LessonResourceIds
import qualified WeekDaze.Model.Lesson as Model.Lesson
import qualified WeekDaze.Model.Meeting as Model.Meeting
import qualified WeekDaze.Model.Timetable as Model.Timetable
import qualified WeekDaze.Model.TimetableForWeek as Model.TimetableForWeek
import qualified WeekDaze.StudentView.LessonResourceIds as StudentView.LessonResourceIds
import qualified WeekDaze.StudentView.Timetable as StudentView.Timetable
import qualified WeekDaze.Temporal.Time as Temporal.Time
import qualified WeekDaze.Text.CSS as Text.CSS
import Text.XHtml.Strict((+++), (<<))
import WeekDaze.Text.XHTML()
type Timetable locationId timeslotId teacherId level = Model.Timetable.Timetable locationId timeslotId (LocationView.LessonResourceIds.LessonResourceIds teacherId) level
fromStudentViewTimetable :: (
Data.Array.IArray.Ix timeslotId,
Enum timeslotId,
Eq level,
Eq teacherId,
Ord locationId,
Show level,
Show locationId,
Show teacherId,
Show timeslotId
)
=> Bool
-> Timetable locationId timeslotId teacherId level
-> StudentView.Timetable.Timetable timeslotId locationId teacherId level
-> Timetable locationId timeslotId teacherId level
fromStudentViewTimetable permitTemporaryStudentBodyMerger = Data.Map.foldrWithKey (
\studentBody studentViewTimetableForWeek locationViewTimetable -> snd $ Data.Foldable.foldr (
\studentViewTimetableForDay (day, locationViewTimetable') -> (
pred day,
snd $ Data.Foldable.foldr (
\maybeStudentViewLesson (timeslotId, locationViewTimetable'') -> (
pred timeslotId,
Data.Maybe.maybe locationViewTimetable'' (
($ locationViewTimetable'') . bookStudentViewLesson permitTemporaryStudentBodyMerger . (,) (
studentBody,
Temporal.Time.mkTime day timeslotId
)
) maybeStudentViewLesson
)
) (
snd $ Data.Array.IArray.bounds studentViewTimetableForDay,
locationViewTimetable'
) studentViewTimetableForDay
)
) (
snd $ Data.Array.IArray.bounds studentViewTimetableForWeek,
locationViewTimetable
) studentViewTimetableForWeek
)
toStudentViewTimetable
:: (Data.Array.IArray.Ix timeslotId, Enum timeslotId)
=> StudentView.Timetable.Timetable timeslotId locationId teacherId level
-> Timetable locationId timeslotId teacherId level
-> StudentView.Timetable.Timetable timeslotId locationId teacherId level
toStudentViewTimetable = Data.Map.foldrWithKey (
\locationId locationViewTimetableForWeek studentViewTimetable -> snd $ Data.Foldable.foldr (
\locationViewTimetableForDay (day, studentViewTimetable') -> (
pred day,
snd $ Data.Foldable.foldr (
\maybeLocationViewLesson (timeslotId, studentViewTimetable'') -> (
pred timeslotId,
Data.Maybe.maybe studentViewTimetable'' (
($ studentViewTimetable'') . bookLocationViewLesson . (,) (
locationId,
Temporal.Time.mkTime day timeslotId
)
) maybeLocationViewLesson
)
) (
snd $ Data.Array.IArray.bounds locationViewTimetableForDay,
studentViewTimetable'
) locationViewTimetableForDay
)
) (
snd $ Data.Array.IArray.bounds locationViewTimetableForWeek,
studentViewTimetable
) locationViewTimetableForWeek
)
bookStudentViewLesson :: (
Data.Array.IArray.Ix timeslotId,
Eq level,
Eq teacherId,
Ord locationId,
Show level,
Show locationId,
Show teacherId,
Show timeslotId
)
=> Bool
-> StudentView.Timetable.Booking timeslotId locationId teacherId level
-> Timetable locationId timeslotId teacherId level
-> Timetable locationId timeslotId teacherId level
bookStudentViewLesson permitTemporaryStudentBodyMerger ((studentBody, time), studentViewLesson) locationViewTimetable = Model.Timetable.defineTimeslot (
locationViewTimetableCoordinates,
Just studentViewLesson {
Model.Lesson.getResourceIds = LocationView.LessonResourceIds.mkLessonResourceIds (
Data.Set.insert studentBody $ case Model.Timetable.getMaybeLesson locationViewTimetableCoordinates locationViewTimetable of
Nothing -> Data.Set.empty
Just locationViewLesson
| and [
permitTemporaryStudentBodyMerger,
LocationView.LessonResourceIds.getTeacherId locationViewResourceIds == teacherId,
Model.Lesson.getSubject locationViewLesson == Model.Lesson.getSubject studentViewLesson
] -> LocationView.LessonResourceIds.getStudentClass locationViewResourceIds
| otherwise -> error $ "WeekDaze.LocationView.Timetable.bookStudentViewLesson:\tlesson at coordinates=" ++ show locationViewTimetableCoordinates ++ " has already been booked in either a different subject or location; " ++ show (locationViewLesson, studentViewLesson) ++ "."
where
locationViewResourceIds = Model.Lesson.getResourceIds locationViewLesson
) teacherId
}
) locationViewTimetable where
studentViewResourceIds = Model.Lesson.getResourceIds studentViewLesson
teacherId = StudentView.LessonResourceIds.getTeacherId studentViewResourceIds
locationViewTimetableCoordinates = (StudentView.LessonResourceIds.getLocationId studentViewResourceIds, time)
type Booking locationId timeslotId teacherId level = Model.Timetable.Booking locationId timeslotId (LocationView.LessonResourceIds.LessonResourceIds teacherId) level
bookLocationViewLesson
:: Data.Array.IArray.Ix timeslotId
=> Booking locationId timeslotId teacherId level
-> StudentView.Timetable.Timetable timeslotId locationId teacherId level
-> StudentView.Timetable.Timetable timeslotId locationId teacherId level
bookLocationViewLesson ((locationId, time), locationViewLesson) studentViewTimetable = Data.Set.foldr (
Model.Timetable.defineTimeslot . flip (,) (
Just $ LocationView.Lesson.toStudentView locationId locationViewLesson
) . flip (,) time
) studentViewTimetable $ LocationView.LessonResourceIds.getStudentClass locationViewResourceIds where
locationViewResourceIds = Model.Lesson.getResourceIds locationViewLesson
toXHtml :: (
Data.Array.IArray.Ix timeslotId,
Fractional minimumContrastRatio,
Ord level,
Ord locationId,
Ord minimumContrastRatio,
Ord teacherId,
Show level,
Show teacherId,
Text.XHtml.Strict.HTML campus,
Text.XHtml.Strict.HTML level,
Text.XHtml.Strict.HTML locationId,
Text.XHtml.Strict.HTML synchronisationId,
Text.XHtml.Strict.HTML teacherId,
Text.XHtml.Strict.HTML timeslotId
)
=> (locationId -> LocationView.Lesson.Lesson teacherId level -> Data.Course.Course synchronisationId level timeslotId)
-> Aggregate.LocationCatalogue.LocationCatalogue locationId campus
-> Model.Timetable.GenericTimetableToMarkup locationId minimumContrastRatio teacherId timeslotId (Timetable locationId timeslotId teacherId level)
toXHtml findCourseForLocationViewLesson locationCatalogue displaySupplementaryInformation meetingsByTime htmlMergeDuplicateTimeslots displayAxisLabels weekend maybeGenerateLessonColourFrom = Text.XHtml.Strict.defList . map (
\(locationId, timetableForWeek) -> let
locationProfile = locationCatalogue ! locationId
nUnallocatedAvailableTimeslots = Model.TimetableForWeek.countUnallocatedAvailableTimeslots locationProfile timetableForWeek
in (
Text.XHtml.Strict.unordList (
(
Data.Location.getCampus locationProfile +++ ' ' +++ locationId
) : if displaySupplementaryInformation
then Data.Maybe.catMaybes [
Just $ Text.XHtml.Strict.thespan Text.XHtml.Strict.! [
Text.XHtml.Strict.theclass Text.CSS.infoCSSIdentifier,
Text.XHtml.Strict.title "The total capacity to accommodate students at this location."
] << (
"Capacity" +++ Text.XHtml.Strict.spaceHtml +++ '=' +++ Text.XHtml.Strict.spaceHtml +++ Text.XHtml.Strict.thespan Text.XHtml.Strict.! [
Text.XHtml.Strict.theclass Text.CSS.numericDataCSSIdentifier
] << Data.Location.getCapacity (locationCatalogue ! locationId)
),
if nUnallocatedAvailableTimeslots == 0
then Nothing
else Just $ Text.XHtml.Strict.thespan Text.XHtml.Strict.! [
Text.XHtml.Strict.theclass Text.CSS.infoCSSIdentifier,
Text.XHtml.Strict.title "Available but unallocated time-slots, at this location."
] << (
"Unallocated time-slots" +++ Text.XHtml.Strict.spaceHtml +++ '=' +++ Text.XHtml.Strict.spaceHtml +++ Text.XHtml.Strict.thespan Text.XHtml.Strict.! [
Text.XHtml.Strict.theclass Text.CSS.numericDataCSSIdentifier
] << nUnallocatedAvailableTimeslots
),
let
facilityNames = Data.Location.getFacilityNames locationProfile
in if Data.Set.null facilityNames
then Nothing
else Just $ Text.XHtml.Strict.unordList (map show $ Data.Set.toList facilityNames) Text.XHtml.Strict.! [
Text.XHtml.Strict.theclass Text.CSS.infoCSSIdentifier,
Text.XHtml.Strict.title "Facilities available at this location."
]
]
else []
) Text.XHtml.Strict.! [Text.XHtml.Strict.theclass Text.CSS.observerSummaryCSSIdentifier],
Model.TimetableForWeek.toXHtml (
findCourseForLocationViewLesson locationId
) locationProfile (
Model.Meeting.deleteLocationId locationId meetingsByTime
) htmlMergeDuplicateTimeslots displayAxisLabels weekend maybeGenerateLessonColourFrom timetableForWeek
)
) . Data.Map.toList