From 73bd8bf9f0cbdeb86ecf0275f7560b8832f36aaa Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 31 Oct 2018 15:48:34 +0100 Subject: [PATCH 1/6] Fixes #222 --- messages/uniworx/de.msg | 1 + src/Foundation.hs | 9 +++++++++ src/Handler/Corrections.hs | 4 +++- src/Handler/Utils/Form.hs | 3 +++ templates/sheetShow.hamlet | 2 +- 5 files changed, 17 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4b7c8a3b0..7c03d6713 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 diff --git a/src/Foundation.hs b/src/Foundation.hs index cd09b4ad8..dc350557d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -228,6 +228,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 9e2285d40..7e4247d19 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -486,7 +486,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/Utils/Form.hs b/src/Handler/Utils/Form.hs index cc3d146fc..9fc3a8daf 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -193,6 +193,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 diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 9efdc5e24..7776c0bc8 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -18,7 +18,7 @@ $maybe descr <- sheetDescription sheet
_{MsgSheetSolutionFrom}
#{solution}
_{MsgSheetType} -
_{sheetType sheet} +
_{SheetTypeComplete (sheetType sheet)} $if CorrectorSubmissions == sheetSubmissionMode sheet
_{MsgSheetPseudonym}
From d6ef0c1b651e89964c3839fbd5c1a590b30a9ca0 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 31 Oct 2018 17:07:19 +0100 Subject: [PATCH 2/6] Tooltips clarifying sheetTypes and sheetGrading at sheet creation --- messages/uniworx/de.msg | 2 ++ src/Handler/Sheet.hs | 3 ++- src/Handler/Utils/Form.hs | 3 ++- src/Model/Types.hs | 23 ++++++++++++++++++----- 4 files changed, 24 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7c03d6713..548904e49 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -356,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 @@ -365,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 nicht angerechnet, eine Punktangabe dient dort nur zur Rückmeldung an die Teilnehmer. SheetTypeBonus': Bonus SheetTypeNormal': Normal diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 0a25a30a6..9870665f2 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -102,7 +102,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) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 9fc3a8daf..c30458e16 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -391,7 +391,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/Model/Types.hs b/src/Model/Types.hs index acd08a9a6..5dabaed5b 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -132,6 +132,16 @@ 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 + +getPassPoints :: SheetGrading -> Points +getPassPoints PassPoints {..} = passingPoints +getPassPoints _ = 0 + + data SheetType = Bonus { grading :: SheetGrading } @@ -152,6 +162,7 @@ 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) @@ -164,12 +175,14 @@ instance Monoid SheetTypeSummary where sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary -sheetTypeSum = error "TODO sheetTypeSum" +-- sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum $ fromMaybe 0 (grading ^? _maxPoints), achievedBonus = Sum <$> achieved } +sheetTypeSum = error "TODO" {- -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 (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 } -} data SheetGroup From af77f1cab3c14cf683fd892365825797d13880d7 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 1 Nov 2018 16:04:46 +0100 Subject: [PATCH 3/6] Fixes #222. Fixes #213. Bug with Summary-Display (not summing up properly). --- messages/uniworx/de.msg | 2 +- src/Handler/Sheet.hs | 6 +-- src/Handler/Utils/Table/Cells.hs | 3 ++ src/Model/Types.hs | 61 ++++++++++++----------- src/Utils.hs | 8 +++ templates/widgets/sheetTypeSummary.hamlet | 56 ++++++++++++--------- 6 files changed, 79 insertions(+), 57 deletions(-) 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. + From e4e5b543a57176b2f7178c04e2619f318dfc8cf2 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 1 Nov 2018 17:01:40 +0100 Subject: [PATCH 4/6] Workaround for unfixed issue #223 --- src/Handler/Sheet.hs | 18 ++++++- templates/widgets/sheetTypeSummary.hamlet | 65 ++++++++++++----------- 2 files changed, 52 insertions(+), 31 deletions(-) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c0dc152d1..dec893ce7 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -200,7 +200,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/templates/widgets/sheetTypeSummary.hamlet b/templates/widgets/sheetTypeSummary.hamlet index f74f5dccf..4a86f9a34 100644 --- a/templates/widgets/sheetTypeSummary.hamlet +++ b/templates/widgets/sheetTypeSummary.hamlet @@ -1,33 +1,38 @@ $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. - +
    + $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. + From 9aaee52ce12f3d80fdc36c4496fe3a1939e6feba Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 2 Nov 2018 12:20:43 +0100 Subject: [PATCH 5/6] BUGFIX: sort corrections by assigned time (undefined sortColumn) --- src/Handler/Corrections.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 7e4247d19..743bee3c1 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -238,6 +238,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" From a29b0eac03ce5fb75147fbaf5ff6be5bae1e2a25 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 2 Nov 2018 14:11:13 +0100 Subject: [PATCH 6/6] Add some missing form actions --- templates/correction.hamlet | 4 ++-- templates/corrections-upload.hamlet | 2 +- templates/corrections.hamlet | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) 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}