feat(exams): improve handling of exam results everywhere

BREAKING CHANGE: ExamResult now contains ExamResultPassedGrade

frontend/src/utils/form/interactive-fieldset.js

@@ -29,9 +29,9 @@ export class InteractiveFieldset {
       return false;
     }
 
-    if (this._element.querySelector('[uw-interactive-fieldset]')) {
+    // if (this._element.querySelector('[uw-interactive-fieldset]')) {
-      return false;
+    //   return false;
-    }
+    // }
 
     // param conditionalInput
     if (!this._element.dataset.conditionalInput) {

messages/uniworx/de-de-formal.msg

@@ -1640,6 +1640,7 @@ ExamCorrectors: Korrektoren
 ExamCorrectorsTip: Hier eingetragene Korrektoren können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer im System hinterlegen.
 ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen
 
+ExamPart: Teilprüfung/Aufgabe
 ExamParts: Teilprüfungen/Aufgaben
 ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein
 ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits
@@ -1703,10 +1704,16 @@ ExamUserAssignOccurrence: Termin/Raum zuweisen
 ExamUserAcceptComputedResult: Berechnetes Prüfungsergebnis übernehmen
 ExamUserResetToComputedResult: Prüfungsergebnis zurücksetzen
 ExamUserResetBonus: Auch Bonuspunkte zurücksetzen
+ExamUserSetPartResult: Teilergebnis setzen
+ExamUserSetBonus: Bonuspunkte setzen
+ExamUserSetResult: Prüfungsergebnis setzen
 ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet
 ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt
 ExamUsersResultsAccepted count@Int64: Prüfungsergebnis für #{show count} Teilnehmer übernommen
 ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehmer zurückgesetzt
+ExamUsersPartResultsSet count@Int64: Teilprüfungsergebnis für #{show count} Teilnehmer angepasst
+ExamUsersBonusSet count@Int64: Bonuspunkte für #{show count} Teilnehmer angepasst
+ExamUsersResultSet count@Int64: Prüfungsergebnis für #{show count} Teilnehmer angepasst
 
 ExamUserSynchronised: Synchronisiert
 ExamUserSyncOfficeName: Name
@@ -2314,3 +2321,5 @@ BtnExamAutoOccurrenceNudgeDown: -
 ExamRoomMappingSurname: Nachnamen beginnend mit
 ExamRoomMappingMatriculation: Matrikelnummern endend in
 ExamRoomLoad: Auslastung
+
+NoFilter: Keine Einschränkung

models/exams.model

@@ -56,7 +56,7 @@ ExamBonus
 ExamResult
   exam ExamId
   user UserId
-  result ExamResultGrade
+  result ExamResultPassedGrade
   lastChanged UTCTime default=now()
   UniqueExamResult exam user
 ExamCorrector

models/external-exams.model

@@ -9,7 +9,7 @@ ExternalExam
 ExternalExamResult
   user UserId
   exam ExternalExamId
-  result ExamResultGrade
+  result ExamResultPassedGrade
   time UTCTime
   lastChanged UTCTime
   UniqueExternalExamResult exam user

src/Foundation.hs

@@ -2255,7 +2255,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
 
       let navChildren = flip map (toList appLanguages) $ \lang -> NavLink
             { navLabel       = MsgLanguage lang
-            , navRoute       = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | let Just currentRoute = mCurrentRoute ])
+            , navRoute       = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
             , navAccess'     = return True
             , navType        = NavTypeButton
               { navMethod = POST
@@ -2281,7 +2281,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
         , navIcon       = IconMenuHelp
         , navLink       = NavLink
           { navLabel       = MsgMenuHelp
-          , navRoute       = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | let Just currentRoute = mCurrentRoute ])
+          , navRoute       = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
           , navAccess'     = return True
           , navType        = NavTypeLink { navModal = True }
           , navQuick'      = mempty

src/Handler/Exam/Correct.hs

@@ -213,11 +213,8 @@ postECorrectR tid ssh csh examn = do
                 delete oldId
                 audit $ TransactionExamResultDeleted eId uid
                 return Nothing
-            | Just result <- ciqGrade' -> let
+            | Just resultGrade <- ciqGrade' -> let
-                mOld = view passedGrade . examResultResult . entityVal <$> mOldResult
+                mOld = examResultResult . entityVal <$> mOldResult
-                resultGrade = review passedGrade result
-                passedGrade :: Iso' ExamResultGrade ExamResultPassedGrade
-                passedGrade = iso (fmap $ bool (Left . view passingGrade) Right examShowGrades) (fmap $ either (review passingGrade) id)
               in if
                 | ciqGrade' /= mOld -> do
                   newResult <- upsert ExamResult
@@ -230,8 +227,8 @@ postECorrectR tid ssh csh examn = do
                     , ExamResultLastChanged =. now
                     ]
                   audit $ TransactionExamResultEdit eId uid
-                  return $ newResult ^? _entityVal . _examResultResult . passedGrade
+                  return $ newResult ^? _entityVal . _examResultResult
-                | otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult . passedGrade
+                | otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult
             | otherwise -> return Nothing
               
         user <- userToResponse match

src/Handler/Exam/Show.hs

@@ -88,7 +88,7 @@ getEShowR tid ssh csh examn = do
 
       noBonus = fromMaybe False $ do
         guardM $ bonusOnlyPassed <$> examBonusRule
-        return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . passingGrade . _Wrapped . to not
+        return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
 
       sumPoints = fmap getSum . mconcat $ catMaybes
         [ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results

src/Handler/Exam/Users.hs

@@ -167,11 +167,12 @@ resultCourseNote = _dbrOutput . _10 . _Just
 resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points
 resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus'))
 
-resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade
+resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultPassedGrade
-resultAutomaticExamResult exam examBonus' = folding . runReader $ do
+resultAutomaticExamResult exam@Exam{..} examBonus' = folding . runReader $ do
   parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult))
   bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus'
-  return $ examGrade exam bonus =<< parts'
+  let gradeRes = examGrade exam bonus =<< parts'
+  return $ fmap (bool (Left . view passingGrade) Right examShowGrades) <$> gradeRes
 
 
 csvExamPartHeader :: Prism' Csv.Name ExamPartNumber
@@ -301,6 +302,9 @@ examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
 
 data ExamUserAction = ExamUserDeregister
                     | ExamUserAssignOccurrence
+                    | ExamUserSetPartResult
+                    | ExamUserSetBonus
+                    | ExamUserSetResult
                     | ExamUserAcceptComputedResult
                     | ExamUserResetToComputedResult
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
@@ -312,11 +316,15 @@ embedRenderMessage ''UniWorX ''ExamUserAction id
 
 data ExamUserActionData = ExamUserDeregisterData
                         | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
+                        | ExamUserSetPartResultData ExamPartNumber (Maybe ExamResultPoints)
+                        | ExamUserSetBonusData (Maybe Points)
+                        | ExamUserSetResultData (Maybe ExamResultPassedGrade)
                         | ExamUserAcceptComputedResultData
                         | ExamUserResetToComputedResultData
                           { examUserResetBonus :: Bool
                           }
 
+
 data ExamUserCsvActionClass
   = ExamUserCsvCourseRegister
   | ExamUserCsvRegister
@@ -394,6 +402,7 @@ getEUsersR = postEUsersR
 postEUsersR tid ssh csh examn = do
   (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do
     exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
+    occurrences <- selectList [ExamOccurrenceExam ==. eid] [Asc ExamOccurrenceName]
     examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
     bonus <- examBonus exam
 
@@ -405,14 +414,11 @@ postEUsersR tid ssh csh examn = do
       showPasses = doBonus && numSheetsPasses allBoni /= 0
       showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0
 
-      resultView :: ExamResultGrade -> ExamResultPassedGrade
-      resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades
-
       examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber
 
       resultAutomaticExamBonus' :: Fold ExamUserTableData Points
       resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus
-      resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade
+      resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultPassedGrade
       resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus
 
       automaticCell :: forall msg m a b r.
@@ -512,7 +518,7 @@ postEUsersR tid ssh csh examn = do
               [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
               | Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
               ]
-            , pure $ sortable (Just $ bool "result-bool" "result" examShowGrades) (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) . to (bimap resultView resultView)
+            , pure $ sortable (Just "exam-result") (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left)
             , pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote))
                 -> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote
             ]
@@ -528,34 +534,20 @@ postEUsersR tid ssh csh examn = do
               ]
             , singletonMap "occurrence" . SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)
             , singletonMap "bonus" . SortColumn $ queryExamBonus >>> (E.?. ExamBonusBonus)
-            , singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult)
+            , sortExamResult (to $ queryExamResult >>> (E.?. ExamResultResult))
-            , singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
             , singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
                 E.subSelectMaybe . E.from $ \edit -> do
                   E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
                   return . E.max_ $ edit E.^. CourseUserNoteEditTime
             ]
-          dbtFilter = Map.fromList
+          dbtFilter = mconcat
-            [ fltrUserNameEmail    queryUser
+            [ uncurry singletonMap $ fltrUserNameEmail    queryUser
-            , fltrUserMatriclenr   queryUser
+            , uncurry singletonMap $ fltrUserMatriclenr   queryUser
-            , fltrField            queryStudyField
+            , uncurry singletonMap $ fltrField            queryStudyField
-            , fltrDegree           queryStudyDegree
+            , uncurry singletonMap $ fltrDegree           queryStudyDegree
-            , fltrFeaturesSemester queryStudyFeatures
+            , uncurry singletonMap $ fltrFeaturesSemester queryStudyFeatures
-            , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
+            , uncurry singletonMap   ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
-            , ("result", FilterColumn . E.mkExactFilterWith Just $ queryExamResult >>> (E.?. ExamResultResult))
+            , fltrExamResultPoints (to $ queryExamResult >>> (E.?. ExamResultResult))
-            , ( "result-bool"
-              , FilterColumn $ \row criteria -> if
-                  | Set.null criteria -> E.true
-                  | otherwise -> let passed :: [ExamResultGrade]
-                                     passed = filter (\res -> preview (_examResult . passingGrade) res == Just (ExamPassed True)) universeF
-                                     criteria' = Set.map (fmap $ review passingGrade) criteria
-                                     criteria''
-                                       | ExamAttended (ExamPassed True) `Set.member` criteria
-                                       = criteria' `Set.union` Set.fromList passed
-                                       | otherwise
-                                       = criteria'
-                                  in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'')
-              )
             ]
           dbtFilterUI mPrev = mconcat $ catMaybes
             [ Just $ fltrUserNameEmailUI    mPrev
@@ -563,9 +555,8 @@ postEUsersR tid ssh csh examn = do
             , Just $ fltrFieldUI            mPrev
             , Just $ fltrDegreeUI           mPrev
             , Just $ fltrFeaturesSemesterUI mPrev
-            , Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence)
+            , Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) $ optionsF [CI.original examOccurrenceName | Entity _ ExamOccurrence{..} <- occurrences]) (fslI MsgExamOccurrence)
-            , guardOn examShowGrades $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examGradeField) (fslI MsgExamResult)
+            , Just $ fltrExamResultPointsUI mPrev
-            , guardOn (not examShowGrades) $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examPassedField) (fslI MsgExamResult)
             ]
           dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
           dbtParams = DBParamsForm
@@ -581,17 +572,36 @@ postEUsersR tid ssh csh examn = do
                         pure ExamUserDeregisterData
                     , singletonMap ExamUserAssignOccurrence $
                         ExamUserAssignOccurrenceData
-                        <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
+                          <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
-                    , bool mempty computeActionMap $ is _Just examGradingRule
+                    , singletonMap ExamUserAcceptComputedResult $
-                    ]
-                  computeActionMap = mconcat
-                    [ singletonMap ExamUserAcceptComputedResult $
                         pure ExamUserAcceptComputedResultData
                     , singletonMap ExamUserResetToComputedResult $
                         ExamUserResetToComputedResultData
-                        <$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule)
+                          <$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule)
+                    , singletonMap ExamUserSetPartResult $
+                        ExamUserSetPartResultData
+                          <$> areq (selectField $ optionsPairs (map ((MsgExamPartNumbered &&& id) . examPartNumber . entityVal) examParts)) (fslI MsgExamPart) Nothing
+                          <*> (fmap ExamAttended <$> aopt pointsField (fslI MsgPoints) Nothing)
+                    , singletonMap ExamUserSetBonus $
+                        ExamUserSetBonusData
+                          <$> aopt pointsField (fslI MsgPoints) Nothing
+                    , singletonMap ExamUserSetResult $
+                        ExamUserSetResultData
+                          <$> aopt (examResultField (Just $ SomeMessage MsgExamResultNone) examPassedGradeField) (fslI MsgExamResult) Nothing
                     ]
-                (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
+
+                  actionOpts :: Handler (OptionList ExamUserAction)
+                  actionOpts = execWriterT $ do
+                    tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
+                    when (is _Just examGradingRule) $
+                      tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
+                    when (not $ null examParts) $
+                      tell =<< optionsF [ ExamUserSetPartResult ]
+                    when doBonus $
+                      tell =<< optionsF [ ExamUserSetBonus ]
+                    tell =<< optionsF [ ExamUserSetResult ]
+
+                (res, formWgt) <- multiActionMOpts actionMap actionOpts (fslI MsgAction) Nothing csrf
                 let formRes = (, mempty) . First . Just <$> res
                 return (formRes, formWgt)
             , dbParamsFormEvaluate = liftHandler . runFormPost
@@ -623,7 +633,7 @@ postEUsersR tid ssh csh examn = do
                 <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
                 <*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus)
                 <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts))
-                <*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView
+                <*> preview (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
                 <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
           dbtCsvDecode = Just DBTCsvDecode
             { dbtCsvRowKey = \csv -> do
@@ -686,8 +696,8 @@ postEUsersR tid ssh csh examn = do
                       oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus')
 
                       newResult, oldResult :: Maybe ExamResultPassedGrade
-                      newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults
+                      newResult = fmap (fmap $ bool (Left . view passingGrade) Right examShowGrades) . examGrade examVal (newBonus <|> oldBonus) =<< newResults
-                      oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView
+                      oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
                   
                   when doBonus $
                     case newBonus of
@@ -806,12 +816,11 @@ postEUsersR tid ssh csh examn = do
                       deleteBy $ UniqueExamResult eid examUserCsvActUser
                       audit $ TransactionExamResultDeleted eid examUserCsvActUser
                     Just res -> do
-                      let res' = either (review passingGrade) id <$> res
                       now <- liftIO getCurrentTime
                       void $ upsertBy
                         (UniqueExamResult eid examUserCsvActUser)
-                        (ExamResult eid examUserCsvActUser res' now)
+                        (ExamResult eid examUserCsvActUser res now)
-                        [ ExamResultResult =. res'
+                        [ ExamResultResult =. res
                         , ExamResultLastChanged =. now
                         ]
                       audit $ TransactionExamResultEdit eid examUserCsvActUser
@@ -1084,6 +1093,88 @@ postEUsersR tid ssh csh examn = do
             Nothing -> return mempty
       addMessageI Success $ MsgExamUsersResultsReset nrReset
       redirect $ CExamR tid ssh csh examn EUsersR
+    (ExamUserSetPartResultData part mPts, Map.elems -> rows) -> do
+      now <- liftIO getCurrentTime
+      updated <- fmap getSum . runDB $ do
+        partId <- getKeyBy $ UniqueExamPartNumber eId part
+        flip foldMapM partId $ \epId -> flip foldMapM rows $ \row -> do
+          let uid = row ^. resultUser . _entityKey
+          oldPartResult <- getBy $ UniqueExamPartResult epId uid
+          case mPts of
+            Just pts
+              | maybe True ((/= pts) . examPartResultResult . entityVal) oldPartResult -> do
+                void $ upsert
+                  ExamPartResult
+                    { examPartResultExamPart = epId
+                    , examPartResultUser = row ^. resultUser . _entityKey
+                    , examPartResultResult = pts
+                    , examPartResultLastChanged = now
+                    }
+                  [ ExamPartResultResult =. pts, ExamPartResultLastChanged =. now ]
+                audit $ TransactionExamPartResultEdit epId uid
+                return $ Sum 1
+            Nothing
+              | is _Just oldPartResult -> do
+                deleteBy $ UniqueExamPartResult epId uid
+                audit $ TransactionExamPartResultDeleted epId uid
+                return $ Sum 1
+            _other -> return mempty
+      addMessageI Success $ MsgExamUsersPartResultsSet updated
+      redirect $ CExamR tid ssh csh examn EUsersR
+    (ExamUserSetBonusData mPts, Map.elems -> rows) -> do
+      now <- liftIO getCurrentTime
+      updated <- fmap getSum . runDB $ do
+        flip foldMapM rows $ \row -> do
+          let uid = row ^. resultUser . _entityKey
+          oldBonus <- getBy $ UniqueExamBonus eId uid
+          case mPts of
+            Just pts
+              | maybe True ((/= pts) . examBonusBonus . entityVal) oldBonus -> do
+                void $ upsert
+                  ExamBonus
+                    { examBonusExam = eId
+                    , examBonusUser = row ^. resultUser . _entityKey
+                    , examBonusBonus = pts
+                    , examBonusLastChanged = now
+                    }
+                  [ ExamBonusBonus =. pts, ExamBonusLastChanged =. now ]
+                audit $ TransactionExamBonusEdit eId uid
+                return $ Sum 1
+            Nothing
+              | is _Just oldBonus -> do
+                deleteBy $ UniqueExamBonus eId uid
+                audit $ TransactionExamBonusDeleted eId uid
+                return $ Sum 1
+            _other -> return mempty
+      addMessageI Success $ MsgExamUsersBonusSet updated
+      redirect $ CExamR tid ssh csh examn EUsersR
+    (ExamUserSetResultData mRes, Map.elems -> rows) -> do
+      now <- liftIO getCurrentTime
+      updated <- fmap getSum . runDB $ do
+        flip foldMapM rows $ \row -> do
+          let uid = row ^. resultUser . _entityKey
+          oldResult <- getBy $ UniqueExamResult eId uid
+          case mRes of
+            Just res
+              | maybe True ((/= res) . examResultResult . entityVal) oldResult -> do
+                void $ upsert
+                  ExamResult
+                    { examResultExam = eId
+                    , examResultUser = row ^. resultUser . _entityKey
+                    , examResultResult = res
+                    , examResultLastChanged = now
+                    }
+                  [ ExamResultResult =. res, ExamResultLastChanged =. now ]
+                audit $ TransactionExamResultEdit eId uid
+                return $ Sum 1
+            Nothing
+              | is _Just oldResult -> do
+                deleteBy $ UniqueExamResult eId uid
+                audit $ TransactionExamResultDeleted eId uid
+                return $ Sum 1
+            _other -> return mempty
+      addMessageI Success $ MsgExamUsersResultSet updated
+      redirect $ CExamR tid ssh csh examn EUsersR
 
   closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId
 

src/Handler/ExamOffice/Exam.hs

@@ -341,7 +341,7 @@ postEGradesR tid ssh csh examn = do
                 start <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just
                 end <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceEnd . _Just <> like examEnd . _Just
                 lift $ maybe mempty (flip (formatTimeRangeW SelFormatDateTime) end) start
-            , colExamResult examShowGrades (resultExamResult . _entityVal . _examResultResult)
+            , colExamResult (resultExamResult . _entityVal . _examResultResult)
             ]
           dbtSorting = mconcat
             [ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
@@ -350,7 +350,7 @@ postEGradesR tid ssh csh examn = do
             , sortStudyDegree queryStudyDegree
             , sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
             , sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart)))
-            , maybeOpticSortColumn (sortExamResult examShowGrades) (queryExamResult . to (E.^. ExamResultResult))
+            , maybeOpticSortColumn sortExamResult (queryExamResult . to (E.^. ExamResultResult))
             , singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
             ]
           dbtFilter = mconcat
@@ -359,7 +359,7 @@ postEGradesR tid ssh csh examn = do
             , fltrStudyTerms queryStudyField
             , fltrStudyDegree queryStudyDegree
             , fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
-            , fltrExamResultPoints examShowGrades (queryExamResult . to (E.^. ExamResultResult))
+            , fltrExamResultPoints (queryExamResult . to (E.^. ExamResultResult) . to E.just)
             , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
             ]
           dbtFilterUI = mconcat
@@ -368,7 +368,7 @@ postEGradesR tid ssh csh examn = do
             , fltrStudyTermsUI
             , fltrStudyDegreeUI
             , fltrStudyFeaturesSemesterUI
-            , fltrExamResultPointsUI examShowGrades
+            , fltrExamResultPointsUI
             , \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
             ]
           dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
@@ -408,7 +408,7 @@ postEGradesR tid ssh csh examn = do
                   (row ^? resultStudyDegree . _entityVal . to (\StudyDegree{..} -> fromMaybe (tshow studyDegreeKey) $ studyDegreeName <|> studyDegreeShorthand))
                   (row ^? resultStudyFeatures . _entityVal . _studyFeaturesSemester)
                   (row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime)
-                  (row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades))
+                  (row ^. resultExamResult . _entityVal . _examResultResult)
             , dbtCsvName = unpack csvName
             , dbtCsvNoExportData = Nothing
             , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)

src/Handler/Utils/ExternalExam/Users.hs

@@ -178,9 +178,6 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
   currentRoute <- fromMaybe (error "makeExternalExamUsersTable called from 404-handler") <$> getCurrentRoute
 
   let
-    resultView :: ExamResultGrade -> ExamResultPassedGrade
-    resultView = fmap $ bool (Left . view passingGrade) Right externalExamShowGrades
-    
     dbtSQLQuery = runReaderT $ do
       result <- view queryResult
       user <- view queryUser
@@ -262,25 +259,25 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
       , Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do
           t <- view $ resultResult . _entityVal . _externalExamResultTime
           lift $ formatTimeW SelFormatDateTime t
-      , colExamResult externalExamShowGrades (resultResult . _entityVal . _externalExamResultResult)
+      , colExamResult (resultResult . _entityVal . _externalExamResultResult)
       ]
     dbtSorting = mconcat
       [ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
       , sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
       , sortOccurrenceStart (queryResult . to (E.^. ExternalExamResultTime))
-      , maybeOpticSortColumn (sortExamResult externalExamShowGrades) (queryResult . to (E.^. ExternalExamResultResult))
+      , maybeOpticSortColumn sortExamResult (queryResult . to (E.^. ExternalExamResultResult))
       , singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
       ]
     dbtFilter = mconcat
       [ fltrUserName' (queryUser . to (E.^. UserDisplayName))
       , fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
-      , fltrExamResultPoints externalExamShowGrades (queryResult . to (E.^. ExternalExamResultResult))
+      , fltrExamResultPoints (queryResult . to (E.^. ExternalExamResultResult) . to E.just)
       , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
       ]
     dbtFilterUI = mconcat
       [ fltrUserNameUI'
       , fltrUserMatriculationUI
-      , fltrExamResultPointsUI externalExamShowGrades
+      , fltrExamResultPointsUI
       , case mode of
           EEUMGrades ->
             \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
@@ -332,7 +329,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
           , csvEUserName            = row ^? resultUser . _entityVal . _userDisplayName
           , csvEUserMatriculation   = row ^? resultUser . _entityVal . _userMatrikelnummer . _Just
           , csvEUserOccurrenceStart = row ^. resultResult . _entityVal . _externalExamResultTime . to utcToZonedTime
-          , csvEUserExamResult      = row ^. resultResult . _entityVal . _externalExamResultResult . to (fmap $ bool (Left . view passingGrade) Right externalExamShowGrades)
+          , csvEUserExamResult      = row ^. resultResult . _entityVal . _externalExamResultResult
           }
     dbtCsvDecode
       | mode == EEUMUsers = Just DBTCsvDecode
@@ -353,7 +350,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
               when (zonedTimeToUTC csvEUserOccurrenceStart /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultTime) $
                 yield $ ExternalExamUserCsvSetTimeData (E.unValue dbCsvOldKey) (zonedTimeToUTC csvEUserOccurrenceStart)
 
-              when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult . to resultView) $
+              when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult) $
                 yield $ ExternalExamUserCsvSetResultData (E.unValue dbCsvOldKey) csvEUserExamResult
         , dbtCsvClassifyAction = \case
             ExternalExamUserCsvRegisterData{}   -> ExternalExamUserCsvRegister
@@ -368,12 +365,11 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
             C.mapM_ $ \case
               ExternalExamUserCsvRegisterData{..} -> do
                 now <- liftIO getCurrentTime
-                let res' = either (review passingGrade) id <$> externalExamUserCsvActResult
                 insert_ ExternalExamResult
                   { externalExamResultExam        = eeId
                   , externalExamResultUser        = externalExamUserCsvActUser
                   , externalExamResultTime        = externalExamUserCsvActTime
-                  , externalExamResultResult      = res'
+                  , externalExamResultResult      = externalExamUserCsvActResult
                   , externalExamResultLastChanged = now
                   }
                 audit $ TransactionExternalExamResultEdit eeId externalExamUserCsvActUser
@@ -386,9 +382,8 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
                 audit $ TransactionExternalExamResultEdit eeId externalExamResultUser
               ExternalExamUserCsvSetResultData{..} -> do
                 now <- liftIO getCurrentTime
-                let res' = either (review passingGrade) id <$> externalExamUserCsvActResult
                 ExternalExamResult{..} <- updateGet externalExamUserCsvActRegistration
-                  [ ExternalExamResultResult =. res'
+                  [ ExternalExamResultResult =. externalExamUserCsvActResult
                   , ExternalExamResultLastChanged =. now
                   ]
                 audit $ TransactionExternalExamResultEdit eeId externalExamResultUser

src/Handler/Utils/Form.hs

@@ -221,6 +221,15 @@ multiAction :: forall action a.
             -> Maybe action
             -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
 multiAction = multiAction' mpopt
+
+multiActionOpts :: forall action a.
+                   Ord action
+                => Map action (AForm Handler a)
+                -> Handler (OptionList action)
+                -> FieldSettings UniWorX
+                -> Maybe action
+                -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
+multiActionOpts = multiActionOpts' mpopt
   
 multiAction' :: forall action a.
                 ( RenderMessage UniWorX action, PathPiece action, Ord action )
@@ -229,15 +238,37 @@ multiAction' :: forall action a.
              -> FieldSettings UniWorX
              -> Maybe action
              -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
-multiAction' minp acts fs@FieldSettings{..} defAction csrf = do
+multiAction' minp acts = multiActionOpts' minp acts (optionsF $ Map.keysSet acts)
-  (actionRes, actionView) <- minp (selectField . optionsF $ Map.keysSet acts) fs defAction
+
-  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
+multiActionOpts' :: forall action a.
+                    Ord action
+                 => (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
+                 -> Map action (AForm Handler a)
+                 -> Handler (OptionList action)
+                 -> FieldSettings UniWorX
+                 -> Maybe action
+                 -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
+multiActionOpts' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do
+  actsOpts <- liftHandler mActsOpts
+  let actsOpts' = OptionList
+        { olOptions      = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts
+        , olReadExternal = assertM (flip Map.member acts) . olReadExternal actsOpts
+        }
+      acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts
+  
+  (actionRes, actionView) <- minp (selectField $ return actsOpts') fs defAction
+  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts'
 
   let actionResults = view _1 <$> results
+  
       actionViews = Map.foldrWithKey accViews [] results
 
       accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
-      accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
+      accViews act
+        | Option{..} : _ <- filter ((== act) . optionInternalValue) $ olOptions actsOpts'
+        = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
+        | otherwise
+        = flip const
 
   return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
 
@@ -247,6 +278,14 @@ multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action)
              -> Maybe action
              -> AForm Handler a
 multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
+  
+multiActionAOpts :: Ord action
+                 => Map action (AForm Handler a)
+                 -> Handler (OptionList action)
+                 -> FieldSettings UniWorX
+                 -> Maybe action
+                 -> AForm Handler a
+multiActionAOpts acts opts fSettings defAction = formToAForm $ multiActionOpts acts opts fSettings defAction mempty
 
 multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action)
              => Map action (AForm Handler a)
@@ -254,6 +293,14 @@ multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action)
              -> Maybe action
              -> WForm Handler (FormResult a)
 multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction
+  
+multiActionWOpts :: Ord action
+                 => Map action (AForm Handler a)
+                 -> Handler (OptionList action)
+                 -> FieldSettings UniWorX
+                 -> Maybe action
+                 -> WForm Handler (FormResult a)
+multiActionWOpts acts opts fSettings defAction = aFormToWForm $ multiActionAOpts acts opts fSettings defAction
 
 multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action)
              => Map action (AForm Handler a)
@@ -261,6 +308,14 @@ multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action)
              -> Maybe action
              -> (Html -> MForm Handler (FormResult a, Widget))
 multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
+  
+multiActionMOpts :: Ord action
+                 => Map action (AForm Handler a)
+                 -> Handler (OptionList action)
+                 -> FieldSettings UniWorX
+                 -> Maybe action
+                 -> (Html -> MForm Handler (FormResult a, Widget))
+multiActionMOpts acts opts fSettings defAction = renderAForm FormStandard $ multiActionAOpts acts opts fSettings defAction
 
 
 ------------
@@ -1175,32 +1230,33 @@ examResultField :: forall m res.
                    , HandlerSite m ~ UniWorX
                    , PathPiece res
                    )
-                => Field m res -> Field m (ExamResult' res)
+                => Maybe (SomeMessage UniWorX) -> Field m res -> Field m (ExamResult' res)
-examResultField innerField = Field
+examResultField optMsg innerField = Field
   { fieldEnctype = UrlEncoded <> fieldEnctype innerField
   , fieldParse = \ts fs -> if
-      | [t] <- ts
+      | res : _ <- mapMaybe (assertM ((||) <$> is _ExamNoShow <*> is _ExamVoided) . fromPathPiece) ts
-      , Just res <- fromPathPiece t
-      , is _ExamNoShow res || is _ExamVoided res
         -> return . Right $ Just res
+      | null ts || any null ts
+        -> return $ Right Nothing
       | otherwise
-        -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["attended", "no-show", "voided"])) ts) fs
+        -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["", "attended", "no-show", "voided"])) ts) fs
   , fieldView = \theId name attrs val isReq -> do
       innerId <- newIdent
       let
-        val' :: ExamResult' (Either Text res)
-        val' = either (ExamAttended . Left) (fmap Right) val
         innerVal :: Either Text res
         innerVal = val >>= maybe (Left "") return . preview _ExamAttended
       [whamlet|
         $newline never
         <div>
           <select id=#{theId} name=#{name} *{attrs} :isReq:required style="display: inline-block">
-            <option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
+            $maybe optMsg' <- guardOnM (not isReq) optMsg
-            <option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
+              <option value="" :is _Left val:selected>
-            <option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
+                _{optMsg'}
+            <option value="attended" :is (_Right . _ExamAttended) val:selected>_{MsgExamResultAttended}
+            <option value="no-show" :is (_Right . _ExamNoShow) val:selected>_{MsgExamResultNoShow}
+            <option value="voided" :is (_Right . _ExamVoided) val:selected>_{MsgExamResultVoided}
           <fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{theId} data-conditional-value="attended" style="display: inline-block">
-            ^{fieldView innerField innerId name attrs innerVal False}
+            ^{fieldView innerField innerId name attrs innerVal True}
       |]
   }
 
@@ -1218,6 +1274,13 @@ examPassedField :: forall m.
                 => Field m ExamPassed
 examPassedField = hoistField liftHandler $ selectField optionsFinite
 
+examPassedGradeField :: forall m.
+                        ( MonadHandler m
+                        , HandlerSite m ~ UniWorX
+                        )
+                     => Field m (Either ExamPassed ExamGrade)
+examPassedGradeField = hoistField liftHandler . selectField $ (<>) <$> (fmap Left <$> optionsFinite) <*> (fmap Right <$> optionsFinite)
+
 
 data CsvFormatOptions' = CsvFormatOptionsPreset' CsvPreset
                        | CsvFormatOptionsCustom'

src/Handler/Utils/Table/Columns.hs

@@ -270,39 +270,23 @@ sortOccurrenceStart queryStart = singletonMap "occurrence-start" . SortColumn $
 -- Exam results --
 ------------------
 
-colExamResult :: Bool -- ^ Show grades?
+colExamResult :: OpticColonnade ExamResultPassedGrade
-              -> OpticColonnade ExamResultGrade
+colExamResult resultResult = Colonnade.singleton (fromSortable header) body
-colExamResult showGrades resultResult = Colonnade.singleton (fromSortable header) body
   where
     header = Sortable (Just "exam-result") (i18nCell MsgExamResult)
-    body = views resultResult $ bool (i18nCell . fmap (view passingGrade)) i18nCell showGrades
+    body = views resultResult i18nCell
 
-sortExamResult :: Bool -- ^ Show grades?
+sortExamResult :: OpticSortColumn (Maybe ExamResultPassedGrade)
-               -> OpticSortColumn (Maybe ExamResultGrade)
+sortExamResult queryResult = singletonMap "exam-result" $ SortColumn $ view  queryResult
-sortExamResult showGrades queryResult = singletonMap "exam-result" $ if
-  | showGrades -> SortColumn $ view  queryResult
-  | otherwise  -> SortColumn . views queryResult $ E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
 
-fltrExamResultPoints :: Bool -- ^ Show grades?
+fltrExamResultPoints :: OpticFilterColumn' t (Set ExamResultPassedGrade) (E.SqlExpr (E.Value (Maybe ExamResultPassedGrade)))
-                     -> OpticFilterColumn t ExamResultGrade
+fltrExamResultPoints queryExamResult = singletonMap "exam-result" . FilterColumn $ \row criteria -> if
-fltrExamResultPoints showGrades queryExamResult = singletonMap "exam-result" . FilterColumn $ \row criteria -> if
   | Set.null criteria -> E.true
-  | otherwise -> let matches :: [ExamResultGrade]
+  | otherwise -> view queryExamResult row `E.in_` E.valList (Just <$> Set.toList criteria)
-                     matches = filter (\res -> oany (((==) `on` viewResult) res) criteria) universeF
-
-                     viewResult
-                       | showGrades = id
-                       | otherwise  = fmap (view $ passingGrade . from passingGrade)
-                  in view queryExamResult row `E.in_` E.valList matches
 
 
-fltrExamResultPointsUI :: Bool -- ^ Show grades?
+fltrExamResultPointsUI :: DBFilterUI
-                       -> DBFilterUI
+fltrExamResultPointsUI mPrev = prismAForm (singletonFilter "exam-result" . maybePrism _PathPiece) mPrev $ aopt (examResultField (Just $ SomeMessage MsgNoFilter) examPassedGradeField) (fslI MsgExamResult)
-fltrExamResultPointsUI showGrades mPrev = prismAForm (singletonFilter "exam-result" . maybePrism _PathPiece) mPrev $ aopt field (fslI MsgExamResult)
-  where
-    field
-      | showGrades = examResultField examGradeField
-      | otherwise  = convertField (over _examResult $ review passingGrade) (over _examResult $ view passingGrade) $ examResultField examPassedField
 
 -------------
 -- Courses --

src/Import/NoModel.hs

@@ -154,6 +154,7 @@ import Colonnade.Instances as Import ()
 import Data.Bool.Instances as Import ()
 import Data.Encoding.Instances as Import ()
 import Prometheus.Instances as Import ()
+import Yesod.Form.Fields.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256)
 

src/Model/Migration.hs

@@ -606,6 +606,14 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL;
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|30.0.0|] [version|31.0.0|]
+    , whenM ((&&) <$> tableExists "exam" <*> tableExists "exam_result") $ do
+        queryRes <- [sqlQQ|SELECT exam_result.id, exam_result.result FROM exam_result INNER JOIN exam ON exam_result.exam = exam.id WHERE NOT exam.show_grades;|]
+        forM_ queryRes $ \(resId :: ExamResultId, Single (res :: ExamResultGrade)) ->
+          let res' :: ExamResultPassedGrade
+              res' = Left . view passingGrade <$> res
+           in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|]
+    )
   ]
 
 

src/Model/Types/Exam.hs

@@ -333,6 +333,17 @@ instance Csv.ToField (Either ExamPassed ExamGrade) where
 instance Csv.FromField (Either ExamPassed ExamGrade) where
   parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint
 
+instance PathPiece (Either ExamPassed ExamGrade) where
+  toPathPiece = either toPathPiece toPathPiece
+  fromPathPiece x = (Left <$> fromPathPiece x) <|> (Right <$> fromPathPiece x)
+
+instance {-# OVERLAPPING #-} ToJSON (Either ExamPassed ExamGrade) where
+  toJSON = either toJSON toJSON
+  toEncoding = either toEncoding toEncoding
+
+instance {-# OVERLAPPING #-} FromJSON (Either ExamPassed ExamGrade) where
+  parseJSON x = (Left <$> parseJSON x) <|> (Right <$> parseJSON x)
+
 
 newtype ExamPartNumber = ExamPartNumber { examPartNumberFragments :: [Either (CI Text) Natural] }
   deriving (Eq, Ord, Generic, Typeable)

src/Yesod/Form/Fields/Instances.hs

@@ -0,0 +1,29 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Yesod.Form.Fields.Instances
+  () where
+
+import ClassyPrelude hiding (foldMap)
+import Yesod.Form.Fields
+
+import Data.Foldable (Foldable(..))
+
+
+deriving instance Foldable Option
+deriving instance Traversable Option
+
+instance Foldable OptionList where
+  foldMap f OptionList{..} = foldMap (foldMap f) olOptions 
+
+
+instance Semigroup (OptionList a) where
+  a <> b = OptionList
+    { olOptions      = olOptions a <> olOptions b
+    , olReadExternal = \inp -> olReadExternal a inp <|> olReadExternal b inp
+    }
+
+instance Monoid (OptionList a) where
+  mempty = OptionList
+    { olOptions      = mempty
+    , olReadExternal = const Nothing
+    }

templates/exam-show.hamlet

@@ -9,13 +9,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result
       <p .result>
         $case examResultResult
           $of ExamAttended grade
-            $if examShowGrades
+            _{grade}
-              _{grade}
-            $else
-              $if view (passingGrade . _Wrapped) grade
-                _{MsgExamPassed}
-              $else
-                _{MsgExamNotPassed}
           $of ExamNoShow
             _{MsgExamNoShow}
           $of ExamVoided

templates/external-exam-show.hamlet

@@ -7,13 +7,7 @@ $maybe ExternalExamResult{externalExamResultResult} <- mResult
     <p .result>
       $case externalExamResultResult
         $of ExamAttended grade
-          $if externalExamShowGrades
+          _{grade}
-            _{grade}
-          $else
-            $if view (passingGrade . _Wrapped) grade
-              _{MsgExamPassed}
-            $else
-              _{MsgExamNotPassed}
         $of ExamNoShow
           _{MsgExamNoShow}
         $of ExamVoided

templates/widgets/multi-action/multi-action.hamlet

@@ -1,4 +1,5 @@
-<fieldset uw-interactive-fieldset data-conditional-input=#{fvId actionView} data-conditional-value=#{toPathPiece act}>
+$newline never
+<fieldset uw-interactive-fieldset data-conditional-input=#{fvId actionView} data-conditional-value=#{optionExternalValue}>
   <legend>
-    _{act}
+    #{optionDisplay}
   ^{w}