Merge branch 'feat/exam-sheets'
This commit is contained in:
Gregor Kleen
commit
4061fb5c3a
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
15
src/Control/Arrow/Instances.hs
Normal file
15
src/Control/Arrow/Instances.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -48,6 +48,7 @@ postEEditR tid ssh csh examn = do
|
||||
, examDescription = efDescription
|
||||
, examExamMode = efExamMode
|
||||
, examStaff = efStaff
|
||||
, examPartsFrom = efPartsFrom
|
||||
}
|
||||
|
||||
when (is _Nothing insertRes) $ do
|
||||
|
||||
@ -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
|
||||
|
||||
@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do
|
||||
, examDescription = efDescription
|
||||
, examExamMode = efExamMode
|
||||
, examStaff = efStaff
|
||||
, examPartsFrom = efPartsFrom
|
||||
}
|
||||
whenIsJust insertRes $ \examid -> do
|
||||
insertMany_
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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'
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 {..}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
30
src/Utils.hs
30
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 --
|
||||
|
||||
@ -161,6 +161,8 @@ makeLenses_ ''SubmissionGroup
|
||||
|
||||
makeLenses_ ''SheetGrading
|
||||
|
||||
makeLenses_ ''Sheet
|
||||
|
||||
makePrisms ''SheetGroup
|
||||
|
||||
makePrisms ''AuthResult
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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
|
||||
<tr .table__row>
|
||||
$forall (Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints}, cID, partSheets) <- examParts
|
||||
<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
|
||||
|
||||
2
templates/i18n/changelog/exam-sheets.de-de-formal.hamlet
Normal file
2
templates/i18n/changelog/exam-sheets.de-de-formal.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Übungsblätter können nun „als Prüfungsaufgabe“ bewertet werden.
|
||||
2
templates/i18n/changelog/exam-sheets.en-eu.hamlet
Normal file
2
templates/i18n/changelog/exam-sheets.en-eu.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Exercise sheets can now be rated “as an exam part”.
|
||||
@ -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}
|
||||
|
||||
@ -66,8 +66,10 @@ $maybe descr <- sheetDescription sheet
|
||||
$nothing
|
||||
^{generateForm}
|
||||
$of _
|
||||
<dt .deflist__dt>_{MsgSheetType}
|
||||
<dd .deflist__dd>_{sheetType sheet}
|
||||
<dt .deflist__dt>
|
||||
_{MsgSheetType}
|
||||
<dd .deflist__dd>
|
||||
^{sTypeDesc tr}
|
||||
|
||||
$maybe marktxt <- markingText
|
||||
<section>
|
||||
|
||||
@ -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}
|
||||
|
||||
13
templates/widgets/sheetType.hamlet
Normal file
13
templates/widgets/sheetType.hamlet
Normal file
@ -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)}
|
||||
)
|
||||
@ -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
|
||||
NotGraded -> NotGraded'
|
||||
Normal{} -> Normal'
|
||||
Bonus{} -> Bonus'
|
||||
Informational{} -> Informational'
|
||||
sheetType' = classifySheetType sheetType
|
||||
|
||||
prog = 14 * (shNr % genericLength sheetCombinations)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance (Arbitrary epId, Ord epId) => Arbitrary (SheetTypeSummary epId) where
|
||||
arbitrary = foldMap (uncurry sheetTypeSum) <$> listOf arbitrary
|
||||
|
||||
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)
|
||||
[ eqLaws, showReadLaws, commutativeMonoidLaws ]
|
||||
lawsCheckHspec (Proxy @(SheetTypeSummary SqlBackendKey))
|
||||
[ eqLaws, showLaws, commutativeMonoidLaws ]
|
||||
lawsCheckHspec (Proxy @SheetGroup)
|
||||
[ eqLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @SheetFileType)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user