diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4b7c8a3b0..b131bc5ab 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -258,6 +258,7 @@ RatingDone: Bewertung fertiggestellt RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein +PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist ColumnRatingPointsDone: Punktzahl/Abgeschlossen Pseudonyms: Pseudonyme @@ -355,6 +356,7 @@ SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten SheetGradingPassBinary: Bestanden/Nicht Bestanden +SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. SheetGradingPoints': Punkte SheetGradingPassPoints': Bestehen nach Punkten @@ -364,6 +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 angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer. SheetTypeBonus': Bonus SheetTypeNormal': Normal diff --git a/src/Foundation.hs b/src/Foundation.hs index ca40aa24a..09aa9b86e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -221,6 +221,15 @@ embedRenderMessage ''UniWorX ''CorrectorState id embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) embedRenderMessage ''UniWorX ''SheetType ("SheetType" <>) +newtype SheetTypeComplete = SheetTypeComplete SheetType +instance RenderMessage UniWorX (SheetTypeComplete) where + renderMessage foundation ls (SheetTypeComplete st) = case st of + NotGraded -> mr NotGraded + other -> mr (grading other) <> ", " <> mr other + where + mr :: RenderMessage UniWorX msg => msg -> Text + mr = renderMessage foundation ls + newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 44c32bb50..a905b93f7 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -232,6 +232,9 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do , ( "ratingtime" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime ) + , ( "assignedtime" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned + ) ] , dbtFilter = Map.fromList [ ( "term" @@ -480,7 +483,9 @@ postCorrectionR tid ssh csh shn cid = do let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) pointsForm = case sheetType of NotGraded -> pure Nothing - _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl") (Just $ submissionRatingPoints) + _otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) + (fslpI MsgRatingPoints "Punktezahl") + (Just $ submissionRatingPoints) ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 582344a3f..e39006646 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -97,7 +97,8 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq ciField (fslI MsgSheetName) (sfName <$> template) <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) - <*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template) + <*> sheetTypeAFormReq (fslI MsgSheetType + & setTooltip MsgSheetTypeInfo) (sfType <$> template) <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) @@ -161,7 +162,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 @@ -180,8 +181,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})) -> @@ -194,7 +195,23 @@ getSheetListR tid ssh csh = do ] psValidator = def & defaultSorting [("submission-since", SortAsc)] - (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable + ------------------------------------------------------ + -- ISSUE #223 + -- The following line does not work; something is wrong with the tell in line 189 above. + -- (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable + -- + -- If fixed, remove the following workaround code: + SheetTypeSummary{..} <- do + rows <- runDB $ E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do + E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission + E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet + E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) + return $ foldMap (\(E.Value st, E.Value mbPts) -> sheetTypeSum st (join mbPts)) rows + (_, table) <- dbTable psValidator $ DBTable + -- END ISSUE #223 + ----------------------------------------------------- { dbtSQLQuery = sheetData , dbtColonnade = sheetCol , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 8f71ec0a9..4e23e11c4 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -187,6 +187,9 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific) return . fromRational $ round (sci * 100) % 100 +pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points --TODO allow fractions +pointsFieldMax Nothing = pointsField +pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField termsActiveField :: Field Handler TermId termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName @@ -382,7 +385,8 @@ sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> templa , ( Informational', Informational <$> gradingReq ) , ( NotGraded', pure NotGraded ) ] - gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading) (template >>= preview _grading) + gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading + & setTooltip MsgSheetGradingInfo) (template >>= preview _grading) classify' :: SheetType -> SheetType' classify' = \case diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 85d8571f7..76da2088f 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 acd08a9a6..396c26bbb 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -132,10 +132,34 @@ gradingPassed (Points {}) _ = Nothing gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints gradingPassed (PassBinary {}) pts = Just $ pts /= 0 +data SheetGradeSummary = SheetGradeSummary + { sumGradePoints :: Sum Points + , numGradePasses :: Sum Int + , achievedPoints :: Maybe (Sum Points) + , achievedPasses :: Maybe (Sum Int) +} deriving (Generic) + +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) @@ -147,30 +171,20 @@ deriveJSON defaultOptions } ''SheetType derivePersistFieldJSON ''SheetType - data SheetTypeSummary = SheetTypeSummary - { sumBonusPoints :: Sum Points - , sumNormalPoints :: Sum Points - , numPassSheets :: 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 = error "TODO sheetTypeSum" -{- -sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved } -sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved } -sheetTypeSum (Pass{..}, achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved} -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 9da6dbe8b..642d1876e 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 @@ -303,6 +304,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/correction.hamlet b/templates/correction.hamlet index 9c5c0ed39..d2f7934d2 100644 --- a/templates/correction.hamlet +++ b/templates/correction.hamlet @@ -2,9 +2,9 @@ ^{userCorrection}
-
+ ^{corrForm}
- + ^{uploadForm} diff --git a/templates/corrections-upload.hamlet b/templates/corrections-upload.hamlet index 7def9e44d..033eafe7c 100644 --- a/templates/corrections-upload.hamlet +++ b/templates/corrections-upload.hamlet @@ -1,2 +1,2 @@ - + ^{upload} diff --git a/templates/corrections.hamlet b/templates/corrections.hamlet index 766cda831..ae932745a 100644 --- a/templates/corrections.hamlet +++ b/templates/corrections.hamlet @@ -1,5 +1,5 @@
- + ^{table}