module WeekDaze.Model.Meeting(
MeetingsByTime,
Meeting(
getMaybeLocationId,
getStudentClass,
getTeacherIds,
getGroupId
),
deleteLocationId,
deleteStudentBody,
deleteTeacherId,
mkMeeting
) where
import Control.Arrow((&&&))
import qualified Data.List
import qualified Data.Map
import qualified Data.Maybe
import qualified Data.Set
import qualified Text.XHtml.Strict
import qualified ToolShed.SelfValidate
import qualified WeekDaze.Aggregate.StudentBody as Aggregate.StudentBody
import qualified WeekDaze.Aggregate.StudentClass as Aggregate.StudentClass
import qualified WeekDaze.Data.Group as Data.Group
import qualified WeekDaze.Data.HumanResource as Data.HumanResource
import qualified WeekDaze.Temporal.Time as Temporal.Time
import qualified WeekDaze.Text.CSS as Text.CSS
import Text.XHtml.Strict((+++), (<<), (!))
cssIdentifier :: Text.CSS.CSSIdentifier
cssIdentifier = "meeting"
resourceIdsCSSIdentifier :: Text.CSS.CSSIdentifier
resourceIdsCSSIdentifier = "resourceIds"
data Meeting locationId teacherId = MkMeeting {
getGroupId :: Data.Group.Id,
getMaybeLocationId :: Maybe locationId,
getStudentClass :: Aggregate.StudentClass.StudentClass,
getTeacherIds :: Data.Set.Set teacherId
} deriving (Eq, Ord, Show)
instance (
Text.XHtml.Strict.HTML locationId,
Text.XHtml.Strict.HTML teacherId
) => Text.XHtml.Strict.HTML (Meeting locationId teacherId) where
toHtml MkMeeting {
getGroupId = groupId,
getMaybeLocationId = maybeLocationId,
getStudentClass = studentClass,
getTeacherIds = teacherIds
} = Text.XHtml.Strict.thediv ! [
Text.XHtml.Strict.theclass cssIdentifier,
Text.XHtml.Strict.title cssIdentifier
] << (
Text.XHtml.Strict.thediv ! [
Text.XHtml.Strict.theclass Data.Group.groupIdTag,
Text.XHtml.Strict.title Data.Group.groupIdTag
] << (groupId +++ '.') +++ Text.XHtml.Strict.unordList (
Data.Maybe.catMaybes [
fmap terminate maybeLocationId,
if Data.Set.null studentClass
then Nothing
else Just . terminate . Data.List.intersperse separator . map Text.XHtml.Strict.toHtml $ Data.Set.toList studentClass,
if Data.Set.null teacherIds
then Nothing
else Just . terminate . Data.List.intersperse separator . map Text.XHtml.Strict.toHtml $ Data.Set.toList teacherIds
]
) ! [
Text.XHtml.Strict.theclass resourceIdsCSSIdentifier,
Text.XHtml.Strict.title resourceIdsCSSIdentifier
]
) where
separator = Text.XHtml.Strict.toHtml ", "
terminate :: Text.XHtml.Strict.HTML html => html -> Text.XHtml.Strict.Html
terminate = (+++ '.')
instance (Show locationId, Show teacherId) => ToolShed.SelfValidate.SelfValidator (Meeting locationId teacherId) where
getErrors meeting = ToolShed.SelfValidate.extractErrors [
(
uncurry (&&) $ (Data.Set.null . getStudentClass &&& Data.Set.null . getTeacherIds) meeting,
"a meeting can't have an empty " ++ show Data.HumanResource.groupMembershipTag ++ "; " ++ show meeting
)
]
mkMeeting
:: (Show locationId, Show teacherId)
=> Data.Group.Id
-> Maybe locationId
-> Aggregate.StudentClass.StudentClass
-> Data.Set.Set teacherId
-> Meeting locationId teacherId
mkMeeting groupId maybeLocationId studentClass teacherIds
| ToolShed.SelfValidate.isValid meeting = meeting
| otherwise = error $ "WeekDaze.Model.Meeting.mkMeeting:\t" ++ ToolShed.SelfValidate.getFirstError meeting ++ "."
where
meeting = MkMeeting groupId maybeLocationId studentClass teacherIds
type MeetingsByTime timeslotId locationId teacherId = Data.Map.Map (Temporal.Time.Time timeslotId) (Data.Set.Set (Meeting locationId teacherId))
type MeetingsByTimeMutator timeslotId locationId teacherId = MeetingsByTime timeslotId locationId teacherId -> MeetingsByTime timeslotId locationId teacherId
deleteLocationId :: (
Ord locationId,
Ord teacherId
) => locationId -> MeetingsByTimeMutator timeslotId locationId teacherId
deleteLocationId locationId = Data.Map.map (
Data.Set.map (
\meeting -> meeting {
getMaybeLocationId = Nothing
}
)
) . Data.Map.filter (
not . Data.Set.null
) . Data.Map.map (
Data.Set.filter (
(== Just locationId) . getMaybeLocationId
)
)
deleteStudentBody :: (
Ord locationId,
Ord teacherId
) => Aggregate.StudentBody.StudentBody -> MeetingsByTimeMutator timeslotId locationId teacherId
deleteStudentBody studentBody = Data.Map.map (
Data.Set.map (
\meeting -> meeting {
getStudentClass = Data.Set.delete studentBody $ getStudentClass meeting
}
)
) . Data.Map.filter (
not . Data.Set.null
) . Data.Map.map (
Data.Set.filter (
Data.Set.member studentBody . getStudentClass
)
)
deleteTeacherId :: (
Ord locationId,
Ord teacherId
) => teacherId -> MeetingsByTimeMutator timeslotId locationId teacherId
deleteTeacherId teacherId = Data.Map.map (
Data.Set.map (
\meeting -> meeting {
getTeacherIds = Data.Set.delete teacherId $ getTeacherIds meeting
}
)
) . Data.Map.filter (
not . Data.Set.null
) . Data.Map.map (
Data.Set.filter (
Data.Set.member teacherId . getTeacherIds
)
)