diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 548904e49..b131bc5ab 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -366,7 +366,7 @@ SheetTypeBonus grading@SheetGrading: Bonus SheetTypeNormal grading@SheetGrading: Normal SheetTypeInformational grading@SheetGrading: Keine Wertung SheetTypeNotGraded: Unbewertet -SheetTypeInfo: Bonus Blätter zählen, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter. Blätter ohne Wertung werden nirgends nicht angerechnet, eine Punktangabe dient dort nur zur Rückmeldung an die Teilnehmer. +SheetTypeInfo: Bonus Blätter zählen, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter. Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer. SheetTypeBonus': Bonus SheetTypeNormal': Normal diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 9870665f2..c0dc152d1 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -167,7 +167,7 @@ getSheetListR tid ssh csh = do , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo , sortable Nothing (i18nCell MsgSheetType) - $ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType + $ \(Entity _ Sheet{..}, _, _) -> i18nCell $ SheetTypeComplete sheetType , sortable Nothing (i18nCell MsgSubmission) $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of Nothing -> mempty @@ -186,8 +186,8 @@ getSheetListR tid ssh csh = do cid <- mkCid return $ CSubmissionR tid ssh csh sheetName cid CorrectionR protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating") - in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints))) - , sortable Nothing -- (Just "percent") + in protoCell & cellContents %~ (<* tell (sheetTypeSum sheetType submissionRatingPoints)) + , sortable Nothing -- (Just "percent") (i18nCell MsgRatingPercent) $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) -> diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 8b7da8308..728c91a83 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -83,6 +83,9 @@ sheetCell crse shn = link= CSheetR tid ssh csh shn SShowR in anchorCell link $ display2widget shn +sheetTypeCell :: IsDBTable m a => SheetType -> DBCell m a +sheetTypeCell st = i18nCell $ SheetTypeComplete st + submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a submissionCell crse shn sid = let tid = crse ^. _1 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 5dabaed5b..396c26bbb 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -132,20 +132,34 @@ gradingPassed (Points {}) _ = Nothing gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints gradingPassed (PassBinary {}) pts = Just $ pts /= 0 --- just for SheetTypeSummary (no lenses available here?!) -getMaxPoints :: SheetGrading -> Points -getMaxPoints PassBinary = 0 -getMaxPoints other = maxPoints other +data SheetGradeSummary = SheetGradeSummary + { sumGradePoints :: Sum Points + , numGradePasses :: Sum Int + , achievedPoints :: Maybe (Sum Points) + , achievedPasses :: Maybe (Sum Int) +} deriving (Generic) -getPassPoints :: SheetGrading -> Points -getPassPoints PassPoints {..} = passingPoints -getPassPoints _ = 0 +instance Monoid SheetGradeSummary where + mempty = memptydefault + mappend = mappenddefault +instance Semigroup SheetGradeSummary where + (<>) = mappend -- remove for GHC > 8.4.x +sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary +sheetGradeSum gr (Just p) = + let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p } + in case gr of PassBinary -> baseSum + _other -> baseSum { achievedPoints = Just $ Sum $ p } +sheetGradeSum (Points {..}) Nothing = mempty { sumGradePoints = Sum maxPoints } +sheetGradeSum (PassPoints{..}) Nothing = mempty { sumGradePoints = Sum maxPoints + , numGradePasses = Sum 1 } +sheetGradeSum (PassBinary) Nothing = mempty { numGradePasses = Sum 1 } + data SheetType - = Bonus { grading :: SheetGrading } - | Normal { grading :: SheetGrading } + = Normal { grading :: SheetGrading } + | Bonus { grading :: SheetGrading } | Informational { grading :: SheetGrading } | NotGraded deriving (Eq, Read, Show) @@ -157,33 +171,20 @@ deriveJSON defaultOptions } ''SheetType derivePersistFieldJSON ''SheetType - data SheetTypeSummary = SheetTypeSummary - { sumBonusPoints :: Sum Points - , sumNormalPoints :: Sum Points - , numPassSheets :: Sum Int - , numPassBonus :: Sum Int - , numNotGraded :: Sum Int - , achievedBonus :: Maybe (Sum Points) - , achievedNormal :: Maybe (Sum Points) - , achievedPasses :: Maybe (Sum Int) + { normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary + , numNotGraded :: Sum Int } deriving (Generic) instance Monoid SheetTypeSummary where - mempty = memptydefault + mempty = memptydefault mappend = mappenddefault - -sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary --- sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum $ fromMaybe 0 (grading ^? _maxPoints), achievedBonus = Sum <$> achieved } -sheetTypeSum = error "TODO" -{- -sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum $ getMaxPoints grading - , achievedBonus = Sum <$> achieved } -sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum $ getMaxPoints grading, achievedNormal = Sum <$> achieved } -sheetTypeSum (Informational{..}, achieved) = mempty { } -sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 } --} +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 } data SheetGroup = Arbitrary { maxParticipants :: Natural } diff --git a/src/Utils.hs b/src/Utils.hs index a95c79722..2c10470a6 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -8,6 +8,7 @@ import ClassyPrelude.Yesod -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import Data.Foldable as Fold hiding (length) +import Data.Monoid (Sum(..)) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -302,6 +303,13 @@ ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argu ifMaybeM Nothing dft _ = return dft ifMaybeM (Just x) _ act = act x +maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if +maybePositive a | a > 0 = Just a + | otherwise = Nothing + +positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive +positiveSum (Sum x) = maybePositive x + maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM dft act mb = mb >>= maybe dft act diff --git a/templates/widgets/sheetTypeSummary.hamlet b/templates/widgets/sheetTypeSummary.hamlet index 581dc0791..f74f5dccf 100644 --- a/templates/widgets/sheetTypeSummary.hamlet +++ b/templates/widgets/sheetTypeSummary.hamlet @@ -1,23 +1,33 @@ -
- $if 0 < getSum sumNormalPoints - Gesamtpunktzahl #{display (getSum sumNormalPoints)} - $maybe nPts <- (maybeAdd (getSum <$> achievedNormal) (getSum <$> achievedBonus)) - \ davon #{display nPts} erreicht - $maybe bPts <- getSum <$> achievedBonus - \ (inklusive #{display bPts} # - $if 0 < getSum sumBonusPoints - von #{display $ getSum sumBonusPoints} erreichbaren # - Bonuspunkten) - \ #{textPercent $ realToFrac $ nPts / (getSum sumNormalPoints)} - - -
- $if 0 < getSum numPassSheets - Blätter zum Bestehen: #{display (getSum numPassSheets)} - $maybe passed <- getSum <$> achievedPasses - \ davon #{display passed} bestanden. - -
- $if 0 < getSum numNotGraded - Unbewertet: #{display (getSum numNotGraded)} Blätter - +$with realGrades <- normalSummary <> bonusSummary + $with allGrades <- realGrades <> informationalSummary +
+ $maybe realPoints <- positiveSum (sumGradePoints realGrades) + Gesamtpunktzahl #{display realPoints} + $maybe nPts <- getSum <$> achievedPoints realGrades + \ davon #{display nPts} erreicht + $maybe bPts <- getSum <$> achievedPoints bonusSummary + \ (inklusive #{display bPts} # + $maybe achievedBonus <- positiveSum (sumGradePoints bonusSummary) + von #{display achievedBonus} erreichbaren # + Bonuspunkten) + \ #{textPercent $ realToFrac $ nPts / realPoints} + $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary) + Hinweis: + \ #{display fakePoints} Punkte gab es für Aufgabenblätter, # + welche nicht gewertet wurden, sondern nur informativen Charakter besitzen + $maybe achievedFakes <- getSum <$> achievedPoints informationalSummary + , davon wurden #{display achievedFakes} erreicht + \ #{textPercent $ realToFrac $ achievedFakes / fakePoints} + . +
+ $maybe reqPasses <- positiveSum (numGradePasses normalSummary) + Aufgaben zum Bestehen: #{display reqPasses} + $maybe passed <- getSum <$> achievedPasses realGrades + \ davon #{display passed} bestanden + $maybe bonusPassed <- getSum <$> achievedPasses bonusSummary + \ (inklusive #{display bonusPassed} Bonusaufgaben) + . +
+ $maybe noGradeSheets <- positiveSum numNotGraded + #{display noGradeSheets} unbewertete Aufgabenblätter. +