feat(exams): refine exam form

2019-09-18 11:45:08 +02:00 · 2019-09-18 11:45:08 +02:00 · 014a17a3be
commit 014a17a3be
parent f7a92a4ce5
10 changed files with 99 additions and 65 deletions
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@ -1329,17 +1329,20 @@ ExamClosedTip: Prüfungsämter, die im System Noten einsehen, werden zu diesem Z
 ExamShowGrades: Klausur ist benotet
 ExamShowGradesTip: Sollen genaue Noten angezeigt werden, oder sollen Teilnehmer und Prüfungsämter nur informiert werden, ob die Klausur bestanden wurde?
 ExamPublicStatistics: Statistik veröffentlichen
-ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmern angezeigt werden, sobald diese ihre Noten einsehen können?
+ExamPublicStatisticsTip: Soll die automatisch berechnete statistische Auswertung auch den Teilnehmern angezeigt werden, sobald diese ihre Noten einsehen können?
+ExamAutomaticGrading: Automatische Notenberechnung
+ExamAutomaticGradingTip: Sollen die Gesamtleistungen der Teilnehmer automatisch aus den in den einzelnen Teilprüfungen erreichten Leistungen berechnet werden? Etwaige Bonuspunkte werden dabei berücksichtigt. Manuelles Überschreiben der Gesamtleistung ist dennoch möglich.
 ExamGradingRule: Notenberechnung
 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
+ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilprüfungen mit ihrem Gewicht multipliziert wurden
 Points: Punkte
 PointsMustBeNonNegative: Punktegrenzen dürfen nicht negativ sein
 PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein
 GradingFrom: Ab
 ExamNew: Neue Prüfung
+ExamBonus: Bonuspunkte-System
 ExamBonusRule: Prüfungsbonus aus Übungsbetrieb
 ExamNoBonus': Kein automatischer Bonus
 ExamBonusPoints': Umrechnung von Übungspunkten
@ -1350,7 +1353,9 @@ ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte
 ExamBonusMaxPointsNonPositive: Maximaler Prüfungsbonus muss positiv und größer null sein
 ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen

-ExamOccurrenceRule: Automatische Termin- bzw. Raumzuteilung
+ExamAutomaticOccurrenceAssignment: Automatische Termin- bzw. Raumzuteilung
+ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer zum Zeitpunkt der Bekanntgabe der Raum- bzw. Terminzuteilung automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich.
+ExamOccurrenceRule: Verfahren
 ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren
 ExamRoomManual': Keine automatische Zuteilung
 ExamRoomSurname': Nach Nachname
@ -1384,9 +1389,9 @@ ExamFormParts: Teile
 ExamCorrectors: Korrektoren
 ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen

-ExamParts: Teilaufgaben
-ExamPartWeightNegative: Gewicht aller Teilaufgaben muss größer oder gleich Null sein
-ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits
+ExamParts: Teilprüfungen/Aufgaben
+ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein
+ExamPartAlreadyExists: Teilprüfunge mit diesem Namen existiert bereits
 ExamPartNumber: Nummer
 ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet
 ExamPartName: Name
@ -1524,7 +1529,7 @@ ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden
 ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern
 ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben
 ExamUserCsvSetResult: Ergebnis eintragen
-ExamUserCsvSetPartResult: Ergebnis einer Teilaufgabe eintragen
+ExamUserCsvSetPartResult: Ergebnis einer Teilprüfung eintragen
 ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen

 ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht
--- a/models/exams
+++ b/models/exams
@ -1,9 +1,9 @@
 Exam
  course CourseId
  name ExamName
-  gradingRule ExamGradingRule
-  bonusRule ExamBonusRule
-  occurrenceRule ExamOccurrenceRule
+  gradingRule ExamGradingRule Maybe
+  bonusRule ExamBonusRule Maybe
+  occurrenceRule ExamOccurrenceRule Maybe
  visibleFrom UTCTime Maybe
  registerFrom UTCTime Maybe
  registerTo UTCTime Maybe
--- a/src/Handler/Exam/Form.hs
+++ b/src/Handler/Exam/Form.hs
@ -26,6 +26,7 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
 data ExamForm = ExamForm
  { efName :: ExamName
  , efDescription :: Maybe Html
+  , efShowGrades :: Bool
  , efStart :: Maybe UTCTime
  , efEnd :: Maybe UTCTime
  , efVisibleFrom :: Maybe UTCTime
@ -35,11 +36,10 @@ data ExamForm = ExamForm
  , efPublishOccurrenceAssignments :: Maybe UTCTime
  , efFinished :: Maybe UTCTime
  , efOccurrences :: Set ExamOccurrenceForm
-  , efShowGrades :: Bool
  , efPublicStatistics :: Bool
-  , efGradingRule :: ExamGradingRule
-  , efBonusRule :: ExamBonusRule
-  , efOccurrenceRule :: ExamOccurrenceRule
+  , efGradingRule :: Maybe ExamGradingRule
+  , efBonusRule :: Maybe ExamBonusRule
+  , efOccurrenceRule :: Maybe ExamOccurrenceRule
  , efCorrectors :: Set (Either UserEmail UserId)
  , efExamParts :: Set ExamPartForm
  }
@ -80,6 +80,7 @@ examForm template html = do
  flip (renderAForm FormStandard) html $ ExamForm
    <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
    <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
+    <*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True)
    <*  aformSection MsgExamFormTimes
    <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
    <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template)
@ -92,11 +93,10 @@ examForm template html = do
    <*  aformSection MsgExamFormOccurrences
    <*> examOccurrenceForm (efOccurrences <$> template)
    <*  aformSection MsgExamFormAutomaticFunctions
-    <*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True)
    <*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
-    <*> examGradingRuleForm (efGradingRule <$> template)
-    <*> examBonusRuleForm (efBonusRule <$> template)
-    <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
+    <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
+    <*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
+    <*> optionalActionA (examOccurrenceRuleForm $ efOccurrenceRule =<< template) (fslI MsgExamAutomaticOccurrenceAssignment & setTooltip MsgExamAutomaticOccurrenceAssignmentTip) (is _Just . efOccurrenceRule <$> template)
    <*  aformSection MsgExamFormCorrection
    <*> examCorrectorsForm (efCorrectors <$> template)
    <*  aformSection MsgExamFormParts
--- a/src/Handler/Utils/Exam.hs
+++ b/src/Handler/Utils/Exam.hs
@ -103,7 +103,7 @@ examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results)

    withBonus :: Points -> Points
    withBonus ps
-      | ExamBonusPoints{..} <- examBonusRule
+      | Just ExamBonusPoints{..} <- examBonusRule
      = if
          |    not bonusOnlyPassed
            || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True)
@ -126,7 +126,7 @@ examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results)
    
    pointsToGrade :: Points -> Maybe ExamGrade
    pointsToGrade ps
-      | ExamGradingKey{..} <- examGradingRule
+      | Just ExamGradingKey{..} <- examGradingRule
      = Just $ gradeFromKey examGradingKey
      | otherwise
      = Nothing
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@ -518,8 +518,7 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c
        )
      ]

-data ExamBonusRule' = ExamNoBonus'
-                    | ExamBonusPoints'
+data ExamBonusRule' = ExamBonusPoints'
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 instance Universe ExamBonusRule'
 instance Finite ExamBonusRule'
@ -529,7 +528,6 @@ embedRenderMessage ''UniWorX ''ExamBonusRule' id

 classifyBonusRule :: ExamBonusRule -> ExamBonusRule'
 classifyBonusRule = \case
-  ExamNoBonus       -> ExamNoBonus'
  ExamBonusPoints{} -> ExamBonusPoints'

 examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule
@ -537,18 +535,14 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify
  where
    actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule)
    actions = Map.fromList
-      [ ( ExamNoBonus'
-        , pure ExamNoBonus
-        )
-      , ( ExamBonusPoints'
+      [ ( ExamBonusPoints'
        , ExamBonusPoints
            <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints) (preview _bonusMaxPoints =<< prev)
            <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev))
        )
      ]

-data ExamOccurrenceRule' = ExamRoomManual'
-                         | ExamRoomSurname'
+data ExamOccurrenceRule' = ExamRoomSurname'
                         | ExamRoomMatriculation'
                         | ExamRoomRandom'
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@ -560,7 +554,6 @@ embedRenderMessage ''UniWorX ''ExamOccurrenceRule' id

 classifyExamOccurrenceRule :: ExamOccurrenceRule -> ExamOccurrenceRule'
 classifyExamOccurrenceRule = \case
-  ExamRoomManual        -> ExamRoomManual'
  ExamRoomSurname       -> ExamRoomSurname'
  ExamRoomMatriculation -> ExamRoomMatriculation'
  ExamRoomRandom        -> ExamRoomRandom'
@ -569,13 +562,11 @@ examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurren
 examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamOccurrenceRule) . fmap classifyExamOccurrenceRule
  where
    reverseClassify = \case
-      ExamRoomManual'        -> ExamRoomManual
      ExamRoomSurname'       -> ExamRoomSurname
      ExamRoomMatriculation' -> ExamRoomMatriculation
      ExamRoomRandom'        -> ExamRoomRandom

-data ExamGradingRule' = ExamGradingManual'
-                      | ExamGradingKey'
+data ExamGradingRule' = ExamGradingKey'
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 instance Universe ExamGradingRule'
 instance Finite ExamGradingRule'
@ -585,7 +576,6 @@ embedRenderMessage ''UniWorX ''ExamGradingRule' id

 classifyExamGradingRule :: ExamGradingRule -> ExamGradingRule'
 classifyExamGradingRule = \case
-  ExamGradingManual -> ExamGradingManual'
  ExamGradingKey{}  -> ExamGradingKey'

 examGradingRuleForm :: Maybe ExamGradingRule -> AForm Handler ExamGradingRule
@ -593,10 +583,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas
  where
    actions :: Map ExamGradingRule' (AForm Handler ExamGradingRule)
    actions = Map.fromList
-      [ ( ExamGradingManual'
-        , pure ExamGradingManual
-        )
-      , ( ExamGradingKey'
+      [ ( ExamGradingKey'
        , ExamGradingKey <$> gradingKeyForm (fslI MsgExamGradingKey & setTooltip MsgExamGradingKeyTip) (preview _examGradingKey =<< prev)
        )
      ]
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@ -523,6 +523,20 @@ customMigrations = Map.fromListWith (>>)
            renameExamParts _ = return ()
        runConduit $ getExamEntries .| C.mapM_ renameExamParts
    )
+  , ( AppliedMigrationKey [migrationVersion|21.0.0|] [version|22.0.0|]
+    , whenM (tableExists "exam") $
+        [executeQQ|
+          ALTER TABLE "exam" ALTER COLUMN "grading_rule" DROP NOT NULL;
+          ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL;
+          ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL;
+
+          UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule" = '{ "rule": "manual" }';
+          UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule" = '{ "rule": "no-bonus"}';
+          UPDATE "exam" SET "occurrence_rule" = NULL WHERE "occurrence_rule" = '"manual"';
+
+          UPDATE "exam" SET "occurrence_rule" = json_build_object('rule', "occurrence_rule");
+        |]
+    )
  ]


--- a/src/Model/Types/Exam.hs
+++ b/src/Model/Types/Exam.hs
@ -116,28 +116,32 @@ instance Universe res => Universe (ExamResult' res) where
 instance Finite res => Finite (ExamResult' res)


-data ExamBonusRule = ExamNoBonus
-                   | ExamBonusPoints
+data ExamBonusRule = ExamBonusPoints
                     { bonusMaxPoints :: Points
                     , bonusOnlyPassed :: Bool
                     }
  deriving (Show, Read, Eq, Ord, Generic, Typeable)
 deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  , fieldLabelModifier = camelToPathPiece' 1
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 1
+  , allNullaryToStringTag = False
  , sumEncoding = TaggedObject "rule" "settings"
+  , unwrapUnaryRecords = False
+  , tagSingleConstructors = True
  } ''ExamBonusRule
 derivePersistFieldJSON ''ExamBonusRule

-data ExamOccurrenceRule = ExamRoomManual
-                        | ExamRoomSurname
+data ExamOccurrenceRule = ExamRoomSurname
                        | ExamRoomMatriculation
                        | ExamRoomRandom
  deriving (Show, Read, Eq, Ord, Generic, Typeable)
 deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 2
-  , fieldLabelModifier = camelToPathPiece' 1
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 2
+  , allNullaryToStringTag = False
  , sumEncoding = TaggedObject "rule" "settings"
+  , unwrapUnaryRecords = False
+  , tagSingleConstructors = True
  } ''ExamOccurrenceRule
 derivePersistFieldJSON ''ExamOccurrenceRule

@ -211,15 +215,17 @@ instance PersistFieldSql ExamGrade where


 data ExamGradingRule
-  = ExamGradingManual
-  | ExamGradingKey
+  = ExamGradingKey
    { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@
    }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
 deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 2
-  , fieldLabelModifier = camelToPathPiece' 2
+  { fieldLabelModifier = camelToPathPiece' 2
+  , constructorTagModifier = camelToPathPiece' 2
+  , allNullaryToStringTag = False
  , sumEncoding = TaggedObject "rule" "settings"
+  , unwrapUnaryRecords = False
+  , tagSingleConstructors = True
  } ''ExamGradingRule
 derivePersistFieldJSON ''ExamGradingRule

--- a/templates/exam-show.hamlet
+++ b/templates/exam-show.hamlet
@ -59,31 +59,30 @@ $maybe desc <- examDescription
      <dt .deflist__dt>_{MsgExamClosed}
      <dd .deflist__dd>^{formatTimeW SelFormatDateTime closed}
    $if gradingShown
-      $if examGradingRule /= ExamGradingManual
+      $maybe gradingRule <- examGradingRule
        <dt .deflist__dt>
          _{MsgExamGradingRule}
          $if not gradingVisible
            \ ^{isVisible False}
        <dd .deflist__dd>
-          $case examGradingRule
-            $of ExamGradingManual
-              _{MsgExamGradingManual'}
+          $case gradingRule
            $of ExamGradingKey{..}
              ^{gradingKeyW examGradingKey}
-      $if examBonusRule /= ExamNoBonus
+      $maybe bonusRule <- examBonusRule
        <dt .deflist__dt>
          _{MsgExamBonusRule}
          $if not gradingVisible
            \ ^{isVisible False}
        <dd .deflist__dd>
-          ^{examBonusW examBonusRule}
-    $if occurrenceAssignmentsShown
-      <dt .deflist__dt>
-        _{MsgExamOccurrenceRuleParticipant}
-        $if not occurrenceAssignmentsVisible
-          \ ^{isVisible False}
-      <dd .deflist__dd>
-        _{classifyExamOccurrenceRule examOccurrenceRule}
+          ^{examBonusW bonusRule}
+    $maybe occurrenceRule <- examOccurrenceRule
+      $if occurrenceAssignmentsShown
+        <dt .deflist__dt>
+          _{MsgExamOccurrenceRuleParticipant}
+          $if not occurrenceAssignmentsVisible
+            \ ^{isVisible False}
+        <dd .deflist__dd>
+          _{classifyExamOccurrenceRule occurrenceRule}
    $maybe registerWdgt <- registerWidget
      <dt .deflist__dt>_{MsgExamRegistration}
      <dd .deflist__dd>^{registerWdgt}
--- a/templates/widgets/bonusRule.hamlet
+++ b/templates/widgets/bonusRule.hamlet
@ -1,7 +1,5 @@
 $newline never
 $case bonusRule
-  $of ExamNoBonus
-    _{MsgExamNoBonus'}
  $of ExamBonusPoints ps False
    _{MsgExamBonusPoints ps}
  $of ExamBonusPoints ps True
--- a/test/Database.hs
+++ b/test/Database.hs
@ -467,6 +467,31 @@ fillDb = do
    ,(tinaTester, Just sfTTc)
    ]

+  examFFP <- insert' $ Exam
+    { examCourse = ffp
+    , examName = "Klausur"
+    , examGradingRule = Nothing
+    , examBonusRule = Nothing
+    , examOccurrenceRule = Nothing
+    , examVisibleFrom = Just now
+    , examRegisterFrom = Just now
+    , examRegisterTo = Just $ addUTCTime (14 * nominalDay) now
+    , examDeregisterUntil = Just $ addUTCTime (15 * nominalDay) now
+    , examPublishOccurrenceAssignments = Just $ addUTCTime (15 * nominalDay) now
+    , examStart = Just $ addUTCTime (16 * nominalDay) now
+    , examEnd = Just $ addUTCTime (17 * nominalDay) now
+    , examFinished = Just $ addUTCTime (21 * nominalDay) now
+    , examClosed = Nothing
+    , examPublicStatistics = True
+    , examShowGrades = True
+    , examDescription = Nothing
+    }
+  void . insertMany $ map (\u -> ExamRegistration examFFP u Nothing now)
+    [ fhamann
+    , maxMuster
+    , tinaTester
+    ]
+
  -- EIP
  eip <- insert' Course
    { courseName = "Einführung in die Programmierung"