diff --git a/frontend/src/app.sass b/frontend/src/app.sass
index 949018fe0..365ac1f3e 100644
--- a/frontend/src/app.sass
+++ b/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)
diff --git a/load/Load.hs b/load/Load.hs
index 1f8bcb1e0..b2eec491d 100644
--- a/load/Load.hs
+++ b/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
diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index b7fe3de9a..1c6a746ae 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/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
-SheetTypeNormal grading@SheetGrading: Normal
-SheetTypeInformational grading@SheetGrading: Ohne Anrechnung
+SheetTypeBonus: Bonus
+SheetTypeNormal: Normal
+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
diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg
index a6b788212..5a5030342 100644
--- a/messages/uniworx/en-eu.msg
+++ b/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
-SheetTypeNormal grading: Normal
-SheetTypeInformational grading: Informational
+SheetTypeBonus: Bonus
+SheetTypeNormal: Normal
+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
diff --git a/models/exams.model b/models/exams.model
index db9b7c2d4..27bdba1d8 100644
--- a/models/exams.model
+++ b/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
diff --git a/models/sheets.model b/models/sheets.model
index 6f0bb6176..a4d1fac2c 100644
--- a/models/sheets.model
+++ b/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
diff --git a/src/Control/Arrow/Instances.hs b/src/Control/Arrow/Instances.hs
new file mode 100644
index 000000000..8bf44e118
--- /dev/null
+++ b/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
diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs
index e7309b6cc..d356217ca 100644
--- a/src/Database/Persist/Types/Instances.hs
+++ b/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
diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs
index 97f8ae1a5..b8b7527bf 100644
--- a/src/Foundation/I18n.hs
+++ b/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
-embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
+data 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)
diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs
index 9775952b4..64f156b7a 100644
--- a/src/Handler/Course/Users.hs
+++ b/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
diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs
index 7f46d7a58..4208453e1 100644
--- a/src/Handler/Exam/Edit.hs
+++ b/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
diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs
index d280b51df..f4dfdbe08 100644
--- a/src/Handler/Exam/Form.hs
+++ b/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 MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
-
+ guardValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd)
+ 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
diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs
index 5961f0187..e982a91be 100644
--- a/src/Handler/Exam/New.hs
+++ b/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_
diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs
index c72231c77..59ed1a4c5 100644
--- a/src/Handler/Exam/Show.hs
+++ b/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
- showAchievedPoints = not $ null results
+ showMaxPoints = gradingShown && any (has $ _1 . _entityVal . _examPartMaxPoints . _Just) examParts
+ 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
diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs
index eb3f4aba1..9c45618f7 100644
--- a/src/Handler/Exam/Users.hs
+++ b/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 = resultExamParts <. _2
+-- resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
+-- 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)
- | Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
+ [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) . automaticCell $ resultExamPartResult epId . _Just . _entityVal . _examPartResultResult . to Right <> resultAutomaticExamPartResult epEnt bonus . to Left
+ | 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
diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs
index 4857e6646..5acf81fc6 100644
--- a/src/Handler/Sheet/Edit.hs
+++ b/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
diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs
index 73c65cdcb..f70b3d473 100644
--- a/src/Handler/Sheet/Form.hs
+++ b/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)
diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs
index bd7afe47a..c72fc8868 100644
--- a/src/Handler/Sheet/List.hs
+++ b/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)
- $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType
+ , sortable Nothing (i18nCell MsgSheetType) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> cell $ do
+ 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
- , dbtStyle = def
+ , dbtFilterUI = mconcat
+ [ 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
diff --git a/src/Handler/Sheet/New.hs b/src/Handler/Sheet/New.hs
index f3dba58c2..922659140 100644
--- a/src/Handler/Sheet/New.hs
+++ b/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
diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs
index dd84f8cce..ccc39aa8d 100644
--- a/src/Handler/Sheet/Show.hs
+++ b/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")
diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs
index 47d8c915e..9c00514ae 100644
--- a/src/Handler/Submission/Correction.hs
+++ b/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
- -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
- (fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType)
- (Just submissionRatingPoints)
+ _otherwise -> aSetTooltip (Just $ sheetTypeDesc tr ur) $
+ aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
+ (fslpI MsgRatingPoints (mr MsgPointsPlaceholder))
+ (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
- urlArchive <- toTextUrl . CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected
- $(widgetFile "correction-user")
+ let heading = MsgCorrectionHead tid ssh csh shn cid
+ urlArchive <- toTextUrl . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected
+ tr <- getTranslate
+ sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
+ siteLayoutMsg heading $ do
+ setTitleI heading
+ $(widgetFile "correction-user")
_ -> notFound
diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs
index b728c2d12..4758b7b27 100644
--- a/src/Handler/Submission/Helper.hs
+++ b/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")
diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs
index 019d933d8..648fb19d1 100644
--- a/src/Handler/Submission/List.hs
+++ b/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
diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs
index be37e167e..79878e05c 100644
--- a/src/Handler/Utils/Exam.hs
+++ b/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)
- accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) ->
- flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType $ assertM submissionRatingDone sub >>= submissionRatingPoints
+ return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission, sheet E.^. SheetCourse)
+ accum = C.foldM ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub, E.Value cId) -> do
+ 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))]
- -> Map SheetId (SheetType, Maybe Points)
+ postprocess :: [(E.Value SheetId, E.Value (SheetType SqlBackendKey), Maybe (Entity Submission))]
+ -> 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
+ bonusProp :: Points -> Rational
+ bonusProp mPoints
| possible <= 0 = 1
| otherwise = achieved / possible
where
- achieved = toRational (getSum $ achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved)
- possible = toRational (getSum $ sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)
+ achieved = toRational (getSum $ achievedPoints bonusAchieved - achievedPassPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved)
+ 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
- -- ^ '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
+ roundToPoints' mult = (* mult) . roundToPoints . (/ toRational mult)
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
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 2c0ff5949..fddf06876 100644
--- a/src/Handler/Utils/Form.hs
+++ b/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 fs template = explainedMultiActionA acts opts fs (classify' <$> template)
- where
- acts = Map.fromList
- [ ( Normal', Normal <$> gradingReq )
- , ( Bonus' , Bonus <$> gradingReq )
- , ( Informational', Informational <$> gradingReq )
- , ( NotGraded', pure NotGraded )
+sheetTypeAFormReq :: CourseId -> FieldSettings UniWorX -> Maybe (SheetType ExamPartId) -> AForm Handler (SheetType ExamPartId)
+sheetTypeAFormReq cId fs template = wFormToAForm $ do
+ examParts'' <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart) -> do
+ E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
+ E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+ E.where_ $ exam E.^. ExamCourse E.==. E.val cId
+ return (exam, course, examPart)
+
+ 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
-
- classify' :: SheetType -> SheetType'
- classify' = \case
- Bonus {} -> Bonus'
- Normal {} -> Normal'
- Informational {} -> Informational'
- NotGraded -> NotGraded'
+ ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints
+
+ aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
sheetGroupAFormReq fs template = explainedMultiActionA acts opts fs (classify' <$> template)
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index ef65892b0..e7c49f9ce 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/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
diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs
index 9cd159284..760c15705 100644
--- a/src/Handler/Utils/Sheet.hs
+++ b/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'
diff --git a/src/Handler/Utils/SheetType.hs b/src/Handler/Utils/SheetType.hs
index 5f269fa55..3c81f4bc7 100644
--- a/src/Handler/Utils/SheetType.hs
+++ b/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)
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index d71bb96ef..836c8d913 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/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
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index a0788810f..fbcf54a14 100644
--- a/src/Import/NoModel.hs
+++ b/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)
diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs
index 5d4a78ec8..06e0073c2 100644
--- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs
+++ b/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))
diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs
index c14b1fb91..b53180bee 100644
--- a/src/Jobs/Handler/SendNotification/Utils.hs
+++ b/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))
diff --git a/src/Model.hs b/src/Model.hs
index 67cb6c01a..b8e4c22d9 100644
--- a/src/Model.hs
+++ b/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
diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs
index 27b11df1c..8fc1ae10d 100644
--- a/src/Model/Migration/Definitions.hs
+++ b/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
diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs
index 0c185750e..3435094c7 100644
--- a/src/Model/Migration/Types.hs
+++ b/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 {..}
diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs
index c0a89ec82..3069284f5 100644
--- a/src/Model/Rating.hs
+++ b/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
diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs
index f2349bd29..76588cb08 100644
--- a/src/Model/Types/Exam.hs
+++ b/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
diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs
index b8eb81ff7..4e115f056 100644
--- a/src/Model/Types/Sheet.hs
+++ b/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 Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps }
-sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps }
-sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
-sheetTypeSum NotGraded _ = mempty { numNotGraded = Sum 1 }
+sheetTypeSum :: forall epid. Ord epid => SheetType epid -> Maybe Points -> SheetTypeSummary epid
+sheetTypeSum Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps }
+sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps }
+sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
+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
diff --git a/src/Utils.hs b/src/Utils.hs
index e902199f0..feeaa9adc 100644
--- a/src/Utils.hs
+++ b/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 --
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 51cfefe0f..33c6dff44 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -161,6 +161,8 @@ makeLenses_ ''SubmissionGroup
makeLenses_ ''SheetGrading
+makeLenses_ ''Sheet
+
makePrisms ''SheetGroup
makePrisms ''AuthResult
diff --git a/src/Utils/Workflow/Lint.hs b/src/Utils/Workflow/Lint.hs
index df1937c5a..581ebaa4e 100644
--- a/src/Utils/Workflow/Lint.hs
+++ b/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
diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet
index 1620eefd1..6d96d7fea 100644
--- a/templates/correction-user.hamlet
+++ b/templates/correction-user.hamlet
@@ -17,11 +17,11 @@
$case grading
$of Points{..}
- | _{sheetType}
+ | ^{sheetTypeDesc tr}
| _{MsgAchievedOf points maxPoints}
$of PassPoints{..}
|
- | _{sheetType}
+ | ^{sheetTypeDesc tr}
|
$if fromMaybe False (gradingPassed grading points)
_{MsgPassed}
@@ -32,7 +32,7 @@
| _{MsgPassAchievedOf points passingPoints maxPoints}
$of PassBinary
|
- | _{sheetType}
+ | ^{sheetTypeDesc tr}
|
$if fromMaybe False (gradingPassed grading points)
_{MsgPassed}
diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet
index 4c99a4a83..79fc2dc91 100644
--- a/templates/exam-show.hamlet
+++ b/templates/exam-show.hamlet
@@ -260,11 +260,11 @@ $if not (null occurrences)
|
-$if gradingShown && not (null examParts)
+$if (gradingShown || partsShown) && not (null examParts)
_{MsgExamParts}
- $if gradingShown && not gradingVisible
+ $if (gradingShown && not gradingVisible) || (partsShown && not partsVisible)
\ ^{isVisible False}
@@ -273,13 +273,15 @@ $if gradingShown && not (null examParts)
|
_{MsgExamPartNumber} ^{isVisible False}
| _{MsgExamPartName}
+ $if showPartSheets
+ | _{MsgExamPartSheets}
$if showMaxPoints
| _{MsgExamPartMaxPoints}
$if showAchievedPoints
| _{MsgExamPartResultPoints}
|
- $forall Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints} <- examParts
-
+ $forall (Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints}, cID, partSheets) <- examParts
+
$if partNumbersShown
| #{examPartNumber}
|
@@ -287,6 +289,14 @@ $if gradingShown && not (null examParts)
#{pName}
$nothing
_{MsgExamPartNumbered examPartNumber}
+ $if showPartSheets
+ |
+ $if not (null partSheets)
+ | |