diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index ef0003579..8ae874e40 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -1069,9 +1069,9 @@ ExamRegisterFrom: Anmeldung ab
ExamRegisterFromTip: Zeitpunkt ab dem sich Kursteilnehmer selbständig zur Klausur anmelden können; ohne Datum ist keine Anmeldung möglich
ExamRegisterTo: Anmeldung bis
ExamDeregisterUntil: Abmeldung bis
-ExamPublishOccurrenceAssignments: Terminzuteilung den Teilnehmern mitteilen um
-ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welchen Teilprüfungen (Räumen) sie angemeldet sind
-ExamPublishOccurrenceAssignmentsParticipant: Terminzuteilung einsehbar ab
+ExamPublishOccurrenceAssignments: Termin- bzw. Raumzuteilung den Teilnehmern mitteilen um
+ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welcher Teilprüfung bzw. welchen Raum sie angemeldet sind
+ExamPublishOccurrenceAssignmentsParticipant: Termin- bzw. Raumzuteilung einsehbar ab
ExamFinished: Bewertung abgeschlossen ab
ExamFinishedParticipant: Bewertung vorrausichtlich abgeschlossen
ExamFinishedTip: Zeitpunkt zu dem Klausurergebnisse den Teilnehmern gemeldet werden
@@ -1082,7 +1082,7 @@ ExamShowGradesTip: Soll den Teilnehmern ihre genaue Note angezeigt werden, oder
ExamPublicStatistics: Statistik veröffentlichen
ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmer angezeigt werden, sobald diese ihre Noten einsehen können?
ExamGradingRule: Notenberechnung
-ExamGradingManual': Manuell
+ExamGradingManual': Keine automatische Berechnung
ExamGradingKey': Nach Schlüssel
ExamGradingKey: Notenschlüssel
ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilaufgaben mit ihrem Gewicht multipliziert wurden
@@ -1092,7 +1092,7 @@ PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein
GradingFrom: Ab
ExamNew: Neue Klausur
ExamBonusRule: Klausurbonus aus Übungsbetrieb
-ExamNoBonus': Kein Bonus
+ExamNoBonus': Kein automatischer Bonus
ExamBonusPoints': Umrechnung von Übungspunkten
ExamEditHeading examn@ExamName: #{examn} bearbeiten
@@ -1101,8 +1101,8 @@ ExamBonusMaxPoints: Maximal erreichbare Klausur-Bonuspunkte
ExamBonusMaxPointsNonPositive: Maximaler Klausurbonus muss positiv und größer null sein
ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen
-ExamOccurrenceRule: Automatische Terminzuteilung
-ExamOccurrenceRuleParticipant: Terminzuteilung
+ExamOccurrenceRule: Automatische Termin- bzw. Raumzuteilung
+ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilung
ExamRoomManual': Keine automatische Zuteilung
ExamRoomSurname': Nach Nachname
ExamRoomMatriculation': Nach Matrikelnummer
@@ -1121,7 +1121,7 @@ ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe
ExamRoomRegistered: Zugeteilt
ExamFormTimes: Zeiten
-ExamFormOccurrences: Prüfungstermine
+ExamFormOccurrences: Prüfungstermine/Räume
ExamFormAutomaticFunctions: Automatische Funktionen
ExamFormCorrection: Korrektur
ExamFormParts: Teile
@@ -1159,7 +1159,7 @@ ExamRegistration: Anmeldung
ExamRegisterToMustBeAfterRegisterFrom: "Anmeldung ab" muss vor "Anmeldung bis" liegen
ExamDeregisterUntilMustBeAfterRegisterFrom: "Abmeldung bis" muss nach "Anmeldung bis" liegen
-ExamStartMustBeAfterPublishOccurrenceAssignments: Start muss nach Veröffentlichung der Terminzuordnung liegen
+ExamStartMustBeAfterPublishOccurrenceAssignments: Start muss nach Veröffentlichung der Termin- bzw. Raumzuordnung liegen
ExamEndMustBeAfterStart: Beginn der Klausur muss vor ihrem Ende liegen
ExamFinishedMustBeAfterEnd: "Bewertung abgeschlossen ab" muss nach Ende liegen
ExamFinishedMustBeAfterStart: "Bewertung abgeschlossen ab" muss nach Start liegen
@@ -1167,6 +1167,11 @@ ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Bewertung abges
ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Start liegen
ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen
+ExamOccurrenceEndMustBeAfterStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss vor seinem Ende liegen
+ExamOccurrenceStartMustBeAfterExamStart eoRoom@Text eoRange@Text: Beginn des Termins #{eoRoom} #{eoRange} muss nach Beginn der Klausur liegen
+ExamOccurrenceEndMustBeBeforeExamEnd eoRoom@Text eoRange@Text: Ende des Termins #{eoRoom} #{eoRange} muss vor Ende der Klausur liegen
+ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRange} kommt mehrfach mit der selben Beschreibung vor
+
VersionHistory: Versionsgeschichte
KnownBugs: Bekannte Bugs
diff --git a/models/exams b/models/exams
index 809ba3f1b..14cd8784b 100644
--- a/models/exams
+++ b/models/exams
@@ -8,8 +8,8 @@ Exam
registerFrom UTCTime Maybe
registerTo UTCTime Maybe
deregisterUntil UTCTime Maybe
- publishOccurrenceAssignments UTCTime
- start UTCTime
+ publishOccurrenceAssignments UTCTime Maybe
+ start UTCTime Maybe
end UTCTime Maybe
finished UTCTime Maybe -- Grades shown to students, `ExamCorrector`s locked out
closed UTCTime Maybe -- Prüfungsamt hat Einsicht (notification)
diff --git a/src/Foundation.hs b/src/Foundation.hs
index f16c9dc79..af6f3421d 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -678,7 +678,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
case subRoute of
EShowR -> guard visible
- EUsersR -> guard $ examStart <= cTime
+ EUsersR -> guard $ NTop examStart <= NTop (Just cTime)
&& NTop (Just cTime) <= NTop examFinished
ERegisterR
| not registered -> guard $ visible
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index 404338e73..ef99c06de 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -425,15 +425,7 @@ getCShowR tid ssh csh = do
[ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) (toWidget examName)
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
- , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do
- startT <- formatTime SelFormatDateTime examStart
- endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
- [whamlet|
- $newline never
- #{startT}
- $maybe endT' <- endT
- \ – #{endT'}
- |]
+ , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
isRegistered <- case mbAid of
diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs
index 1758e3ffa..1be2b99fa 100644
--- a/src/Handler/Exam.hs
+++ b/src/Handler/Exam.hs
@@ -56,15 +56,7 @@ getCExamListR tid ssh csh = do
, (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
, Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
- , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do
- startT <- formatTime SelFormatDateTime examStart
- endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
- [whamlet|
- $newline never
- #{startT}
- $maybe endT' <- endT
- \ – #{endT'}
- |]
+ , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
]
dbtSorting = Map.fromList
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
@@ -154,13 +146,13 @@ postECInviteR = invitationR examCorrectorInvitationConfig
data ExamForm = ExamForm
{ efName :: ExamName
, efDescription :: Maybe Html
- , efStart :: UTCTime
+ , efStart :: Maybe UTCTime
, efEnd :: Maybe UTCTime
, efVisibleFrom :: Maybe UTCTime
, efRegisterFrom :: Maybe UTCTime
, efRegisterTo :: Maybe UTCTime
, efDeregisterUntil :: Maybe UTCTime
- , efPublishOccurrenceAssignments :: UTCTime
+ , efPublishOccurrenceAssignments :: Maybe UTCTime
, efFinished :: Maybe UTCTime
, efClosed :: Maybe UTCTime
, efOccurrences :: Set ExamOccurrenceForm
@@ -189,6 +181,8 @@ data ExamPartForm = ExamPartForm
, epfWeight :: Rational
} deriving (Read, Show, Eq, Ord, Generic, Typeable)
+makeLenses_ ''ExamForm
+
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
} ''ExamPartForm
@@ -206,13 +200,13 @@ examForm template html = do
<$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
<* aformSection MsgExamFormTimes
- <*> areq utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
+ <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
<*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template)
<*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template)
<*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template)
<*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template)
<*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
- <*> areq utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignments) (efPublishOccurrenceAssignments <$> template)
+ <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
<*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
<*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template)
<* aformSection MsgExamFormOccurrences
@@ -221,7 +215,7 @@ examForm template html = do
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template))
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template))
<*> examGradingRuleForm (efGradingRule <$> template)
- <*> bonusRuleForm (efBonusRule <$> template)
+ <*> examBonusRuleForm (efBonusRule <$> template)
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
<* aformSection MsgExamFormCorrection
<*> examCorrectorsForm (efCorrectors <$> template)
@@ -272,7 +266,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout")
- fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) True (Set.toList <$> mPrev)
+ fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) False (Set.toList <$> mPrev)
examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceForm prev = wFormToAForm $ do
@@ -281,7 +275,7 @@ examOccurrenceForm prev = wFormToAForm $ do
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
- fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) True $ Set.toList <$> prev
+ fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
where
examOccurrenceForm' nudge mPrev csrf = do
(eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
@@ -321,7 +315,7 @@ examPartsForm prev = wFormToAForm $ do
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
- fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) True $ Set.toList <$> prev
+ fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
where
examPartForm' nudge mPrev csrf = do
(epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
@@ -436,8 +430,8 @@ examTemplate cid = runMaybeT $ do
, efRegisterFrom = dateOffset <$> examRegisterFrom oldExam
, efRegisterTo = dateOffset <$> examRegisterTo oldExam
, efDeregisterUntil = dateOffset <$> examDeregisterUntil oldExam
- , efPublishOccurrenceAssignments = dateOffset $ examPublishOccurrenceAssignments oldExam
- , efStart = dateOffset $ examStart oldExam
+ , efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam
+ , efStart = dateOffset <$> examStart oldExam
, efEnd = dateOffset <$> examEnd oldExam
, efFinished = dateOffset <$> examFinished oldExam
, efClosed = dateOffset <$> examClosed oldExam
@@ -456,14 +450,31 @@ validateExam = do
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom
- guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ efStart >= efPublishOccurrenceAssignments
- guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop (Just efStart)
+ guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
+ guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
- guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop (Just efStart)
+ guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart
guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished
- guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop (Just efStart)
+ guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop efStart
guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd
+ forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
+ eofRange' <- formatTimeRange SelFormatDateTime eofStart eofEnd
+
+ guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofRoom eofRange') $ NTop eofEnd >= NTop (Just eofStart)
+ guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofRoom eofRange') $ NTop (Just eofStart) >= NTop efStart
+ guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofRoom eofRange') $ NTop eofEnd <= NTop efEnd
+
+ forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
+ eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)
+
+ guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b)
+ [ (/=) `on` eofRoom
+ , (/=) `on` eofStart
+ , (/=) `on` eofEnd
+ , (/=) `on` fmap renderHtml . eofDescription
+ ]
+
getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamNewR = postCExamNewR
@@ -669,7 +680,7 @@ getEShowR tid ssh csh examn = do
let gradingVisible = NTop (Just cTime) >= NTop examFinished
gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
- let occurrenceAssignmentsVisible = cTime >= examPublishOccurrenceAssignments
+ let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
@@ -703,7 +714,7 @@ getEShowR tid ssh csh examn = do
return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister))
- let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
+ let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
registerWidget
| Just isRegistered <- registered
, mayRegister = Just $ do
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index 7103afe14..4033e8ae1 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -231,15 +231,7 @@ homeUpcomingExams uid = do
indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) (toWidget examName)
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
- , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> cell $ do
- startT <- formatTime SelFormatDateTime examStart
- endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
- [whamlet|
- $newline never
- #{startT}
- $maybe endT' <- endT
- \ – #{endT'}
- |]
+ , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
{- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
, sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs
index 8297f7266..f0ba27edb 100644
--- a/src/Handler/Utils/DateTime.hs
+++ b/src/Handler/Utils/DateTime.hs
@@ -3,10 +3,11 @@ module Handler.Utils.DateTime
, localTimeToUTC, TZ.LocalToUTCResult(..)
, toMidnight, beforeMidnight, toMidday, toMorning
, formatDiffDays
- , formatTime, formatTime', formatTimeW
+ , formatTime'
+ , formatTime, formatTimeW, formatTimeMail
+ , formatTimeRange, formatTimeRangeW, formatTimeRangeMail
, getTimeLocale, getDateTimeFormat
, validDateTimeFormats, dateTimeFormatOptions
- , formatTimeMail
, addOneWeek, addWeeks
, weeksToAdd
, setYear
@@ -236,3 +237,44 @@ ceilingMinuteBy margin roundto utct = addUTCTime bonus utct
newMin = roundToNearestMultiple roundto $ oldMin + margin
newTime = oldTime { todMin = newMin, todSec = 0 } -- might be invalid, but correctly treated by `timeOfDayToTime`
bonus = realToFrac $ timeOfDayToTime newTime - timeOfDayToTime oldTime
+
+
+formatTimeRange' :: ( HasLocalTime t, HasLocalTime t'
+ , Monad m
+ )
+ => (forall t2. HasLocalTime t2 => SelDateTimeFormat -> t2 -> m Text) -- ^ @formatTime@
+ -> SelDateTimeFormat
+ -> t -- ^ Start
+ -> Maybe t' -- ^ End
+ -> m Text
+formatTimeRange' cont proj startT endT = do
+ startT' <- cont proj startT
+ let
+ endProj = (/\ proj) $ if
+ | Just endT' <- endT
+ , ((==) `on` localDay) (toLocalTime startT) (toLocalTime endT')
+ -> SelFormatTime
+ | otherwise
+ -> SelFormatDateTime
+ endT' <- for endT $ cont endProj
+
+ return $ case endT' of
+ Nothing -> startT'
+ Just endT'' -> [st|#{startT'} – #{endT''}|]
+
+
+formatTimeRange :: ( HasLocalTime t, HasLocalTime t'
+ , MonadHandler m
+ , HandlerSite m ~ UniWorX
+ )
+ => SelDateTimeFormat
+ -> t -- ^ Start
+ -> Maybe t' -- ^ End
+ -> m Text
+formatTimeRange = formatTimeRange' formatTime
+
+formatTimeRangeW :: (HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> Widget
+formatTimeRangeW s t t' = toWidget =<< formatTimeRange s t t'
+
+formatTimeRangeMail :: (MonadMail m, HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> m Text
+formatTimeRangeMail = formatTimeRange' formatTimeMail
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 58ea2ffaf..76a0a1a31 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -463,8 +463,8 @@ classifyBonusRule = \case
ExamNoBonus -> ExamNoBonus'
ExamBonusPoints{} -> ExamBonusPoints'
-bonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule
-bonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classifyBonusRule <$> prev
+examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule
+examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classifyBonusRule <$> prev
where
actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule)
actions = Map.fromList
diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs
index ae87527bf..c8a869514 100644
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/src/Handler/Utils/Form/MassInput.hs
@@ -21,8 +21,6 @@ import Utils.Lens
import Handler.Utils.Form.MassInput.Liveliness
import Handler.Utils.Form.MassInput.TH
-import Algebra.Lattice hiding (join)
-
import Text.Blaze (Markup)
import qualified Data.Text as Text
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index bb7c5dd78..cd1bd66c2 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -77,6 +77,8 @@ import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), To
import Data.Constraint as Import (Dict(..))
import Data.Void as Import (Void)
+import Algebra.Lattice as Import hiding (meet, join)
+
import Language.Haskell.TH.Instances as Import ()
import Data.List.NonEmpty.Instances as Import ()
import Data.NonNull.Instances as Import ()
diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs
index 3f66c65ee..97b73481d 100644
--- a/src/Utils/DateTime.hs
+++ b/src/Utils/DateTime.hs
@@ -34,6 +34,9 @@ import Data.Aeson.TH
import Utils.PathPiece
import Data.Time.Format.Instances ()
+
+import Algebra.Lattice
+import Algebra.Lattice.Ordered
-- $(timeLocaleMap _) :: [Lang] -> TimeLocale
@@ -78,7 +81,7 @@ newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
instance Hashable DateTimeFormat
-data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
+data SelDateTimeFormat = SelFormatDate | SelFormatTime | SelFormatDateTime
deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable)
instance Universe SelDateTimeFormat
@@ -98,3 +101,19 @@ instance {-# OVERLAPPING #-} Default (SelDateTimeFormat -> DateTimeFormat) where
def SelFormatDateTime = "%c"
def SelFormatDate = "%F"
def SelFormatTime = "%T"
+
+instance JoinSemiLattice SelDateTimeFormat where
+ a \/ b = getOrdered $ ((\/) `on` Ordered) a b
+
+instance MeetSemiLattice SelDateTimeFormat where
+ a /\ b = getOrdered $ ((/\) `on` Ordered) a b
+
+instance Lattice SelDateTimeFormat
+
+instance BoundedJoinSemiLattice SelDateTimeFormat where
+ bottom = SelFormatTime
+
+instance BoundedMeetSemiLattice SelDateTimeFormat where
+ top = SelFormatDateTime
+
+instance BoundedLattice SelDateTimeFormat
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 1749dd51a..ae9cb5325 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Utils.Form where
@@ -832,9 +833,18 @@ deriving newtype instance Monad m => Applicative (FormValidator r m)
deriving newtype instance Monad m => Monad (FormValidator r m)
deriving newtype instance Monad m => MonadState r (FormValidator r m)
deriving newtype instance MonadFix m => MonadFix (FormValidator r m)
+deriving newtype instance MonadResource m => MonadResource (FormValidator r m)
+deriving newtype instance MonadThrow m => MonadThrow (FormValidator r m)
+deriving newtype instance MonadIO m => MonadIO (FormValidator r m)
+instance MonadBase b m => MonadBase b (FormValidator r m) where
+ liftBase = lift . liftBase
instance MonadTrans (FormValidator r) where
lift = FormValidator . lift
+instance MonadHandler m => MonadHandler (FormValidator r m) where
+ type HandlerSite (FormValidator r m) = HandlerSite m
+ liftHandlerT = lift . liftHandlerT
+
validateForm :: MonadHandler m
=> FormValidator a m ()
-> (Markup -> MForm m (FormResult a, xml))
diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet
index 3603fee38..56b8b0fd1 100644
--- a/templates/exam-show.hamlet
+++ b/templates/exam-show.hamlet
@@ -44,14 +44,14 @@ $maybe desc <- examDescription
$maybe deregUntil <- examDeregisterUntil
_{MsgExamDeregisterUntil}
^{formatTimeW SelFormatDateTime deregUntil}
- _{MsgExamPublishOccurrenceAssignmentsParticipant}
- ^{formatTimeW SelFormatDateTime examPublishOccurrenceAssignments}
+ $maybe publishAssignments <- examPublishOccurrenceAssignments
+ _{MsgExamPublishOccurrenceAssignmentsParticipant}
+ ^{formatTimeW SelFormatDateTime publishAssignments}
$if examTimes
_{MsgExamTime}
- ^{formatTimeW SelFormatDateTime examStart}
- $maybe end <- examEnd
- \ – ^{formatTimeW (bool SelFormatDateTime SelFormatTime ((on (==) utctDay) examStart end)) end}
+ $maybe start <- examStart
+ ^{formatTimeRangeW SelFormatDateTime start examEnd}
$maybe finished <- examFinished
_{MsgExamFinishedParticipant}
^{formatTimeW SelFormatDateTime finished}
@@ -108,9 +108,7 @@ $if not (null occurrences)
| #{examOccurrenceRoom}
$if not examTimes
|
- ^{formatTimeW SelFormatDateTime examOccurrenceStart}
- $maybe end <- examOccurrenceEnd
- \ – ^{formatTimeW (bool SelFormatDateTime SelFormatTime ((on (==) utctDay) examStart end)) end}
+ ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}
|
$maybe desc <- examOccurrenceDescription
#{desc}
|