fix(exams): cleanup exam interface

BREAKING CHANGE: examStart and examPublishOccurrenceAssignments now optional

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
+ExamPublishOccurrenceAssignments: Termin- bzw. Raumzuteilung den Teilnehmern mitteilen um
-ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welchen Teilprüfungen (Räumen) sie angemeldet sind
+ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welcher Teilprüfung bzw. welchen Raum sie angemeldet sind
-ExamPublishOccurrenceAssignmentsParticipant: Terminzuteilung einsehbar ab
+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
+ExamOccurrenceRule: Automatische Termin- bzw. Raumzuteilung
-ExamOccurrenceRuleParticipant: Terminzuteilung
+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
 

models/exams

@@ -8,8 +8,8 @@ Exam
   registerFrom UTCTime Maybe
   registerTo UTCTime Maybe
   deregisterUntil UTCTime Maybe
-  publishOccurrenceAssignments UTCTime
+  publishOccurrenceAssignments UTCTime Maybe
-  start UTCTime
+  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)

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

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
+          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
-              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 Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
               mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
               isRegistered <- case mbAid of

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
+          , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
-              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'}
-              |]
           ]
         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
+    , efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam
-    , efStart            = dateOffset $ examStart 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 MsgExamStartMustBeAfterPublishOccurrenceAssignments      . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
-  guardValidation MsgExamEndMustBeAfterStart                               $ NTop efEnd                          >= NTop (Just efStart)
+  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

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
+          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
-              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'}
-              |]
           {- 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

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

src/Handler/Utils/Form.hs

@@ -463,8 +463,8 @@ classifyBonusRule = \case
   ExamNoBonus       -> ExamNoBonus'
   ExamBonusPoints{} -> ExamBonusPoints'
 
-bonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule
+examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule
-bonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classifyBonusRule <$> prev
+examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classifyBonusRule <$> prev
   where
     actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule)
     actions = Map.fromList

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

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 ()

src/Utils/DateTime.hs

@@ -35,6 +35,9 @@ import Utils.PathPiece
 
 import Data.Time.Format.Instances ()
 
+import Algebra.Lattice
+import Algebra.Lattice.Ordered
+  
 
 -- $(timeLocaleMap _) :: [Lang] -> TimeLocale
 timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
@@ -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

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))

templates/exam-show.hamlet

@@ -44,14 +44,14 @@ $maybe desc <- examDescription
     $maybe deregUntil <- examDeregisterUntil
       <dt .deflist__dt>_{MsgExamDeregisterUntil}
       <dd .deflist__dd>^{formatTimeW SelFormatDateTime deregUntil}
-    <dt .deflist__dt>_{MsgExamPublishOccurrenceAssignmentsParticipant}
+    $maybe publishAssignments <- examPublishOccurrenceAssignments
-    <dd .deflist__dd>^{formatTimeW SelFormatDateTime examPublishOccurrenceAssignments}
+      <dt .deflist__dt>_{MsgExamPublishOccurrenceAssignmentsParticipant}
+      <dd .deflist__dd>^{formatTimeW SelFormatDateTime publishAssignments}
     $if examTimes
       <dt .deflist__dt>_{MsgExamTime}
       <dd .deflist__dd>
-        ^{formatTimeW SelFormatDateTime examStart}
+        $maybe start <- examStart
-        $maybe end <- examEnd
+          ^{formatTimeRangeW SelFormatDateTime start examEnd}
-          \ – ^{formatTimeW (bool SelFormatDateTime SelFormatTime ((on (==) utctDay) examStart end)) end}
     $maybe finished <- examFinished
       <dt .deflist__dt>_{MsgExamFinishedParticipant}
       <dd .deflist__dd>^{formatTimeW SelFormatDateTime finished}
@@ -108,9 +108,7 @@ $if not (null occurrences)
             <td .table__td>#{examOccurrenceRoom}
             $if not examTimes
               <td .table__td>
-                ^{formatTimeW SelFormatDateTime examOccurrenceStart}
+                ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}
-                $maybe end <- examOccurrenceEnd
-                  \ – ^{formatTimeW (bool SelFormatDateTime SelFormatTime ((on (==) utctDay) examStart end)) end}
             <td .table__td>
               $maybe desc <- examOccurrenceDescription
                 #{desc}