diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 9f3625c7e..8b60430d0 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -1,4 +1,4 @@ -{ +{ "version": "2.0.0", "tasks": [ { @@ -11,7 +11,7 @@ }, "presentation": { "echo": true, - "reveal": "silent", + "reveal": "always", "focus": false, "panel": "dedicated", "showReuseMessage": false diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 86c1d0cd5..cbc27001c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -379,7 +379,9 @@ SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tsh SheetGradingPassBinary: Bestanden/Nicht Bestanden SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. +SheetGradingCount': Anzahl SheetGradingPoints': Punkte +SheetGradingPassing': Bestehen SheetGradingPassPoints': Bestehen nach Punkten SheetGradingPassBinary': Bestanden/Nicht bestanden diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 34322b942..fb124c041 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -360,12 +360,12 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) redirect currentRoute - SheetTypeSummary{..} <- runDB $ do + gradingSummary <- runDB $ do let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime) points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn [] return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points - let statistics = $(widgetFile "widgets/sheetTypeSummary") + let statistics = $(widgetFile "widgets/gradingSummary") fmap toTypedContent . defaultLayout $ do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") @@ -383,6 +383,11 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = let route = CSubmissionR tid ssh csh shn cID SAssignR (== Authorized) <$> evalAccessDB route True +gradeSummaryWidget :: SheetTypeSummary -> Widget UniWorX IO () +gradeSummaryWidget sts = undefined + + + type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) downloadAction :: ActionCorrections' diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index 6ce7760f5..b4c18b801 100644 --- a/src/Model/Rating.hs +++ b/src/Model/Rating.hs @@ -2,7 +2,8 @@ module Model.Rating where import ClassyPrelude.Yesod import Model - +import Utils +import Control.Lens -- import Data.Text (Text) import Data.Text.Encoding.Error (UnicodeException(..)) import GHC.Generics (Generic) @@ -35,3 +36,19 @@ data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to p deriving (Show, Eq, Generic, Typeable) instance Exception RatingException + +-- TODO: maybe move elsewhere, but Model is a bit overful already +addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary +addBonusToPoints sts = + sts & _normalSummary . _achievedPoints %~ maxBonusPts . addBonusPts + & _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass + where + bonusPoints = sts ^. _bonusSummary . _achievedPoints + maxPoints = sts ^. _normalSummary . _sumGradePoints + maxBonusPts = fmap $ min maxPoints + addBonusPts = maybeAdd bonusPoints + + bonusPasses = sts ^. _bonusSummary . _achievedPasses + maxPasses = sts ^. _normalSummary . _numGradePasses + maxBonusPass = fmap $ min maxPasses + addBonusPass = maybeAdd bonusPasses diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 186bced96..f92babd87 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -121,10 +121,10 @@ data SheetGrading | PassBinary -- non-zero means passed deriving (Eq, Read, Show) -deriveJSON defaultOptions +deriveJSON defaultOptions { constructorTagModifier = intercalate "-" . map toLower . splitCamel , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , sumEncoding = TaggedObject "type" "data" + , sumEncoding = TaggedObject "type" "data" } ''SheetGrading derivePersistFieldJSON ''SheetGrading @@ -133,59 +133,74 @@ gradingPassed (Points {}) _ = Nothing gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints gradingPassed (PassBinary {}) pts = Just $ pts /= 0 -data SheetGradeSummary = SheetGradeSummary - { sumGradePoints :: Sum Points +data SheetGradeSummary = SheetGradeSummary + { numSheets :: Sum Int , numGradePasses :: Sum Int - , achievedPoints :: Maybe (Sum Points) + , sumGradePoints :: Sum Points , achievedPasses :: Maybe (Sum Int) -} deriving (Generic) + , achievedPoints :: Maybe (Sum Points) +} deriving (Generic, Show) -- TODO: Show added for Debugging only instance Monoid SheetGradeSummary where mempty = memptydefault mappend = mappenddefault -instance Semigroup SheetGradeSummary where - (<>) = mappend -- remove for GHC > 8.4.x +instance Semigroup SheetGradeSummary where + (<>) = mappend -- TODO: 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 } +makeLenses_ ''SheetGradeSummary + +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 } - +sheetGradeSum (Points {..}) Nothing = mempty { numSheets = Sum 1 + , sumGradePoints = Sum maxPoints + } +sheetGradeSum (PassPoints{..}) Nothing = mempty { numSheets = Sum 1 + , numGradePasses = Sum 1 + , sumGradePoints = Sum maxPoints + } +sheetGradeSum (PassBinary) Nothing = mempty { numSheets = Sum 1 + , numGradePasses = Sum 1 + } -data SheetType +data SheetType = Normal { grading :: SheetGrading } | Bonus { grading :: SheetGrading } | Informational { grading :: SheetGrading } | NotGraded - deriving (Eq, Read, Show) + deriving (Eq, Read, Show) deriveJSON defaultOptions { constructorTagModifier = intercalate "-" . map toLower . splitCamel , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel - , sumEncoding = TaggedObject "type" "data" + , sumEncoding = TaggedObject "type" "data" } ''SheetType derivePersistFieldJSON ''SheetType data SheetTypeSummary = SheetTypeSummary - { normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary - , numNotGraded :: Sum Int - } deriving (Generic) + { normalSummary + , bonusSummary + , informationalSummary :: SheetGradeSummary + , numNotGraded :: Sum Int + } deriving (Generic, Show) -- TODO: Show added for Debugging only instance Monoid SheetTypeSummary where mempty = memptydefault mappend = mappenddefault +instance Semigroup SheetTypeSummary 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 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 a451eb70b..f9d897630 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -185,6 +185,9 @@ textPercent x = lz <> pack (show rx) <> "%" rx = fromIntegral (round' $ 1000.0*x) / 10.0 lz = if rx < 10.0 then "0" else "" +textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? +textPercentInt part whole = textPercent $ (fromIntegral part) / (fromIntegral whole) + stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes stepTextCounterCI = CI.map stepTextCounter @@ -289,14 +292,13 @@ toNothing = const Nothing toNothingS :: String -> Maybe b toNothingS = const Nothing -maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap +maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap maybeAdd (Just x) (Just y) = Just (x + y) maybeAdd Nothing y = y maybeAdd x Nothing = x maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m -maybeEmpty (Just x) f = f x -maybeEmpty Nothing _ = mempty +maybeEmpty = flip foldMap whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x @@ -311,7 +313,7 @@ maybePositive a | a > 0 = Just a | otherwise = Nothing positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive -positiveSum (Sum x) = maybePositive x +positiveSum = maybePositive . getSum maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM dft act mb = mb >>= maybe dft act @@ -341,7 +343,6 @@ instance Ord a => Ord (NTop (Maybe a)) where compare (NTop (Just x)) (NTop (Just y)) = compare x y - ------------ -- Either -- ------------ diff --git a/templates/widgets/gradingSummary.hamlet b/templates/widgets/gradingSummary.hamlet new file mode 100644 index 000000000..7f0bd786f --- /dev/null +++ b/templates/widgets/gradingSummary.hamlet @@ -0,0 +1,35 @@ +$# Displays gradings Summary for various purposes +$# -- +$with SheetTypeSummary{..} <- addBonusToPoints gradingSummary + $with sumSummaries <- mappend normalSummary (mappend bonusSummary informationalSummary) + $with hasPassings <- positiveSum $ numGradePasses sumSummaries + $with hasPoints <- positiveSum $ sumGradePoints sumSummaries +
+ + + + +
+ $# empty cell for row headers + $maybe _ <- hasPassings + _{MsgSheetGradingPassing'} + $maybe _ <- hasPoints + _{MsgSheetGradingPoints'} + _{MsgSheetGradingCount'} + $# Number of Sheet/Submissions used for calculating maximum passes/points + $with sumHeader <- MsgSheetTypeNormal' + $with summary <- normalSummary + ^{gradingSummaryRow} + $# $for (sumHeader, summary) <- [(MsgSheetTypeNormal',normalSummary),(MsgSheetTypeBonus',bonusSummary),(MsgSheetTypeInformational',informationalSummary)] + $# ^{gradingSummaryRow} + DEBUG + $maybe nrNoGrade <- positiveSum $ numNotGraded +
_{MsgSheetTypeNotGraded} + $maybe _ <- hasPassings + + $maybe _ <- hasPoints + + #{display nrNoGrade} + $maybe _ <- positiveSum $ bonusSummary ^. _numSheets +

_{MsgSheetTypeInfo} + $nothing +

_{MsgSheetTypeInfo} \ No newline at end of file diff --git a/templates/widgets/gradingSummaryRow.hamlet b/templates/widgets/gradingSummaryRow.hamlet new file mode 100644 index 000000000..46e4375bb --- /dev/null +++ b/templates/widgets/gradingSummaryRow.hamlet @@ -0,0 +1,33 @@ +$# Displays one row of the grading summary +$# Expects several variables: +$# hasPassing :: Maybe Int -- Should Passing be displayed? +$# hasPoints :: Maybe Poibts -- Should Points be displayed? +$# summary :: SheetGradeSummary -- summary to display +$# sumHeader :: UniWorXMessage -- row header +$# + $maybe nrSheets <- positiveSum $ summary ^. _numSheets +

_{sumHeader} + $maybe _ <- hasPassings + $with Sum pmax <- sumHeader ^. _numGradePasses + $maybe Sum pacv <- summary ^. _achievedPasses + + $if pmax /= 0 + #{textPercentInt pacv pmax} + + #{display pacv} / #{display pmax} + $nothing + + #{display pmax } + $maybe _ <- hasPoints + $with Sum pmax <- sumHeader ^. _sumGradePoints + $maybe Sum pacv <- summary ^. _achievedPoints + + $if pmax /= 0 + #{textPercent $ realToFrac $ pacv / pmax} + + #{display pacv} / #{display pmax} + $nothing + + #{display pmax } + #{display nrSheets} \ No newline at end of file diff --git a/templates/widgets/sheetTypeSummary.hamlet b/templates/widgets/sheetTypeSummary.hamlet index 62572e5e5..8609b82b2 100644 --- a/templates/widgets/sheetTypeSummary.hamlet +++ b/templates/widgets/sheetTypeSummary.hamlet @@ -1,3 +1,4 @@ +$# DEPRECATED IN FAVOUR OF widgets/gradingSummary.hamlet DO NOT USE !!! $with realGrades <- normalSummary <> bonusSummary $# $with allGrades <- realGrades <> informationalSummary