Merge branch 'feat/exam-sheets'

frontend/src/app.sass

@@ -461,7 +461,7 @@ input[type="button"].btn-info:not(.btn-link):hover,
   overflow-y: auto
 
 .table--vertical
-  th
+  th, .table__th
     background-color: transparent
     color: var(--color-font)
     width: 170px
@@ -469,7 +469,16 @@ input[type="button"].btn-info:not(.btn-link):hover,
     padding-right: 15px
     font-weight: 400
 
-  td
+    a
+      color: var(--color-lin)
+
+      &:hover
+        color: var(--color-link-hover)
+
+      &::before
+        display: none
+
+  td, .table__td
     font-weight: 600
     color: var(--color-font)
 

load/Load.hs

@@ -50,13 +50,6 @@ import Data.List (genericLength)
 import qualified Control.Retry as Retry
 
 
-instance (a ~ b, Monad m) => Monoid (Kleisli m a b) where
-  mempty = Kleisli return
-
-instance (a ~ b, Monad m) => Semigroup (Kleisli m a b) where
-  Kleisli f <> Kleisli g = Kleisli $ f <=< g
-
-
 data Normal k = Normal
   { dAvg :: k
   , dRelDev :: Centi

messages/uniworx/de-de-formal.msg

@@ -720,6 +720,8 @@ RatingTime: Korrigiert
 RatingComment: Kommentar
 SubmissionUsers: Studenten
 Rating: Korrektur
+IsRated: Korrigiert
+SheetTypeIsExam: Anrechnung „als Prüfungsaufgabe“
 RatingPoints: Punkte
 RatingDone: Bewertung abgeschlossen
 RatingDoneTip: Das Korrekturergebnis ist nur dann für die Abgebenden sichtbar und kann gegen etwaige Prüfungs-Bonuspunkte verrechnet werden, wenn die Bewertung abgeschlossen ist.
@@ -1126,9 +1128,10 @@ SheetGradingPassPoints': Bestehen nach Punkten
 SheetGradingPassBinary': Bestanden/Nicht bestanden
 SheetGradingPassAlways': Automatisch bestanden, sobald korrigiert
 
-SheetTypeBonus grading@SheetGrading: Bonus
+SheetTypeBonus: Bonus
-SheetTypeNormal grading@SheetGrading: Normal
+SheetTypeNormal: Normal
-SheetTypeInformational grading@SheetGrading: Ohne Anrechnung
+SheetTypeInformational: Ohne Anrechnung
+SheetTypeExamPartPoints: Als Prüfungsaufgabe
 SheetTypeNotGraded: Keine Korrektur
 SheetTypeInfoNormalLecturer: Normale Blätter werden zur Berechnung eines etwaigen Prüfungsbonus herangezogen. Der Bonus kann sowohl anhand der zu bestehenden Blätter als auch der erreichbaren Maximalpunktzahl automatisch oder manuell berechnet werden.
 SheetTypeInfoNotGraded: Keine Korrektur bedeutet, dass es gar kein Feedback gibt.
@@ -1138,6 +1141,11 @@ SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den errei
 SummaryTitle: Zusammenfassung über
 SheetGradingSummaryTitle intgr@Integer: #{intgr} #{pluralDE intgr "Blatt" "Blätter"}
 SubmissionGradingSummaryTitle intgr@Integer: #{intgr} #{pluralDE intgr "Abgabe" "Abgaben"}
+SheetTypeExamPartPointsWeightNegative: Gewichtung darf nicht negativ sein
+SheetTypeExamPartPointsWeight: Gewichtung
+SheetTypeExamPartPointsExamPartOption examn@ExamName examPartNumber@ExamPartNumber: #{examn} - Teil #{view _ExamPartNumber examPartNumber}
+SheetTypeInfoExamPartPoints: Bei diesem Übungsblatt erreichte Punkte werden direkt auf die Punktezahl eines Prüfungsteils angerechnet. Wenn die Anzahl von über Übungsblättern erreichbaren Punkten nicht der Maximalpunktzahl des Prüfungsteils entspricht, werden die Übungsblattpunkte anhand der angegebenen Gewichtung skaliert.
+SheetTypeExamPartPointsExamPart: Prüfungsteil
 
 SheetTypeBonus': Bonus
 SheetTypeNormal': Normal
@@ -1998,6 +2006,10 @@ ExamPartMaxPoints: Maximalpunktzahl
 ExamPartWeight: Gewichtung
 ExamPartWeightTip: Wird vor Anzeige oder automatischen Notenberechnung mit der erreichten Punktzahl und der Maximalpunktzahl multipliziert; Änderungen hier passen also auch bestehende Korrekturergebnisse an (derart geänderte Noten müssen erneut manuell übernommen werden)
 ExamPartResultPoints: Erreichte Punkte
+ExamPartSheets: Übungsblätter
+
+ExamPartsFrom: Teile anzeigen ab
+ExamPartsFromTip: Ab dem gegebenen Zeitpunkt wird die Liste von Prüfungsteilen/Aufgaben veröffentlicht, nicht jedoch die jeweilige Maximalpunktzahl. Ohne Zeitpunkt wird die Liste ab "Ergebnisse sichtbar ab" angezeigt.
 
 ExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam}
 ExamCreated exam@ExamName: #{exam} erfolgreich angelegt
@@ -2035,6 +2047,7 @@ ExamRegistrationMustFollowSchoolSeparationFromStart dayCount@Int: Nach Regeln de
 ExamRegistrationMustFollowSchoolDuration dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Anmeldung bis" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen.
 ExamModeRequiredForRegistration: Nach Regeln des Institus muss die "Ausgestaltung der Prüfung" vollständig angegeben sein, bevor "Anmeldung ab" festgelegt werden kann.
 ExamModeSchoolDiscouraged: Nach Regeln des Instituts wird von der angegebenen "Ausgestaltung der Prüfung" abgeraten
+ExamPartsFromMustBeBeforeFinished: "Teile anzeigen ab" muss vor "Ergebnisse sichtbar ab" liegen
 
 ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen
 ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Prüfung liegen
@@ -2043,6 +2056,7 @@ ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRan
 ExamOccurrenceDuplicateName eoName@ExamOccurrenceName: Interne Terminbezeichnung #{eoName} kommt mehrfach vor
 ExamOccurrenceCannotBeDeletedDueToRegistrations eoName@ExamOccurrenceName: Termin #{eoName} kann nicht gelöscht werden, da noch Teilnehmer diesem Termin zugewiesen sind. Über die Liste von Prüfungsteilnehmern können Sie zunächst die entsprechenden Terminzuweisungen entfernen.
 ExamPartCannotBeDeletedDueToResults exampartnum@ExamPartNumber: Teil #{exampartnum} kann nicht gelöscht werden, da bereits Prüfungsergebnisse für diesen Teil eingetragen wurden.
+ExamPartCannotBeDeletedDueToSheetReference exampartnum@ExamPartNumber sheetName@SheetName: Teil #{exampartnum} kann nicht gelöscht werden, da Übungsblatt #{sheetName} den Bewertungsmodus „als Prüfungsaufgabe“ trägt.
 
 VersionHistory: Versionsgeschichte
 KnownBugs: Bekannte Bugs
@@ -2056,6 +2070,7 @@ ExamUserAssignOccurrence: Termin/Raum zuweisen
 ExamUserAcceptComputedResult: Berechnetes Prüfungsergebnis übernehmen
 ExamUserResetToComputedResult: Prüfungsergebnis zurücksetzen
 ExamUserResetBonus: Auch Bonuspunkte zurücksetzen
+ExamUserResetParts: Auch Teilergebnisse zurücksetzen
 ExamUserSetPartResult: Teilergebnis setzen
 ExamUserSetBonus: Bonuspunkte setzen
 ExamUserSetResult: Prüfungsergebnis setzen

messages/uniworx/en-eu.msg

@@ -717,6 +717,8 @@ RatingTime: Marked
 RatingComment: Comment
 SubmissionUsers: Submittors
 Rating: Marking
+IsRated: Marked
+SheetTypeIsExam: Rating „as an exam part“
 RatingPoints: Points
 RatingDone: Rating finished
 RatingDoneTip: The rating is only visible to the submittors and considered for any exam bonuses if it is finished.
@@ -1127,9 +1129,10 @@ SheetGradingPassPoints': Passing by points
 SheetGradingPassBinary': Pass/Fail
 SheetGradingPassAlways': Automatically passed when corrected
 
-SheetTypeBonus grading: Bonus
+SheetTypeBonus: Bonus
-SheetTypeNormal grading: Normal
+SheetTypeNormal: Normal
-SheetTypeInformational grading: Informational
+SheetTypeInformational: Informational
+SheetTypeExamPartPoints: As an exam part
 SheetTypeNotGraded: Not marked
 SheetTypeInfoNormalLecturer: Normal sheets are used to calculate exam bonuses. Bonuses may be calculated from the number of sheets that can be passed or the maximum number of points achievable either manually or automatically.
 SheetTypeInfoNotGraded: "Not marked" means that there will be no feedback at all.
@@ -1139,6 +1142,11 @@ SheetGradingBonusIncluded: Achieved bonus points are already counted among the a
 SummaryTitle: Summary of
 SheetGradingSummaryTitle intgr: #{intgr} #{pluralEN intgr "sheet" "sheets"}
 SubmissionGradingSummaryTitle intgr: #{intgr} #{pluralEN intgr "submission" "submissions"}
+SheetTypeExamPartPointsWeightNegative: Weight may not be negative
+SheetTypeExamPartPointsWeight: Weight
+SheetTypeExamPartPointsExamPartOption examn examPartNumber: #{examn} - Part #{view _ExamPartNumber examPartNumber}
+SheetTypeInfoExamPartPoints: Points achieved in this exercise sheet will be directly applied to the result of an exam part. If the number of points achievable via exercise sheets for an exam part does not match the maximum number of points of that exam part, the points achieved via exercise sheets will be scaled according to their weight.
+SheetTypeExamPartPointsExamPart: Exam part
 
 SheetTypeBonus': Bonus
 SheetTypeNormal': Normal
@@ -1997,6 +2005,10 @@ ExamPartMaxPoints: Maximum points
 ExamPartWeight: Weight
 ExamPartWeightTip: Will be multiplied with the achieved number of points before they are shown to the participant or used in automatic grade computation. Thus this also affects existing exam results (changed exam achievements have to be accepted manually again)
 ExamPartResultPoints: Achieved points
+ExamPartSheets: Exercise sheets
+
+ExamPartsFrom: Parts visible from
+ExamPartsFromTip: At this time the list of exam parts/questions will be published, but without their respective maximum number of points. If left empty the list will be published with “Results visible from”
 
 ExamNameTaken exam: There already is an exam named #{exam}
 ExamCreated exam: Successfully created #{exam}
@@ -2034,6 +2046,7 @@ ExamRegistrationMustFollowSchoolSeparationFromStart dayCount: As per school rule
 ExamRegistrationMustFollowSchoolDuration dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Register to".
 ExamModeRequiredForRegistration: As per school rules "Exam design" needs to be fully specified before "Register from" may be set.
 ExamModeSchoolDiscouraged: As per school rules the specified "Exam design" is discouraged
+ExamPartsFromMustBeBeforeFinished: “Parts visible from” must be before “Results visible from”
 
 ExamOccurrenceEndMustBeAfterStart eoName: End of the occurrence #{eoName} must be after it's start
 ExamOccurrenceStartMustBeAfterExamStart eoName: Start of the occurrence #{eoName} must be after the exam start
@@ -2042,6 +2055,7 @@ ExamOccurrenceDuplicate eoRoom eoRange: Combination of room #{eoRoom} and occurr
 ExamOccurrenceDuplicateName eoName: Internal name #{eoName} occurs multiple times
 ExamOccurrenceCannotBeDeletedDueToRegistrations eoName: Occurrence #{eoName} cannot be deleted because participants are registered for it. You can remove the offending registrations via the list of exam participants.
 ExamPartCannotBeDeletedDueToResults exampartnum: Part #{exampartnum} cannot be deleted because some exam part results were already entered for it.
+ExamPartCannotBeDeletedDueToSheetReference exampartnum sheetName: Part #{exampartnum} cannot be deleted, since exercise sheet #{sheetName} is configured “as an exam part”.
 
 VersionHistory: Version history
 KnownBugs: Known bugs
@@ -2055,6 +2069,7 @@ ExamUserAssignOccurrence: Assign occurrence/room
 ExamUserAcceptComputedResult: Accept computed result
 ExamUserResetToComputedResult: Reset result
 ExamUserResetBonus: Also reset exam bonus
+ExamUserResetParts: Also reset exam part results
 ExamUserSetPartResult: Set exam part result
 ExamUserSetBonus: Set exam bonus
 ExamUserSetResult: Set exam result

models/exams.model

@@ -19,6 +19,7 @@ Exam
   description StoredMarkup Maybe
   examMode ExamMode
   staff Text Maybe
+  partsFrom UTCTime Maybe
   UniqueExam course name
 ExamPart
   exam ExamId
@@ -28,6 +29,7 @@ ExamPart
   weight Rational
   UniqueExamPartNumber exam number
   UniqueExamPartName exam name !force
+  deriving Read Show Eq Ord Generic Typeable
 ExamOccurrence
   exam ExamId
   name ExamOccurrenceName

models/sheets.model

@@ -2,7 +2,7 @@ Sheet   -- exercise sheet for a given course
     course          CourseId
     name            (CI Text)
     description     StoredMarkup Maybe
-    type            SheetType        -- Does it count towards overall course grade?
+    type            (SheetType SqlBackendKey) -- ExamPartId; Does it count towards overall course grade?
     grouping        SheetGroup       -- May participants submit in groups of certain sizes?
     markingText     StoredMarkup Maybe -- Instructons for correctors, included in marking templates
     visibleFrom     UTCTime Maybe    -- Invisible to enrolled participants before

src/Control/Arrow/Instances.hs

@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Control.Arrow.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Control.Arrow
+
+
+instance (a ~ b, Monad m) => Monoid (Kleisli m a b) where
+  mempty = Kleisli return
+
+instance (a ~ b, Monad m) => Semigroup (Kleisli m a b) where
+  Kleisli f <> Kleisli g = Kleisli $ f <=< g

src/Database/Persist/Types/Instances.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Database.Persist.Types.Instances
@@ -22,3 +23,6 @@ deriving instance Typeable PersistValue
 instance Hashable PersistValue
 instance Binary PersistValue
 instance NFData PersistValue
+
+instance (NFData record, NFData (Key record)) => NFData (Entity record) where
+  rnf Entity{..} = rnf entityKey `seq` rnf entityVal

src/Foundation/I18n.hs

@@ -8,7 +8,7 @@ module Foundation.I18n
   , MsgLanguage(..)
   , ShortSex(..)
   , ShortWeekDay(..)
-  , SheetTypeHeader(..)
+  , SheetType'(..), classifySheetType
   , SheetArchiveFileTypeDirectory(..)
   , ShortStudyDegree(..)
   , ShortStudyTerms(..)
@@ -248,22 +248,27 @@ embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials"
 newtype ShortSex = ShortSex Sex
 embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)
 
-newtype SheetTypeHeader = SheetTypeHeader SheetType
+data SheetType'
-embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
+  = NotGraded' | Normal' | Bonus' | Informational' | ExamPartPoints'
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving (Universe, Finite)
+
+classifySheetType :: SheetType a -> SheetType'
+classifySheetType = \case
+  NotGraded        -> NotGraded'
+  Normal{}         -> Normal'
+  Bonus{}          -> Bonus'
+  Informational{}  -> Informational'
+  ExamPartPoints{} -> ExamPartPoints'
+
+nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
+embedRenderMessage ''UniWorX ''SheetType' $ ("SheetType" <>) . fromMaybe (error "Expected SheetType' to have '") . stripSuffix "'"
 
 newtype SheetArchiveFileTypeDirectory = SheetArchiveFileTypeDirectory SheetFileType
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
   deriving newtype (Enum, Bounded, Universe, Finite)
 embedRenderMessageVariant ''UniWorX ''SheetArchiveFileTypeDirectory $ ("SheetArchiveFileTypeDirectory" <>) . concat . drop 1 . splitCamel
 
-instance RenderMessage UniWorX SheetType where
-  renderMessage foundation ls sheetType = case sheetType of
-      NotGraded -> mr $ SheetTypeHeader NotGraded
-      other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
-    where
-      mr :: RenderMessage UniWorX msg => msg -> Text
-      mr = renderMessage foundation ls
-
 instance RenderMessage UniWorX StudyDegree where
   renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
 

src/Handler/Course/Users.hs

@@ -85,7 +85,7 @@ type UserTableData = DBRow ( Entity User
                            , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
                            , [Entity Exam]
                            , Maybe (Entity SubmissionGroup)
-                           , Map SheetName (SheetType, Maybe Points)
+                           , Map SheetName (SheetType SqlBackendKey, Maybe Points)
                            , UserTableStudyFeatures
                            )
 
@@ -113,7 +113,7 @@ _userExams = _dbrOutput . _5
 _userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup)
 _userSubmissionGroup = _dbrOutput . _6 . _Just
 
-_userSheets :: Lens' UserTableData (Map SheetName (SheetType, Maybe Points))
+_userSheets :: Lens' UserTableData (Map SheetName (SheetType SqlBackendKey, Maybe Points))
 _userSheets = _dbrOutput . _7
 
 _userStudyFeatures :: Lens' UserTableData UserTableStudyFeatures
@@ -160,7 +160,7 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
                       ]
 
     userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
-    userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) . views (_userSheets . at shn) $ \case
+    userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) $ \dat -> flip (views $ _userSheets . at shn) dat $ \case
       Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgAchievedOf points maxPoints
       Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed $ Just True == gradingPassed grading' points
       _other -> mempty
@@ -177,7 +177,7 @@ data UserTableCsv = UserTableCsv
   , csvUserNote :: Maybe StoredMarkup
   , csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName))
   , csvUserExams :: [ExamName]
-  , csvUserSheets :: Map SheetName (SheetType, Maybe Points)
+  , csvUserSheets :: Map SheetName (SheetType (), Maybe Points)
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 makeLenses_ ''UserTableCsv
 
@@ -470,7 +470,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
                   <*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials)
                   -- <*> (over (_2.traverse._Just) (examName . entityVal) . over (_1.traverse) (examName . entityVal) <$> view _userExams)
                   <*> (over traverse (examName . entityVal) <$> view _userExams)
-                  <*> view _userSheets
+                  <*> views _userSheets (set (mapped . _1 . mapped) ())
             , dbtCsvName = unpack csvName
             , dbtCsvNoExportData = Nothing
             , dbtCsvHeader = return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def

src/Handler/Exam/Edit.hs

@@ -48,6 +48,7 @@ postEEditR tid ssh csh examn = do
         , examDescription      = efDescription
         , examExamMode         = efExamMode
         , examStaff            = efStaff
+        , examPartsFrom        = efPartsFrom
         }
 
       when (is _Nothing insertRes) $ do

src/Handler/Exam/Form.hs

@@ -26,6 +26,8 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)
 
 import qualified Data.Text.Lazy as LT
 
+import qualified Data.Conduit.Combinators as C
+
 
 data ExamForm = ExamForm
   { efName :: ExamName
@@ -37,6 +39,7 @@ data ExamForm = ExamForm
   , efRegisterTo :: Maybe UTCTime
   , efDeregisterUntil :: Maybe UTCTime
   , efPublishOccurrenceAssignments :: Maybe UTCTime
+  , efPartsFrom :: Maybe UTCTime
   , efFinished :: Maybe UTCTime
   , efOccurrences :: Set ExamOccurrenceForm
   , efPublicStatistics :: Bool
@@ -121,6 +124,7 @@ examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do
     <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template)
     <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
     <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
+    <*> aopt utcTimeField (fslpI MsgExamPartsFrom (mr MsgDate) & setTooltip MsgExamPartsFromTip) (efPartsFrom <$> template)
     <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip (bool MsgExamFinishedTip MsgExamFinishedTipCloseOnFinished $ is _ExamCloseOnFinished' schoolExamCloseMode)) (efFinished <$> template)
     <*  aformSection MsgExamFormOccurrences
     <*> examOccurrenceForm (efOccurrences <$> template)
@@ -322,6 +326,7 @@ examFormTemplate (Entity eId Exam{..}) = do
     , efRegisterTo       = examRegisterTo
     , efDeregisterUntil  = examDeregisterUntil
     , efPublishOccurrenceAssignments = examPublishOccurrenceAssignments
+    , efPartsFrom        = examPartsFrom
     , efStart            = examStart
     , efEnd              = examEnd
     , efFinished         = examFinished
@@ -397,6 +402,7 @@ examTemplate cid = runMaybeT $ do
     , efRegisterTo       = dateOffset <$> examRegisterTo oldExam
     , efDeregisterUntil  = dateOffset <$> examDeregisterUntil oldExam
     , efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam
+    , efPartsFrom        = dateOffset <$> examPartsFrom oldExam
     , efStart            = dateOffset <$> examStart oldExam
     , efEnd              = dateOffset <$> examEnd oldExam
     , efFinished         = dateOffset <$> examFinished oldExam
@@ -425,9 +431,10 @@ validateExam cId oldExam = do
   guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom            $ NTop efDeregisterUntil              >= NTop efRegisterFrom
   guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments      $ Just False /= ((>=) <$> efStart <*> efPublishOccurrenceAssignments)
   guardValidation MsgExamEndMustBeAfterStart                               $ NTop efEnd                          >= NTop efStart
-  guardValidation MsgExamFinishedMustBeAfterEnd   $ Just False /= ((>=) <$> efFinished <*> efEnd)
+  guardValidation MsgExamFinishedMustBeAfterEnd                            $ Just False /= ((>=) <$> efFinished <*> efEnd)
-  guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
+  guardValidation MsgExamFinishedMustBeAfterStart                          $ Just False /= ((>=) <$> efFinished <*> efStart)
-
+  guardValidation MsgExamPartsFromMustBeBeforeFinished                     $ NTop efFinished                     >= NTop efPartsFrom
+                                                                          || is _Nothing efPartsFrom
 
   forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
     guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName)       $ NTop eofEnd >= NTop (Just eofStart)
@@ -465,8 +472,11 @@ validateExam cId oldExam = do
     return ( examPart E.^. ExamPartId
            , examPart E.^. ExamPartNumber
            )
-  forM_ (join $ hoistMaybe oldPartsWithResults) $ \(E.Value epId, E.Value epNumber) ->
+  forM_ (join $ hoistMaybe oldPartsWithResults) $ \(E.Value epId, E.Value epNumber) -> do
     guardValidationM (MsgExamPartCannotBeDeletedDueToResults epNumber) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId
+    runConduit $ transPipe lift (selectSource [] [])
+              .| C.filter (has $ _entityVal . _sheetType . _examPart . re _SqlKey . only epId)
+              .| C.mapM_ (\(Entity _ Sheet{..}) -> guardValidationM (MsgExamPartCannotBeDeletedDueToSheetReference epNumber sheetName) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId)
 
 
   mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do

src/Handler/Exam/New.hs

@@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do
         , examDescription                  = efDescription
         , examExamMode                     = efExamMode
         , examStaff                        = efStaff
+        , examPartsFrom                    = efPartsFrom
         }
       whenIsJust insertRes $ \examid -> do
         insertMany_

src/Handler/Exam/Show.hs

@@ -26,24 +26,34 @@ getEShowR tid ssh csh examn = do
   cTime <- liftIO getCurrentTime
   mUid <- maybeAuthId
 
-  (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools) <- runDB $ do
+  (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools, (partsVisible, partsShown)) <- runDB $ do
     exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
     school <- getJust examCourse >>= belongsToJust courseSchool
 
+    lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
+
     let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
 
     let gradingVisible = NTop (Just cTime) >= NTop examFinished
-    gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
+        gradingShown = gradingVisible || lecturerInfoShown
+
+    let partsVisible = gradingVisible
+                    || NTop (Just cTime) >= NTop examPartsFrom
+        partsShown = partsVisible || lecturerInfoShown
 
     let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments || examOccurrenceRule == ExamRoomFifo
-    occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
+        occurrenceAssignmentsShown = occurrenceAssignmentsVisible || lecturerInfoShown
 
-    examParts <- sortOn (view $ _entityVal . _examPartNumber) <$> selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
+    sheets <- selectList [ SheetCourse ==. examCourse ] [] 
+    let examPartSheets epId = do
+          let sheets' = flip filter sheets $ \(Entity _ Sheet{..}) -> has (_examPart . re _SqlKey . only epId) sheetType
+          flip filterM sheets' $ \(Entity _ Sheet{..}) -> hasReadAccessTo $ CSheetR tid ssh csh sheetName SShowR
+    examParts <- fmap (sortOn . view $ _1 . _entityVal . _examPartNumber) $ selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] >>= traverse (\ep@(Entity epId _) -> (ep,,) <$> encrypt @ExamPartId @UUID epId <*> examPartSheets epId)
 
     resultsRaw <- for mUid $ \uid ->
       E.select . E.from $ \examPartResult -> do
         E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
-             E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey examParts)
+             E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map (views _1 entityKey) examParts)
         return examPartResult
     let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
 
@@ -83,8 +93,6 @@ getEShowR tid ssh csh examn = do
             sortPred (Entity _ ExamOccurrence{..}, registered', _, showRoom)
               = (Down $ registered' && not mayRegister, examOccurrenceStart, guardOn @Maybe showRoom examOccurrenceRoom)
 
-    lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
-
     staffInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EGradesR
 
     extraSchools <- E.select . E.from $ \(school' `E.InnerJoin` examOfficeSchool) -> do
@@ -92,7 +100,7 @@ getEShowR tid ssh csh examn = do
       E.where_ $ examOfficeSchool E.^. ExamOfficeSchoolExam E.==. E.val eId
       return school'
 
-    return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools)
+    return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools, (partsVisible, partsShown))
 
   let occurrenceNamesShown = lecturerInfoShown
       partNumbersShown = lecturerInfoShown
@@ -102,7 +110,7 @@ getEShowR tid ssh csh examn = do
       showRegisteredCount = lecturerInfoShown
       examFinishedMsg = if lecturerInfoShown then MsgExamFinished else MsgExamFinishedParticipant
 
-      sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, mPoints <- examPartMaxPoints ^.. _Just ]
+      sumMaxPoints = sum [ fromRational examPartWeight * mPoints | (Entity _ ExamPart{..}, _, _) <- examParts, mPoints <- examPartMaxPoints ^.. _Just ]
 
       sumRegisteredCount = sumOf (folded . _3) occurrences
 
@@ -175,8 +183,9 @@ getEShowR tid ssh csh examn = do
             |]
         | otherwise = Nothing
 
-      showMaxPoints = any (has $ _entityVal . _examPartMaxPoints . _Just) examParts
+      showMaxPoints = gradingShown && any (has $ _1 . _entityVal . _examPartMaxPoints . _Just) examParts
-      showAchievedPoints = not $ null results
+      showAchievedPoints = gradingShown && not (null results)
+      showPartSheets = any (has $ _3 . folded) examParts
       showOccurrenceRegisterColumn = occurrenceAssignmentsShown || (mayRegister && examOccurrenceRule == ExamRoomFifo)
       markUnregisteredOccurrences mOcc = occurrenceAssignmentsShown && hasRegistration && isn't _Just (registerWidget mOcc)
       showOccurrenceMappingColumn = examOccurrenceRuleAutomatic examOccurrenceRule && occurrenceAssignmentsShown && is _Just examExamOccurrenceMapping

src/Handler/Exam/Users.hs

@@ -135,8 +135,8 @@ resultExamParts = _dbrOutput . _6 . itraversed
 resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult))
 resultExamPartResult epId = _dbrOutput . _6 . unsafeSingular (ix epId) . _2
 
-resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
+-- resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
-resultExamPartResults = resultExamParts <. _2
+-- resultExamPartResults = resultExamParts <. _2
 
 resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
 resultCourseNote = _dbrOutput . _7 . _Just
@@ -145,16 +145,24 @@ resultStudyFeatures :: Lens' ExamUserTableData UserTableStudyFeatures
 resultStudyFeatures = _dbrOutput . _8
 
 
-resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points
+resultAutomaticExamBonus :: Ord epId => Exam -> Map UserId (SheetTypeSummary epId) -> Fold ExamUserTableData Points
 resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> join $ examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus'))
 
-resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultPassedGrade
+resultAutomaticExamResult :: Exam -> Map UserId (SheetTypeSummary ExamPartId) -> Fold ExamUserTableData ExamResultPassedGrade
 resultAutomaticExamResult exam@Exam{..} examBonus' = folding . runReader $ do
-  parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult))
+  parts' <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> runMaybeT $ hoistMaybe (mRes ^? _Just . _entityVal . _examPartResultResult)
+                                                                                      <|> MaybeT (preview $ resultAutomaticExamPartResult (Entity epId ep) examBonus')
+                                                      )
   bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus'
-  let gradeRes = examGrade exam bonus =<< parts'
+  let gradeRes = examGrade exam bonus =<< sequence parts'
   return $ fmap (bool Right (Left . view passingGrade) $ is _ExamGradingPass examGradingMode) <$> gradeRes
 
+resultAutomaticExamPartResult :: Entity ExamPart -> Map UserId (SheetTypeSummary ExamPartId) -> Fold ExamUserTableData ExamResultPoints
+resultAutomaticExamPartResult epEnt examBonus' = folding . runReader . runMaybeT $ do
+  uid <- view $ resultUser . _entityKey
+  summary <- hoistMaybe $ Map.lookup uid examBonus'
+  hoistMaybe $ sheetExamResult summary epEnt
+
 
 csvExamPartHeader :: Prism' Csv.Name ExamPartNumber
 csvExamPartHeader = prism' toHeader fromHeader
@@ -294,7 +302,8 @@ data ExamUserActionData = ExamUserDeregisterData
                         | ExamUserSetResultData (Maybe ExamResultPassedGrade)
                         | ExamUserAcceptComputedResultData
                         | ExamUserResetToComputedResultData
-                          { examUserResetBonus :: Bool
+                          { examUserResetBonus
+                          , examUserResetParts :: Bool
                           }
 
 
@@ -479,8 +488,8 @@ postEUsersR tid ssh csh examn = do
                  in propCell (getSum achievedPoints) (getSum sumSheetsPoints)
             , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left
             , pure $ mconcat
-              [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
+              [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) . automaticCell $ resultExamPartResult epId . _Just . _entityVal . _examPartResultResult . to Right <> resultAutomaticExamPartResult epEnt bonus . to Left
-              | Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
+              | epEnt@(Entity epId ExamPart{..}) <- sortOn (examPartNumber . entityVal) examParts
               ]
             , 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))
@@ -548,6 +557,7 @@ postEUsersR tid ssh csh examn = do
                     , singletonMap ExamUserResetToComputedResult $
                         ExamUserResetToComputedResultData
                           <$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule)
+                          <*> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetParts) (Just True)) (not $ all (null . examSummary) bonus)
                     , singletonMap ExamUserSetPartResult $
                         ExamUserSetPartResultData
                           <$> areq (selectField $ optionsPairs (map ((MsgExamPartNumbered &&& id) . examPartNumber . entityVal) examParts)) (fslI MsgExamPart) Nothing
@@ -601,9 +611,11 @@ postEUsersR tid ssh csh examn = do
                 <*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped)
                 <*> fmap (bool (const Nothing) Just showPasses) (preview $ resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral)
                 <*> fmap (bool (const Nothing) Just doBonus   ) (preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus')
-                <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts))
+                <*> encodePartResults
                 <*> preview (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
                 <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
+              encodePartResults = fmap Map.fromList . forM examParts $ \epEnt@(Entity epId ExamPart{..}) -> (examPartNumber, ) <$>
+                preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult <> resultAutomaticExamPartResult epEnt bonus)
           dbtCsvDecode = Just DBTCsvDecode
             { dbtCsvRowKey = \csv -> do
                 uid <- lift $ view _2 <$> guessUser' csv
@@ -964,6 +976,7 @@ postEUsersR tid ssh csh examn = do
         hasBonus <- asks $ has resultExamBonus
         autoResult <- preview $ resultAutomaticExamResult examVal bonus
         autoBonus <- preview $ resultAutomaticExamBonus examVal bonus
+        autoParts <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> fmap (guardOnM (isn't _Just mRes) . fmap (epId, )) . preview $ resultAutomaticExamPartResult (Entity epId ep) bonus)
         lift $ if
           | not hasResult
           , Just examResultResult <- autoResult
@@ -982,6 +995,15 @@ postEUsersR tid ssh csh examn = do
                 | otherwise
                 -> return ()
 
+              iforM_ (Map.fromList $ catMaybes autoParts) $ \epId autoPartResult -> do
+                insert_ ExamPartResult
+                  { examPartResultExamPart = epId
+                  , examPartResultUser = uid
+                  , examPartResultResult = autoPartResult
+                  , examPartResultLastChanged = now
+                  }
+                audit $ TransactionExamPartResultEdit epId uid
+
               insert_ ExamResult
                 { examResultExam = eId
                 , examResultUser = uid
@@ -1003,6 +1025,12 @@ postEUsersR tid ssh csh examn = do
             whenIsJust bonusId' $ \bonusId -> do
                 delete bonusId
                 audit $ TransactionExamBonusDeleted eId uid
+          when examUserResetParts $ do
+            forM_ (foldMap (Map.keysSet . unMergeMap . examSummary) $ Map.lookup uid bonus) $ \epId -> do
+              partResultId' <- getKeyBy $ UniqueExamPartResult epId uid
+              whenIsJust partResultId' $ \partResultId -> do
+                delete partResultId
+                audit $ TransactionExamPartResultDeleted epId uid
 
           result <- getKeyBy $ UniqueExamResult eId uid
           case result of

src/Handler/Sheet/Edit.hs

@@ -33,7 +33,7 @@ postSEditR tid ssh csh shn = do
   let template = Just $ SheetForm
         { sfName           = sheetName
         , sfDescription    = sheetDescription
-        , sfType           = sheetType
+        , sfType           = review _SqlKey <$> sheetType
         , sfGrouping       = sheetGrouping
         , sfVisibleFrom    = sheetVisibleFrom
         , sfActiveFrom     = sheetActiveFrom
@@ -74,7 +74,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               { sheetCourse         = cid
               , sheetName           = sfName
               , sheetDescription    = sfDescription
-              , sheetType           = sfType
+              , sheetType           = view _SqlKey <$> sfType
               , sheetGrouping       = sfGrouping
               , sheetMarkingText    = sfMarkingText
               , sheetVisibleFrom    = sfVisibleFrom

src/Handler/Sheet/Form.hs

@@ -37,7 +37,7 @@ data SheetForm = SheetForm
       , sfSolutionFrom :: Maybe UTCTime
       , sfSubmissionMode :: SubmissionMode
       , sfGrouping     :: SheetGroup
-      , sfType         :: SheetType
+      , sfType         :: SheetType ExamPartId
       , sfAutoDistribute :: Bool
       , sfMarkingText  :: Maybe StoredMarkup
       , sfAnonymousCorrection :: Bool
@@ -93,7 +93,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
       <* aformSection MsgSheetFormType
       <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction False))
       <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        ((sfGrouping <$> template) <|> pure NoGroups)
-      <*> sheetTypeAFormReq   (fslI MsgSheetType)         (sfType        <$> template)
+      <*> sheetTypeAFormReq cId (fslI MsgSheetType) (sfType <$> template)
       <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
       <*> aopt htmlField    (fslI MsgSheetMarking) (sfMarkingText <$> template)
       <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)

src/Handler/Sheet/List.hs

@@ -9,6 +9,7 @@ import Handler.Utils
 import Handler.Utils.SheetType
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 
 import qualified Data.Map as Map
 
@@ -38,6 +39,9 @@ getSheetListR tid ssh csh = do
         E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
       E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
 
+    querySubmission :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` E.SqlExpr (Maybe (Entity SubmissionUser))) -> E.SqlExpr (Maybe (Entity Submission))
+    querySubmission (_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) = submission
+
     sheetFilter :: SheetName -> DB Bool
     sheetFilter sheetName = hasReadAccessTo $ CSheetR tid ssh csh sheetName SShowR
 
@@ -64,8 +68,10 @@ getSheetListR tid ssh csh = do
           $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveFrom
       , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
           $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveTo
-      , sortable Nothing (i18nCell MsgSheetType)
+      , sortable Nothing (i18nCell MsgSheetType) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> cell $ do
-          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType
+          sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
+          tr <- getTranslate
+          toWidget $ sheetTypeDesc tr
       , sortable Nothing (i18nCell MsgSubmission)
           $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of
               Nothing -> mempty
@@ -86,7 +92,6 @@ getSheetListR tid ssh csh = do
                     mkRoute = liftHandler $ do
                       cid' <- encrypt sid
                       return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
-                    mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
                     acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
                     tellStats = do
                       r <- mkRoute
@@ -154,10 +159,17 @@ getSheetListR tid ssh csh = do
       , dbtFilter    = mconcat
         [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
             let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
-             in (==b) <$> sheetFilter sheetName :: DB Bool
+             in (== b) <$> sheetFilter sheetName :: DB Bool
+        , singletonMap "rated" . FilterColumn $ \(Any b) -> (E.==. E.val b) . E.isJust . (E.?. SubmissionRatingTime) . querySubmission
+        , singletonMap "is-exam" . FilterProjected $ \(Any b) DBRow{..} ->
+            let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
+             in return $ is _ExamPartPoints sheetType == b :: DB Bool
         ]
-      , dbtFilterUI  = mempty
+      , dbtFilterUI  = mconcat
-      , dbtStyle     = def
+        [ flip (prismAForm $ singletonFilter "is-exam" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgSheetTypeIsExam)
+        , flip (prismAForm $ singletonFilter "rated" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgIsRated)
+        ]
+      , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = def
       , dbtIdent     = "sheets" :: Text
       , dbtCsvEncode = noCsvEncode

src/Handler/Sheet/New.hs

@@ -48,7 +48,7 @@ postSheetNewR tid ssh csh = do
           in Just $ SheetForm
             { sfName           = stepTextCounterCI sheetName
             , sfDescription    = sheetDescription
-            , sfType           = sheetType
+            , sfType           = review _SqlKey <$> sheetType
             , sfGrouping       = sheetGrouping
             , sfVisibleFrom    = addTime <$> sheetVisibleFrom
             , sfActiveFrom     = addTime <$> sheetActiveFrom

src/Handler/Sheet/Show.hs

@@ -150,6 +150,8 @@ getSShowR tid ssh csh shn = do
     guardM . hasWriteAccessTo $ CSheetR tid ssh csh shn SEditR
     return $ notification NotificationBroad =<< messageI Warning MsgSheetSubmissionModeNoneWithoutNotGraded
 
+  sTypeDesc <- runDB $ sheetTypeDescription (sheetCourse sheet) (sheetType sheet)
+
   defaultLayout $ do
     setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
     let zipLink = CSheetR tid ssh csh shn SArchiveR
@@ -161,4 +163,5 @@ getSShowR tid ssh csh shn = do
     solutionFrom  <- traverse (formatTime SelFormatDateTime) $  sheetSolutionFrom sheet
     markingText   <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
     submissionTip <- messageI Info MsgSheetCorrectorSubmissionsTip
+    tr <- getTranslate
     $(widgetFile "sheetShow")

src/Handler/Submission/Correction.hs

@@ -49,8 +49,11 @@ postCorrectionR tid ssh csh shn cid = do
     <*> hasWriteAccessTo (CSheetR tid ssh csh shn SSubsR)
 
   MsgRenderer mr <- getMsgRenderer
+  ur <- getUrlRenderParams
+  tr <- getTranslate
   case results of
     [(Entity cId Course{}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
+      sheetTypeDesc <- runDB $ sheetTypeDescription cId sheetType
       let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip
           pointsForm = case sheetType of
             NotGraded
@@ -59,10 +62,10 @@ postCorrectionR tid ssh csh shn cid = do
               -> Just <$> apopt (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) submissionRatingPoints
             (preview _grading -> Just PassAlways)
               -> Just <$> aforced (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) 1
-            _otherwise
+            _otherwise -> aSetTooltip (Just $ sheetTypeDesc tr ur) $
-              -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
+              aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
-                      (fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType)
+                   (fslpI MsgRatingPoints (mr MsgPointsPlaceholder))
-                      (Just submissionRatingPoints)
+                   (Just submissionRatingPoints)
           correctorForm
             | not isLecturer = wFormToAForm $ pure . Just <$> requireAuthId
             | otherwise = wFormToAForm $ do
@@ -142,6 +145,7 @@ postCorrectionR tid ssh csh shn cid = do
               $if not (submissionRatingDone subm)
                 \ ^{isVisibleWidget False}
             |]
+            
       siteLayout headingWgt $ do
         setTitleI heading
         urlArchive <- toTextUrl . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected
@@ -154,9 +158,13 @@ getCorrectionUserR tid ssh csh shn cid = do
   results <- runDB $ correctionData tid ssh csh shn sub
 
   case results of
-    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _), E.Value filesCorrected)] ->
+    [(_, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _), E.Value filesCorrected)] -> do
       let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
-       in defaultLayout $ do
+      let heading = MsgCorrectionHead tid ssh csh shn cid
-            urlArchive <- toTextUrl . CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected
+      urlArchive <- toTextUrl . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected
-            $(widgetFile "correction-user")
+      tr <- getTranslate
+      sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
+      siteLayoutMsg heading $ do
+        setTitleI heading
+        $(widgetFile "correction-user")
     _ -> notFound

src/Handler/Submission/Helper.hs

@@ -548,12 +548,14 @@ submissionHelper tid ssh csh shn mcid = do
     E.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. E.val subId
     E.where_ $ sFile2 E.?. SubmissionFileSubmission E.==. E.just (E.val subId)
 
+  sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
 
   defaultLayout $ do
     setTitleI $ MsgSubmissionEditHead tid ssh csh shn
     (urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID
       -> let mkUrl sft = toTextUrl . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft
           in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal
+    tr <- getTranslate
     let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) ->
           let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
            in $(widgetFile "correction-user")

src/Handler/Submission/List.hs

@@ -118,7 +118,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgSubmission)
               shn = sheetName $ entityVal sheet
           in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn cid SubShowR) (toPathPiece cid)
 
-colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
+colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId))
 colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid
 
 colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
@@ -150,7 +150,7 @@ colSGroups = sortable (Just "submittors-group") (i18nCell MsgSubmissionGroup) $
         | otherwise
           -> mempty
 
-colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary))
+colRating :: forall m a. IsDBTable m (a, SheetTypeSummary SqlBackendKey) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary SqlBackendKey))
 colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _, _, _) } ->
   let csh = course ^. _2
       tid = course ^. _3
@@ -160,14 +160,13 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
       mkRoute = do
         cid <- encrypt subId
         return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
-      mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
   in mconcat
      [ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating")
      , writerCell $ do
          let
-           summary :: SheetTypeSummary
+           summary :: SheetTypeSummary SqlBackendKey
            summary = sheetTypeSum sheetType $ submissionRatingPoints <* guard (submissionRatingDone sub)
-         scribe (_2 :: Lens' (a, SheetTypeSummary) SheetTypeSummary) summary
+         scribe (_2 :: Lens' (a, SheetTypeSummary SqlBackendKey) (SheetTypeSummary SqlBackendKey)) summary
      ]
 
 colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
@@ -198,7 +197,10 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
   )
 
 colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
-colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType)
+colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{sheetCourse, sheetType}, _, _, _, _, _, _) } -> cell $ do
+  sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
+  tr <- getTranslate
+  toWidget $ sheetTypeDesc tr
 
 colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
 colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
@@ -434,7 +436,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
   
-correctionsR' :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary)
+correctionsR' :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey)
 correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
   currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
 

src/Handler/Utils/Exam.hs

@@ -54,6 +54,7 @@ import qualified Data.Char as Char
 import qualified Data.RFC5051 as RFC5051
 
 import Handler.Utils.I18n
+import Handler.Utils.Sheet
 
 
 fetchExamAux :: ( SqlBackendCanRead backend
@@ -90,7 +91,7 @@ fetchCourseIdExam  :: MonadHandler m => TermId -> SchoolId -> CourseShorthand ->
 fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn
 
 
-examBonus :: MonadHandler m => Entity Exam -> ReaderT SqlBackend m (Map UserId SheetTypeSummary)
+examBonus :: (MonadHandler m, MonadThrow m) => Entity Exam -> ReaderT SqlBackend m (Map UserId (SheetTypeSummary ExamPartId))
 examBonus (Entity eId Exam{..}) = runConduit $
   let
     rawData = E.selectSource . E.from $ \(((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` sheet) `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do
@@ -112,19 +113,20 @@ examBonus (Entity eId Exam{..}) = runConduit $
         ]
         ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
         )
-      return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission)
+      return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission, sheet E.^. SheetCourse)
-    accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) ->
+    accum = C.foldM ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub, E.Value cId) -> do
-      flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType $ assertM submissionRatingDone sub >>= submissionRatingPoints
+      sheetType' <- fmap entityKey <$> resolveSheetType cId sheetType
+      return . flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType' $ assertM submissionRatingDone sub >>= submissionRatingPoints
    in rawData .| accum
 
-examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> SheetGradeSummary
+examBonusPossible, examBonusAchieved :: Ord epId => UserId -> Map UserId (SheetTypeSummary epId) -> SheetGradeSummary
 examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap
 examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap
 
 getRelevantSheetsUpTo :: CourseId
                       -> UserId
                       -> Maybe UTCTime
-                      -> DB (Map SheetId (SheetType, Maybe Points))
+                      -> DB (Map SheetId (SheetType SqlBackendKey, Maybe Points))
 getRelevantSheetsUpTo cid uid mCutoff
   = fmap postprocess . E.select . E.from $ \(sheet `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ sheet E.^. SheetId ] $ do
       E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId)
@@ -138,8 +140,8 @@ getRelevantSheetsUpTo cid uid mCutoff
         Nothing -> E.where_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
       return (sheet E.^. SheetId, sheet E.^. SheetType, submission)
   where
-    postprocess :: [(E.Value SheetId, E.Value SheetType, Maybe (Entity Submission))]
+    postprocess :: [(E.Value SheetId, E.Value (SheetType SqlBackendKey), Maybe (Entity Submission))]
-                -> Map SheetId (SheetType, Maybe Points)
+                -> Map SheetId (SheetType SqlBackendKey, Maybe Points)
     postprocess = Map.fromList . map postprocess'
       where postprocess' (E.Value sId, E.Value sType, fmap entityVal -> sub)
               = (sId, ) . (sType, ) $ assertM submissionRatingDone sub >>= submissionRatingPoints
@@ -155,36 +157,27 @@ examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of
   ExamBonusManual{}
     -> Nothing
   ExamBonusPoints{..}
-    -> Just . roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp
+    -> Just . roundToPoints' bonusRound $ toRational bonusMaxPoints * bonusProp bonusMaxPoints
   where
-    bonusProp :: Rational
+    bonusProp :: Points -> Rational
-    bonusProp
+    bonusProp mPoints
       | possible <= 0 = 1
       | otherwise = achieved / possible
       where
-        achieved = toRational (getSum $ achievedPoints  bonusAchieved) + scalePasses (getSum $ achievedPasses  bonusAchieved)
+        achieved = toRational (getSum $ achievedPoints  bonusAchieved - achievedPassPoints  bonusAchieved) + scalePasses (getSum $ achievedPasses  bonusAchieved)
-        possible = toRational (getSum $ sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)
+        possible = toRational (getSum $ sumSheetsPoints bonusPossible - sumSheetsPassPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)
 
         scalePasses :: Integer -> Rational
         -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
         scalePasses passes
+          | pointsPossible <= 0 = toRational mPoints / fromInteger passesPossible
           | passesPossible <= 0 = 0
           | otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible
           where
             passesPossible = getSum $ numSheetsPasses bonusPossible
-            pointsPossible = getSum $ sumSheetsPoints bonusPossible
+            pointsPossible = getSum $ sumSheetsPoints bonusPossible - sumSheetsPassPoints bonusPossible
 
-    roundToPoints :: forall a. HasResolution a => Fixed a -> Rational -> Fixed a
+    roundToPoints' mult = (* mult) . roundToPoints . (/ toRational mult)
-    -- ^ 'round-to-nearest' whole multiple
-    roundToPoints (MkFixed mult'@(fromInteger -> mult)) ((* toRational (resolution (Proxy @a))) -> raw)
-      = MkFixed . (* mult') $
-          let (whole, frac) = raw `divMod'` mult
-           in if | abs frac < abs (mult / 2)
-                   -> whole
-                 | raw >= 0
-                   -> succ whole
-                 | otherwise
-                   -> pred whole
 
 examGrade :: ( MonoFoldable mono
              , Element mono ~ ExamResultPoints
@@ -223,9 +216,10 @@ examGrade Exam{..} mBonus (otoList -> results)
             lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'
 
 examBonusGrade :: ( MonoFoldable sheets
-                  , Element sheets ~ (SheetType, Maybe Points)
+                  , Element sheets ~ (SheetType epId, Maybe Points)
                   , MonoFoldable results
                   , Element results ~ ExamResultPoints
+                  , Ord epId
                   )
                => Exam
                -> Either Points sheets -- ^ `Points` retrieved from relevant `ExamBonus`, iff it exists
@@ -241,8 +235,6 @@ examBonusGrade exam@Exam{..} bonusInp = (mBonus, ) . examGrade exam mBonus
         bonusAchieved = (<>) <$> fmap normalSummary sheetSummary <*> fmap bonusSummary sheetSummary
 
 
-
-
 data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig
   { eaocMinimizeRooms :: Bool
   , eaocFinenessCost  :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms

src/Handler/Utils/Form.hs

@@ -1168,16 +1168,6 @@ nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
 embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
 
 
-data SheetType' = Normal' | Bonus' | Informational' | NotGraded'
-  deriving (Eq, Ord, Read, Show, Enum, Bounded)
-
-instance Universe SheetType'
-instance Finite SheetType'
-
-nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
-embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)
-
-
 data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
 
@@ -1207,30 +1197,47 @@ sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> tem
     passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints)
 
 
-sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
+sheetTypeAFormReq :: CourseId -> FieldSettings UniWorX -> Maybe (SheetType ExamPartId) -> AForm Handler (SheetType ExamPartId)
-sheetTypeAFormReq fs template = explainedMultiActionA acts opts fs (classify' <$> template)
+sheetTypeAFormReq cId fs template = wFormToAForm $ do
-  where
+  examParts'' <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart) -> do
-    acts = Map.fromList
+    E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
-      [ ( Normal', Normal <$> gradingReq )
+    E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
-      , ( Bonus' , Bonus  <$> gradingReq )
+    E.where_ $ exam E.^. ExamCourse E.==. E.val cId
-      , ( Informational', Informational <$> gradingReq  )
+    return (exam, course, examPart)
-      , ( NotGraded', pure NotGraded )
+
+  editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) ->
+    hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
+
+  let
+    examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt)
+    examParts = flip sortOn examParts' $ \(Entity _ Exam{..}, Entity _ ExamPart{..}) -> (examName, examPartNumber)
+    
+    doExamPartPoints = fmap classifySheetType template == Just ExamPartPoints'
+                    || not (null examParts)
+    
+    acts = Map.fromList $ catMaybes
+      [ pure ( Normal', Normal <$> gradingReq )
+      , pure ( Bonus' , Bonus  <$> gradingReq )
+      , pure ( Informational', Informational <$> gradingReq )
+      , pure ( NotGraded', pure NotGraded )
+      , guardOn doExamPartPoints ( ExamPartPoints', ExamPartPoints <$> examPartReq <*> weightReq <*> gradingReq )
       ]
     gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
-        & setTooltip MsgSheetGradingInfo) (template >>= preview _grading)
+        & setTooltip MsgSheetGradingInfo) $ template >>= preview _grading
+    weightReq = apreq (checkBool (>= 0) MsgSheetTypeExamPartPointsWeightNegative rationalField) (fslI MsgSheetTypeExamPartPointsWeight) $ preview (_Just . _weight) template
+    examPartReq = apreq examPartField (fslI MsgSheetTypeExamPartPointsExamPart) $ preview (_Just . _examPart) template >>= assertM' (\epId -> any (\(_, Entity epId' _) -> epId == epId') examParts)
+    examPartField = selectField' Nothing . fmap (fmap $ \(_, Entity epId _) -> epId) $ optionsCryptoIdF examParts
+      (\(_, Entity epId _) -> return epId)
+      (\(Entity _ Exam{..}, Entity _ ExamPart{..}) -> return $ MsgSheetTypeExamPartPointsExamPartOption examName examPartNumber)
 
     opts = explainOptionList optionsFinite $ \case
       Normal' -> return $ i18n MsgSheetTypeInfoNormalLecturer
       Bonus' -> return $ i18n MsgSheetTypeInfoBonus
       Informational' -> return $ i18n MsgSheetTypeInfoInformational
       NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded
-
+      ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints
-    classify' :: SheetType -> SheetType'
+  
-    classify' = \case
+  aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template
-      Bonus  {} -> Bonus'
-      Normal {} -> Normal'
-      Informational {} -> Informational'
-      NotGraded -> NotGraded'
 
 sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
 sheetGroupAFormReq fs template = explainedMultiActionA acts opts fs (classify' <$> template)

src/Handler/Utils/Rating.hs

@@ -13,6 +13,7 @@ import Import
 
 import Handler.Utils.Files
 import Handler.Utils.DateTime (getDateTimeFormatter)
+import Handler.Utils.Sheet (resolveSheetTypeRating)
 
 import qualified Data.Text as Text
 
@@ -28,7 +29,7 @@ import qualified Data.CaseInsensitive as CI
 import qualified Data.Char as Char
 
 
-validateRating :: SheetType -> Rating' -> [RatingValidityException]
+validateRating :: SheetType a -> Rating' -> [RatingValidityException]
 validateRating ratingSheetType Rating'{ ratingPoints=Just rp }
   | rp < 0
     = [RatingNegative]
@@ -59,7 +60,8 @@ getRating submissionId = runMaybeT $ do
         E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId
 
         -- Yes, we can only pass a tuple through 'E.select'
-        return ( course E.^. CourseTerm
+        return ( course E.^. CourseId
+               , course E.^. CourseTerm
                , school E.^. SchoolName
                , course E.^. CourseName
                , sheet E.^. SheetName
@@ -68,14 +70,16 @@ getRating submissionId = runMaybeT $ do
                , submission
                )
 
-  [ ( unTermKey . E.unValue -> ratingCourseTerm
+  [ ( E.unValue -> cId
+    , unTermKey . E.unValue -> ratingCourseTerm
     , E.unValue -> ratingCourseSchool
     , E.unValue -> ratingCourseName
     , E.unValue -> ratingSheetName
     , E.unValue -> ratingCorrectorName
-    , E.unValue -> ratingSheetType
+    , E.unValue -> ratingSheetType'
     , E.Entity _ sub@Submission{..}
     ) ] <- lift query
+  ratingSheetType <- lift $ resolveSheetTypeRating cId ratingSheetType'
 
   let ratingPoints = submissionRatingPoints
       ratingComment = submissionRatingComment

src/Handler/Utils/Sheet.hs

@@ -5,6 +5,10 @@ import Import
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Internal as E
 
+import qualified Data.Map.Strict as Map
+
+import Text.Hamlet
+
 
 -- | Map sheet file types to their visibily dates of a given sheet, for convenience
 sheetFileTypeDates :: Sheet -> SheetFileType -> Maybe UTCTime
@@ -51,3 +55,96 @@ fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Ye
 fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux (\sheet course -> (sheet E.^. SheetId, course E.^. CourseId)) tid ssh cid shn
 
 
+data ResolveSheetTypeException
+  = ResolveSheetTypeExamPartUnavailable SqlBackendKey
+  | ResolveSheetTypeForeignExam
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Exception)
+  
+resolveSheetType :: ( MonadThrow m
+                    , MonadIO m
+                    )
+                 => CourseId
+                 -> SheetType SqlBackendKey
+                 -> ReaderT SqlBackend m (SheetType (Entity ExamPart))
+resolveSheetType cId = traverse $ \epId'@(review _SqlKey -> epId) -> do
+  ep@(Entity _ ExamPart{..}) <- maybe (throwM $ ResolveSheetTypeExamPartUnavailable epId') return =<< getEntity epId
+  Exam{..} <- getJust examPartExam
+  if | examCourse /= cId -> throwM ResolveSheetTypeForeignExam
+     | otherwise         -> return ep
+
+resolveSheetTypeRating :: ( MonadThrow m
+                          , MonadIO m
+                          )
+                       => CourseId
+                       -> SheetType SqlBackendKey
+                       -> ReaderT SqlBackend m (SheetType RatingExamPartReference)
+resolveSheetTypeRating cId dbST = do
+  eST <- resolveSheetType cId dbST
+  case matching _ExamPartPoints eST of
+    Left t -> return t
+    Right (Entity _ ExamPart{..}, weight, grading) -> do
+      Exam{..} <- getJust examPartExam
+      return ExamPartPoints
+        { examPart = RatingExamPartReference examName examPartNumber
+        , ..
+        }
+
+sheetTypeDescription :: forall m.
+                        ( MonadThrow m
+                        , MonadHandler m, HandlerSite m ~ UniWorX
+                        )
+                     => CourseId
+                     -> SheetType SqlBackendKey
+                     -> ReaderT SqlBackend m (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
+sheetTypeDescription cId dbST = do
+  sType' <- resolveSheetType cId dbST
+  sType <- for sType' $ \(Entity _epId ExamPart{..}) -> do
+    Exam{..} <- getJust examPartExam
+    Course{..} <- getJust examCourse
+    cTime <- liftIO getCurrentTime
+    lecturerInfo <- hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
+    let partVisible = gradingVisible
+                   || NTop (Just cTime) >= NTop examPartsFrom
+                   || lecturerInfo
+        gradingVisible = NTop (Just cTime) >= NTop examPartsFrom
+                      || lecturerInfo
+    return (examName, examPartName, examPartNumber, partVisible, gradingVisible, CExamR courseTerm courseSchool courseShorthand examName EShowR)
+  return $(ihamletFile "templates/widgets/sheetType.hamlet")
+
+
+
+sheetExamResult :: SheetTypeSummary ExamPartId -> Entity ExamPart -> Maybe ExamResultPoints
+sheetExamResult SheetTypeSummary{ examSummary = MergeMap examSummary'' } (Entity epId ExamPart{..}) = Map.lookup epId examSummary'' <&> \examSummary' ->
+  let
+    sumOfWeights = getSum $ foldMap (views _1 Sum) examSummary'
+    weightRescale = recip sumOfWeights
+
+    toExamPoints :: (Rational, SheetGradeSummary) -> Maybe Rational
+    toExamPoints (weight, summary)
+      | sumOfWeights <= 0 = Nothing
+      | otherwise = Just . (* weight) $ case examPartMaxPoints of
+          Just maxPoints -> toRational maxPoints * bonusProp
+          Nothing        -> bonusProp * possible
+      where
+        bonusProp :: Rational
+        bonusProp | possible <= 0 = 1
+                  | otherwise     = achieved / possible
+
+        achieved = toRational (getSum $ achievedPoints  summary - achievedPassPoints  summary) + scalePasses (getSum $ achievedPasses  summary)
+        possible = toRational (getSum $ sumSheetsPoints summary - sumSheetsPassPoints summary) + scalePasses (getSum $ numSheetsPasses summary)
+
+        scalePasses :: Integer -> Rational
+        scalePasses passes
+          | pointsPossible <= 0
+          , Just maxPoints <- examPartMaxPoints = fromInteger passes * toRational maxPoints / fromInteger passesPossible
+          | pointsPossible <= 0 = 0
+          | passesPossible <= 0 = 0
+          | otherwise = fromInteger passes / (fromInteger passesPossible * passesWeights) * (toRational pointsPossible * pointsWeights)
+          where
+            passesPossible = getSum $ numSheetsPasses summary
+            pointsPossible = getSum $ sumSheetsPoints summary - sumSheetsPassPoints summary
+
+            pointsWeights = getSum $ foldMap (\(sWeight, gradeSummary) -> guardMonoid (sumSheetsPoints gradeSummary - sumSheetsPassPoints gradeSummary > 0) $ Sum sWeight) examSummary'
+            passesWeights = getSum $ foldMap (\(sWeight, gradeSummary) -> guardMonoid (numSheetsPasses gradeSummary > 0) $ Sum sWeight) examSummary'
+   in ExamAttended . roundToPoints . (* examPartWeight) . (* weightRescale) . getSum . fold $ foldMapM (fmap Sum . toExamPoints) examSummary'

src/Handler/Utils/SheetType.hs

@@ -5,7 +5,7 @@ module Handler.Utils.SheetType
 
 import Import
 
-addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
+addBonusToPoints :: SheetTypeSummary a -> SheetTypeSummary a
 addBonusToPoints sts =
     sts & _normalSummary . _achievedPasses %~ (min passmax . (passbonus +))
         & _normalSummary . _achievedPoints %~ (min ptsmax  . (ptsbonus  +))
@@ -15,7 +15,7 @@ addBonusToPoints sts =
     ptsmax    = sts ^. _normalSummary . _sumMarkedPoints
     ptsbonus  = sts ^. _bonusSummary  . _achievedPoints
 
-gradeSummaryWidget ::  RenderMessage UniWorX msg => (Integer -> msg) -> SheetTypeSummary -> Widget
+gradeSummaryWidget ::  RenderMessage UniWorX msg => (Integer -> msg) -> SheetTypeSummary a -> Widget
 gradeSummaryWidget title sts =
   let SheetTypeSummary{..} = addBonusToPoints sts
       sumSummaries    = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)

src/Handler/Utils/Table/Pagination.hs

@@ -32,7 +32,7 @@ module Handler.Utils.Table.Pagination
   , dbTableWidget, dbTableWidget'
   , dbTableDB, dbTableDB'
   , widgetColonnade, formColonnade, dbColonnade
-  , cell, textCell, stringCell, i18nCell
+  , cell, wgtCell, textCell, stringCell, i18nCell
   , anchorCell, anchorCell', anchorCellM, anchorCellM'
   , linkEitherCell, linkEitherCellM, linkEitherCellM'
   , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
@@ -1508,6 +1508,9 @@ pagesizeField psLim = selectField $ do
 cell :: IsDBTable m a => Widget -> DBCell m a
 cell wgt = dbCell # ([], return wgt)
 
+wgtCell :: (IsDBTable m a, ToWidget UniWorX wgt) => wgt -> DBCell m a
+wgtCell = cell . toWidget
+
 textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
 textCell = cell . toWidget . (pack :: String -> Text) . otoList
 stringCell = textCell

src/Import/NoModel.hs

@@ -187,6 +187,7 @@ import Text.Shakespeare.Text.Instances as Import ()
 import Ldap.Client.Instances as Import ()
 import Network.URI.Instances as Import ()
 import Data.MultiSet.Instances as Import ()
+import Control.Arrow.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
 import Crypto.Random as Import (ChaChaDRG, Seed)
@@ -213,6 +214,8 @@ import Data.Kind as Import (Type, Constraint)
 
 import Data.Scientific as Import (Scientific, formatScientific)
 
+import Data.MultiSet as Import (MultiSet)
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Jobs/Handler/SendNotification/SubmissionRated.hs

@@ -12,14 +12,16 @@ import Jobs.Handler.SendNotification.Utils
 import Text.Hamlet
 import qualified Data.CaseInsensitive as CI
 
+
 dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler ()
 dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipient $ do
-  (Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandler . runDB $ do
+  (Course{..}, Sheet{..}, Submission{..}, corrector, sheetTypeDesc) <- liftHandler . runDB $ do
     submission@Submission{submissionRatingBy} <- getJust nSubmission
     sheet <- belongsToJust submissionSheet submission
     course <- belongsToJust sheetCourse sheet
     corrector <- traverse getJust submissionRatingBy
-    return (course, sheet, submission, corrector)
+    sheetTypeDesc <- sheetTypeDescription (sheetCourse sheet) (sheetType sheet)
+    return (course, sheet, submission, corrector, sheetTypeDesc)
 
   whenIsJust corrector $ \corrector' ->
     addMailHeader "Reply-To" . renderAddress $ userAddressFrom corrector'
@@ -29,7 +31,6 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
   csid <- encrypt nSubmission
   MsgRenderer mr <- getMailMsgRenderer
   let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
-  let sheetTypeDesc = mr sheetType
   submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime
   let tid = courseTerm
       ssh = courseSchool
@@ -38,4 +39,4 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
 
   editNotifications <- mkEditNotifications jRecipient
 
-  addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+  addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))

src/Jobs/Handler/SendNotification/Utils.hs

@@ -11,7 +11,7 @@ import qualified Data.HashSet as HashSet
 import qualified Data.HashMap.Strict as HashMap
 
 
-ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
+ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage route -> HtmlUrlI18n (SomeMessage UniWorX) route
 ihamletSomeMessage f trans = f $ trans . SomeMessage
 
 mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Model.hs

@@ -23,6 +23,8 @@ import Text.Blaze (ToMarkup(..))
 
 import Database.Persist.Sql (BackendKey(..))
 
+import qualified Database.Esqueleto as E
+
 
 type SqlBackendKey = BackendKey SqlBackend
 
@@ -38,6 +40,9 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateUni
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime
 
+sqlSubmissionRatingDone :: E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value Bool)
+sqlSubmissionRatingDone submission = E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime
+
 
 deriving newtype instance ToJSONKey UserId
 deriving newtype instance FromJSONKey UserId
@@ -46,6 +51,8 @@ deriving newtype instance FromJSONKey ExamOccurrenceId
 
 deriving instance Show (Unique ExamPart)
 
+deriving anyclass instance NFData ExamPart
+
 -- ToMarkup and ToMessage instances for displaying selected database primary keys
 
 instance ToMarkup (Key School) where

src/Model/Migration/Definitions.hs

@@ -96,6 +96,7 @@ data ManualMigration
   | Migration20200916ExamMode
   | Migration20201106StoredMarkup
   | Migration20201119RoomTypes
+  | Migration20210115ExamPartsFrom
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 
@@ -959,6 +960,14 @@ customMigrations = mapF $ \case
           migrateCourse _ = return ()
        in runConduit $ getCourses .| C.mapM_ migrateCourse
 
+  Migration20210115ExamPartsFrom -> do
+    whenM (tableExists "exam") $ do
+      [executeQQ|ALTER TABLE "exam" ADD COLUMN "parts_from" timestamp with time zone|]
+      let getExam = [queryQQ|SELECT "id", "finished" FROM "exam"|]
+          migrateExam [ fromPersistValue -> Right (eId :: ExamId), fromPersistValue -> Right (finished :: Maybe UTCTime) ] = [executeQQ|UPDATE "exam" SET "parts_from" = #{finished} WHERE "id" = #{eId}|]
+          migrateExam _ = return ()
+       in runConduit $ getExam .| C.mapM_ migrateExam
+
 
 tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableExists table = do

src/Model/Migration/Types.hs

@@ -28,7 +28,7 @@ data SheetType
   | NotGraded
   deriving (Show, Read, Eq)
 
-sheetType :: SheetType -> Current.SheetType
+sheetType :: SheetType -> Current.SheetType a
 sheetType Bonus {..}  = Current.Bonus  Current.Points {..}
 sheetType Normal {..} = Current.Normal Current.Points {..}
 sheetType Pass {..}   = Current.Normal Current.PassPoints {..}

src/Model/Rating.hs

@@ -6,6 +6,9 @@ import CryptoID
 -- import Data.Text (Text)
 import Data.Text.Encoding.Error (UnicodeException(..))
 
+import Data.Aeson.TH
+import Utils.PathPiece
+
 
 data Rating = Rating
   { ratingCourseTerm :: TermIdentifier
@@ -13,11 +16,17 @@ data Rating = Rating
   , ratingCourseName :: CourseName
   , ratingSheetName :: SheetName
   , ratingCorrectorName :: Maybe Text
-  , ratingSheetType :: SheetType
+  , ratingSheetType :: SheetType RatingExamPartReference
   , ratingValues :: Rating'
   } deriving (Read, Show, Eq, Generic, Typeable)
     deriving anyclass (NFData)
 
+data RatingExamPartReference = RatingExamPartReference
+  { ratingExamName :: ExamName
+  , ratingExamPartNumber :: ExamPartNumber
+  } deriving (Read, Show, Eq, Ord, Generic, Typeable)
+    deriving anyclass (NFData)
+
 data Rating' = Rating'
   { ratingPoints :: Maybe Points
   , ratingComment :: Maybe Text
@@ -26,6 +35,11 @@ data Rating' = Rating'
   } deriving (Read, Show, Eq, Generic, Typeable)
     deriving anyclass (NFData)
 
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''RatingExamPartReference
+
+
 data RatingValidityException
   = RatingNegative       -- ^ Rating points must be non-negative
   | RatingExceedsMax     -- ^ Rating point must not exceed maximum points

src/Model/Types/Exam.hs

@@ -387,6 +387,7 @@ hasExamGradingGrades _                 = True
 
 newtype ExamPartNumber = ExamPartNumber { examPartNumberFragments :: [Either (CI Text) Natural] }
   deriving (Eq, Ord, Generic, Typeable)
+  deriving anyclass (NFData)
 
 _ExamPartNumber :: Iso' ExamPartNumber (CI Text)
 _ExamPartNumber = iso pToText pFromText

src/Model/Types/Sheet.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 {-|
 Module: Model.Types.Sheet
 Description: Types for modeling sheets
@@ -15,6 +17,7 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
+import qualified Data.MultiSet as MultiSet
 
 import Text.Blaze (Markup)
 
@@ -26,6 +29,7 @@ import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
 
 
+
 data SheetGrading
   = Points     { maxPoints :: Points }
   | PassPoints { maxPoints, passingPoints :: Points }
@@ -78,7 +82,7 @@ data SheetGradeSummary = SheetGradeSummary
   , achievedPasses :: Count        -- Achieved passes (within marked sheets)
   , achievedPoints :: Sum Points   -- Achieved points (within marked sheets)
   , achievedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points
-  } deriving (Generic, Read, Show, Eq)
+  } deriving (Generic, Read, Show, Eq, Ord)
 
 instance Monoid SheetGradeSummary where
   mempty  = memptydefault
@@ -113,12 +117,17 @@ sheetGradeSum gr (Just p) =
         }
 
 
-data SheetType
+data SheetType exampartid
   = NotGraded
   | Normal        { grading :: SheetGrading }
   | Bonus         { grading :: SheetGrading }
   | Informational { grading :: SheetGrading }
-  deriving (Eq, Ord, Read, Show, Generic)
+  | ExamPartPoints
+    { examPart  :: exampartid
+    , weight    :: Rational
+    , grading   :: SheetGrading
+    }
+  deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic)
   deriving anyclass (NFData)
 
 deriveJSON defaultOptions
@@ -131,27 +140,29 @@ derivePersistFieldJSON ''SheetType
 makeLenses_ ''SheetType
 makePrisms ''SheetType
 
-data SheetTypeSummary = SheetTypeSummary
+data SheetTypeSummary exampartid = SheetTypeSummary
   { normalSummary
   , bonusSummary
   , informationalSummary :: SheetGradeSummary
+  , examSummary :: MergeMap exampartid (MultiSet (Rational, SheetGradeSummary))
   , numNotGraded :: Count
-  } deriving (Generic, Read, Show, Eq)
+  } deriving (Generic, Show, Eq)
 
-instance Monoid SheetTypeSummary where
+instance Ord epid => Monoid (SheetTypeSummary epid) where
   mempty  = memptydefault
   mappend = mappenddefault
 
-instance Semigroup SheetTypeSummary where
+instance Ord epid => Semigroup (SheetTypeSummary epid) where
   (<>) = mappend -- TODO: remove for GHC > 8.4.x
 
 makeLenses_ ''SheetTypeSummary
 
-sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
+sheetTypeSum :: forall epid. Ord epid => SheetType epid -> Maybe Points -> SheetTypeSummary epid
-sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps }
+sheetTypeSum Bonus{..}          mps = mempty { bonusSummary         = sheetGradeSum grading mps }
-sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps }
+sheetTypeSum Normal{..}         mps = mempty { normalSummary        = sheetGradeSum grading mps }
-sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
+sheetTypeSum Informational{..}  mps = mempty { informationalSummary = sheetGradeSum grading mps }
-sheetTypeSum NotGraded _           = mempty { numNotGraded         = Sum 1 }
+sheetTypeSum NotGraded          _   = mempty { numNotGraded         = Sum 1 }
+sheetTypeSum ExamPartPoints{..} mps = (mempty @(SheetTypeSummary epid)) { examSummary = MergeMap . Map.singleton examPart $ MultiSet.singleton (weight, sheetGradeSum grading mps) }
 
 data SheetGroup
   = Arbitrary { maxParticipants :: Natural }
@@ -360,7 +371,7 @@ showCompactCorrectorLoad Load{..} CorrectorNormal  | byProportion == 0 = tutoria
                                       Just True  -> "(T)"
                                       Just False -> "T"
 
-instance Csv.ToField (SheetType, Maybe Points) where
+instance Csv.ToField (SheetType epid, Maybe Points) where
   toField (_, Nothing) = mempty
   toField (sType, Just res)
     | Just passed <- flip gradingPassed res =<< preview _grading sType

src/Utils.hs

@@ -10,6 +10,8 @@ import qualified Data.Foldable as Fold
 import Data.Foldable as Utils (foldlM, foldrM)
 import Data.Monoid (First, Sum(..))
 import Data.Proxy
+import Control.Arrow (Kleisli(..))
+import Control.Arrow.Instances ()
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
@@ -36,7 +38,7 @@ import Utils.NTop as Utils
 import Utils.HttpConditional as Utils
 import Utils.Persist as Utils
 
-import Text.Blaze (Markup, ToMarkup)
+import Text.Blaze (Markup, ToMarkup(..))
 
 import Data.Char (isDigit, isSpace, isAscii)
 import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
@@ -132,6 +134,10 @@ import Yesod.Core.Types.Instances.Catch ()
 import Control.Monad.Trans.Resource
 import Control.Monad.Reader.Class (MonadReader(local))
 
+import Text.Hamlet (Translate)
+
+import Data.Ratio ((%))
+
 {-# ANN module ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -148,6 +154,9 @@ getMsgRenderer = do
   mr <- getMessageRender
   return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
 
+getTranslate :: forall m site msg. (MonadHandler m, HandlerSite m ~ site, RenderMessage site msg) => m (Translate msg)
+getTranslate = (toMarkup .) <$> getMessageRender
+
 
 guardAuthResult :: MonadHandler m => AuthResult -> m ()
 guardAuthResult AuthenticationRequired = notAuthenticated
@@ -346,6 +355,14 @@ rationalToFixed2 = rationalToFixed
 realToFixed :: forall a n. (Real n, HasResolution a) => n -> Fixed a
 realToFixed = rationalToFixed . toRational
 
+roundToPoints :: forall a. HasResolution a => Rational -> Fixed a
+roundToPoints ((* toRational (resolution $ Proxy @a)) -> raw) = MkFixed $
+  let (whole, frac) = properFraction raw
+   in if | abs frac < abs (1 % 2)
+           -> whole
+         | otherwise
+           -> succ whole
+
 ----------
 -- Bool --
 ----------
@@ -427,6 +444,9 @@ guardMonoid :: Monoid m => Bool -> m -> m
 guardMonoid False _ = mempty
 guardMonoid True  x = x
 
+assertMonoid :: Monoid m => (m -> Bool) -> m -> m
+assertMonoid f x = guardMonoid (f x) x
+
 ------------
 -- Tuples --
 ------------
@@ -442,7 +462,8 @@ trd3 (_,_,z) = z
 -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
 -- snd3 = $(projNI 3 2)
 
-
+mTuple :: Applicative f => f a -> f b -> f (a, b)
+mTuple = liftA2 (,)
 
 -----------
 -- Lists --
@@ -574,6 +595,9 @@ partitionKeysEither = over _2 (Map.mapKeysMonotonic . view $ singular _Right) .
 mapFromSetM :: Applicative m => (k -> m v) -> Set k -> m (Map k v)
 mapFromSetM = (sequenceA .) . Map.fromSet
 
+mapFilterM :: (Monad m, Ord k) => (v -> m Bool) -> Map k v -> m (Map k v)
+mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT . assertMM (lift . f) . hoistMaybe)) (Map.keys m)
+
 ---------------
 -- Functions --
 ---------------
@@ -893,6 +917,7 @@ diffTimeout timeoutLength timeoutRes act = fromMaybe timeoutRes <$> timeout time
       = let (MkFixed micro :: Micro) = realToFrac timeoutLength
          in fromInteger micro
 
+
 --------------
 -- Foldable --
 --------------
@@ -1468,7 +1493,6 @@ instance (Ord k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeMap k
 
       parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
       parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx
-
   
 --------------
 -- FilePath --

src/Utils/Lens.hs

@@ -161,6 +161,8 @@ makeLenses_ ''SubmissionGroup
 
 makeLenses_ ''SheetGrading
 
+makeLenses_ ''Sheet
+
 makePrisms ''SheetGroup
 
 makePrisms ''AuthResult

src/Utils/Workflow/Lint.hs

@@ -6,7 +6,6 @@ module Utils.Workflow.Lint
 import Import.NoFoundation
 
 import qualified Data.Set as Set
-import Data.MultiSet (MultiSet)
 import qualified Data.MultiSet as MultiSet
 import qualified Data.Map as Map
 import qualified Data.Sequence as Seq

templates/correction-user.hamlet

@@ -17,11 +17,11 @@
         $case grading 
           $of Points{..}
             <tr .table__row>
-              <th .table__th>_{sheetType}
+              <th .table__th>^{sheetTypeDesc tr}
               <td .table__td>_{MsgAchievedOf points maxPoints}
           $of PassPoints{..}
             <tr .table__row>
-              <th .table__th>_{sheetType}
+              <th .table__th>^{sheetTypeDesc tr}
               <td .table__td>
                 $if fromMaybe False (gradingPassed grading points)
                   _{MsgPassed}
@@ -32,7 +32,7 @@
               <td .table__td>_{MsgPassAchievedOf points passingPoints maxPoints}
           $of PassBinary
             <tr .table__row>
-              <th .table__th>_{sheetType}
+              <th .table__th>^{sheetTypeDesc tr}
               <td .table__td>
                 $if fromMaybe False (gradingPassed grading points)
                   _{MsgPassed}

templates/exam-show.hamlet

@@ -260,11 +260,11 @@ $if not (null occurrences)
           <td>
 
 
-$if gradingShown && not (null examParts)
+$if (gradingShown || partsShown) && not (null examParts)
   <section>
     <h2>
       _{MsgExamParts}
-      $if gradingShown && not gradingVisible
+      $if (gradingShown && not gradingVisible) || (partsShown && not partsVisible)
         \ ^{isVisible False}
     <table .table .table--striped .table--hover >
       <thead>
@@ -273,13 +273,15 @@ $if gradingShown && not (null examParts)
             <th .table__th>
               _{MsgExamPartNumber} ^{isVisible False}
           <th .table__th>_{MsgExamPartName}
+          $if showPartSheets
+            <th .table__th>_{MsgExamPartSheets}
           $if showMaxPoints
             <th .table__th>_{MsgExamPartMaxPoints}
           $if showAchievedPoints
             <th .table__th>_{MsgExamPartResultPoints}
       <tbody>
-        $forall Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints} <- examParts
+        $forall (Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints}, cID, partSheets) <- examParts
-          <tr .table__row>
+          <tr .table__row ##{toPathPiece cID}>
             $if partNumbersShown
               <td .table__td>#{examPartNumber}
             <td .table__td>
@@ -287,6 +289,14 @@ $if gradingShown && not (null examParts)
                 #{pName}
               $nothing
                 _{MsgExamPartNumbered examPartNumber}
+            $if showPartSheets
+              <td .table__td>
+                $if not (null partSheets)
+                  <ul .list--inline .list--comma-separated>
+                    $forall Entity _ Sheet{sheetName} <- partSheets
+                      <li>
+                        <a href=@{CSheetR tid ssh csh sheetName SShowR}>
+                          #{sheetName}
             $if showMaxPoints
               <td .table__td>
                 $maybe mPoints <- examPartMaxPoints

templates/i18n/changelog/exam-sheets.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Übungsblätter können nun „als Prüfungsaufgabe“ bewertet werden.

templates/i18n/changelog/exam-sheets.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Exercise sheets can now be rated “as an exam part”.

templates/mail/submissionRated.hamlet

@@ -16,52 +16,52 @@ $newline never
       }
   <body>
     <h1>
-      _{MsgMailSubmissionRatedIntro (CI.original courseName) termDesc}
+      _{SomeMessage (MsgMailSubmissionRatedIntro (CI.original courseName) termDesc)}
     <dl>
       <dt>
-        _{MsgSubmission}
+        _{SomeMessage MsgSubmission}
       <dd>
         <a href=@{CSubmissionR tid ssh csh shn csid SubShowR}>
           #{csid}
       $maybe User{userDisplayName, userSurname, userEmail} <- corrector
         <dt>
-          _{MsgRatingBy}
+          _{SomeMessage MsgRatingBy}
         <dd>
           #{nameEmailHtml userEmail userDisplayName userSurname}
       $maybe time <- submissionRatingTime'
         <dt>
-          _{MsgRatingTime}
+          _{SomeMessage MsgRatingTime}
         <dd>
           #{time}
-      <dt> #{sheetTypeDesc}
+      <dt> ^{sheetTypeDesc}
       $maybe points <- submissionRatingPoints
         $maybe grading <- preview _grading sheetType
           $case grading 
             $of Points{..}
               <dd>
-                _{MsgAchievedOf points maxPoints}          
+                _{SomeMessage (MsgAchievedOf points maxPoints)}
             $of PassPoints{..}
               <dd>
                 $if fromMaybe False (gradingPassed grading points)
-                  _{MsgPassed}
+                  _{SomeMessage MsgPassed}
                 $else
-                  _{MsgNotPassed}
+                  _{SomeMessage MsgNotPassed}
               <dt>
-                _{MsgAchievedPassPoints}
+                _{SomeMessage MsgAchievedPassPoints}
               <dd>
-                _{MsgPassAchievedOf points passingPoints maxPoints}
+                _{SomeMessage (MsgPassAchievedOf points passingPoints maxPoints)}
             $of PassBinary
               <dd>
                 $if fromMaybe False (gradingPassed grading points)
-                  _{MsgPassed}
+                  _{SomeMessage MsgPassed}
                 $else
-                  _{MsgNotPassed}
+                  _{SomeMessage MsgNotPassed}
             $of PassAlways
               <dd>
               
       $maybe comment <- submissionRatingComment
         <dt>
-          _{MsgRatingComment}
+          _{SomeMessage MsgRatingComment}
         <dd .comment>
           #{comment}
-    ^{editNotifications}
+    ^{ihamletSomeMessage editNotifications}

templates/sheetShow.hamlet

@@ -66,8 +66,10 @@ $maybe descr <- sheetDescription sheet
           $nothing
             ^{generateForm}
       $of _
-    <dt .deflist__dt>_{MsgSheetType}
+    <dt .deflist__dt>
-    <dd .deflist__dd>_{sheetType sheet}
+      _{MsgSheetType}
+    <dd .deflist__dd>
+      ^{sTypeDesc tr}
 
 $maybe marktxt <- markingText
   <section>

templates/widgets/rating/rating.hamlet

@@ -8,20 +8,17 @@ $if submissionRatingDone sub
     $case grading
       $of Points{..}
         _{MsgAchievedOf points maxPoints}
-        , #
       $of PassPoints{maxPoints}
         $if fromMaybe False (gradingPassed grading points)
           _{MsgPassed}, _{MsgAchievedOf points maxPoints}
         $else
           _{MsgNotPassed}, _{MsgAchievedOf points maxPoints}
-        , #
       $of PassBinary
         $if fromMaybe False (gradingPassed grading points)
           _{MsgPassed}
         $else
           _{MsgNotPassed}
-        , #
       $of PassAlways
-    _{SheetTypeHeader sheetType}
+        #{hasTickmark True}
   $nothing
     #{hasTickmark True}

templates/widgets/sheetType.hamlet

@@ -0,0 +1,13 @@
+$newline never
+$maybe g <- preview _grading sType
+  _{SomeMessage g}, #
+_{SomeMessage (classifySheetType sType)}
+$maybe ((eName, epName, epNumber, partVisible, gradingVisible, eRoute), weight, _) <- preview _ExamPartPoints sType
+  \ (
+  <a href=@{eRoute}>
+    #{eName}
+  $if partVisible
+    \ - _{fromMaybe (SomeMessage (MsgExamPartNumbered epNumber)) (fmap SomeMessage epName)}
+    $if gradingVisible
+      , _{SomeMessage MsgSheetTypeExamPartPointsWeight} _{SomeMessage (rationalToFixed3 weight)}
+  )

test/Database/Fill.hs

@@ -3,7 +3,7 @@ module Database.Fill
   ) where
 
 import "uniworx" Import hiding (Option(..), currentYear)
-import Handler.Utils.Form (SheetGrading'(..), SheetType'(..), SheetGroup'(..))
+import Handler.Utils.Form (SheetGrading'(..), SheetGroup'(..))
 
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text as Text
@@ -708,6 +708,7 @@ fillDb = do
     , examStart = Just $ termTime True Summer 3 True Tuesday (toTimeOfDay 10 0 0)
     , examEnd = Just $ termTime True Summer 3 True Tuesday (toTimeOfDay 12 0 0)
     , examFinished = Just $ termTime True Summer 3 True Wednesday (toTimeOfDay 22 0 0)
+    , examPartsFrom = Just $ termTime True Summer (-4) True Monday toMidnight
     , examClosed = Nothing
     , examPublicStatistics = True
     , examGradingMode = ExamGradingGrades
@@ -888,11 +889,7 @@ fillDb = do
           | otherwise
           = mr sheetType'
           where
-            sheetType' = case sheetType of
+            sheetType' = classifySheetType sheetType
-              NotGraded -> NotGraded'
-              Normal{} -> Normal'
-              Bonus{} -> Bonus'
-              Informational{} -> Informational'
 
         prog = 14 * (shNr % genericLength sheetCombinations)
 

test/Model/RatingSpec.hs

@@ -4,6 +4,10 @@ import TestImport
 import ModelSpec ()
 import Model.Rating
 
+instance Arbitrary RatingExamPartReference where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
 instance Arbitrary Rating' where
   arbitrary = genericArbitrary
   shrink = genericShrink

test/Model/TypesSpec.hs

@@ -91,7 +91,7 @@ instance Arbitrary SheetGrading where
     ]
   shrink = genericShrink
 
-instance Arbitrary SheetType where
+instance Arbitrary epId => Arbitrary (SheetType epId) where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
@@ -103,9 +103,8 @@ instance Arbitrary SheetGroup where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
-instance Arbitrary SheetTypeSummary where
+instance (Arbitrary epId, Ord epId) => Arbitrary (SheetTypeSummary epId) where
-  arbitrary = genericArbitrary
+  arbitrary = foldMap (uncurry sheetTypeSum) <$> listOf arbitrary
-  shrink = genericShrink
 
 instance Arbitrary SheetFileType where
   arbitrary = genericArbitrary
@@ -342,10 +341,10 @@ spec = do
       [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @SheetGradeSummary)
       [ eqLaws, showReadLaws, commutativeMonoidLaws, commutativeSemigroupLaws ]
-    lawsCheckHspec (Proxy @SheetType)
+    lawsCheckHspec (Proxy @(SheetType SqlBackendKey))
       [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
-    lawsCheckHspec (Proxy @SheetTypeSummary)
+    lawsCheckHspec (Proxy @(SheetTypeSummary SqlBackendKey))
-      [ eqLaws, showReadLaws, commutativeMonoidLaws ]
+      [ eqLaws, showLaws, commutativeMonoidLaws ]
     lawsCheckHspec (Proxy @SheetGroup)
       [ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @SheetFileType)