diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 08b5f9561..f6d38f8fb 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -391,7 +391,8 @@ SheetTypeNormal grading@SheetGrading: Normal SheetTypeInformational grading@SheetGrading: Keine Wertung SheetTypeNotGraded: Unbewertet SheetTypeInfo: Bonus Blätter zählen normal, 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. -SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den normalen Punkten hinzugezählt. +SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt. +SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben/Blätter SheetTypeBonus': Bonus SheetTypeNormal': Normal diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 6a95e29dc..ab625a903 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -102,6 +102,10 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet) shn = sheetName $ entityVal sheet in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] +colSheetType :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) + $ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet + colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty @@ -383,23 +387,6 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = let route = CSubmissionR tid ssh csh shn cID SAssignR (== Authorized) <$> evalAccessDB route True -gradeSummaryWidget :: SheetTypeSummary -> Widget -gradeSummaryWidget sts = - let SheetTypeSummary{..} = addBonusToPoints sts - sumSummaries = (normalSummary <> bonusSummary <> informationalSummary) -- # _numSheets %~ (<> numNotGraded) - hasPassings = positiveSum $ numGradePasses sumSummaries - hasPoints = positiveSum $ sumGradePoints sumSummaries - rowWdgts = [ $(widgetFile "widgets/gradingSummaryRow") - | (sumHeader,summary) <- - [ (MsgSheetTypeNormal' ,normalSummary) - , (MsgSheetTypeBonus' ,bonusSummary) - , (MsgSheetTypeInformational' ,informationalSummary) - ] ] - in if 0 == numSheets sumSummaries - then mempty - else $(widgetFile "widgets/gradingSummary") - - type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) downloadAction :: ActionCorrections' @@ -448,6 +435,7 @@ postCorrectionsR = do , colAssigned , colRating , colRated + , colSheetType ] -- Continue here psValidator = def & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information @@ -468,6 +456,7 @@ postCCorrectionsR tid ssh csh = do , colSMatrikel , colSubmittors , colSubmissionLink + , colSheetType , colRating , colRated , colCorrector @@ -782,6 +771,7 @@ postCorrectionsGradeR = do , colSheet , colPseudonyms , colSubmissionLink + , colSheetType , colRated , colRatedField , colPointsField diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 371354fe2..bb6e551d5 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -41,7 +41,7 @@ import qualified Data.Map as Map import Data.Map (Map, (!?)) -import Data.Monoid (Sum(..), Any(..)) +import Data.Monoid (Any(..)) -- import Control.Lens import Utils.Lens @@ -152,7 +152,8 @@ getSheetListR tid ssh csh = do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return (sheet, lastSheetEdit sheet, submission) sheetCol = widgetColonnade . mconcat $ - [ sortable (Just "name") (i18nCell MsgSheet) + [ -- TODO: dbRow add numbers + sortable (Just "name") (i18nCell MsgSheet) $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) , sortable (Just "last-edit") (i18nCell MsgLastEdit) $ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime @@ -228,7 +229,7 @@ getSheetListR tid ssh csh = do , dbtIdent = "sheets" :: Text } -- Collect summary over all Sheets, not just the ones shown due to pagination: - SheetTypeSummary{..} <- do + statistics <- gradeSummaryWidget <$> 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 @@ -236,7 +237,6 @@ getSheetListR tid ssh csh = do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows - let statistics = $(widgetFile "widgets/sheetTypeSummary") defaultLayout $ do $(widgetFile "sheetList") diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index be259344f..6cffb948d 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -12,6 +12,7 @@ module Handler.Utils.Rating , parseRating , SubmissionContent , extractRatings + , gradeSummaryWidget ) where import Import @@ -32,6 +33,8 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString.Lazy as Lazy.ByteString +import Data.Monoid (Sum(..)) + import Text.Read (readEither) import System.FilePath @@ -51,7 +54,7 @@ instance Pretty x => Pretty (CI x) where pretty = pretty . CI.original -instance Pretty SheetGrading where +instance Pretty SheetGrading where pretty Points{..} = pretty ( show maxPoints <> " Punkte" :: String) pretty PassPoints{..} = pretty ( show maxPoints <> " Punkte, bestanden ab " <> show passingPoints <> " Punkte" :: String ) pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String ) @@ -59,12 +62,12 @@ instance Pretty SheetGrading where validateRating :: SheetType -> Rating' -> [RatingException] validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..} - | rp < 0 - = [RatingNegative] - | NotGraded <- ratingSheetType + | rp < 0 + = [RatingNegative] + | NotGraded <- ratingSheetType = [RatingNotExpected] | (Just maxPoints ) <- ratingSheetType ^? _grading . _maxPoints - , rp > maxPoints + , rp > maxPoints = [RatingExceedsMax] | (Just PassBinary) <- ratingSheetType ^? _grading , not (rp == 0 || rp == 1) @@ -98,7 +101,7 @@ getRating submissionId = runMaybeT $ do , E.unValue -> ratingComment , E.unValue -> ratingTime ) ] <- lift query - + return Rating{ ratingValues = Rating'{..}, .. } formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString @@ -199,3 +202,35 @@ isRatingFile' (takeFileName -> fName) = Just cID | otherwise = Nothing + +-- 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 + +gradeSummaryWidget :: SheetTypeSummary -> Widget +gradeSummaryWidget sts = + let SheetTypeSummary{..} = addBonusToPoints sts + sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded) + hasPassings = positiveSum $ numGradePasses sumSummaries + hasPoints = positiveSum $ sumGradePoints sumSummaries + rowWdgts = [ $(widgetFile "widgets/gradingSummaryRow") + | (sumHeader,summary) <- + [ (MsgSheetTypeNormal' ,normalSummary) + , (MsgSheetTypeBonus' ,bonusSummary) + , (MsgSheetTypeInformational' ,informationalSummary) + ] ] + in if 0 == numSheets sumSummaries + then mempty + else $(widgetFile "widgets/gradingSummary") diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 3c5155842..808ad04af 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -183,7 +183,7 @@ instance Default (PSValidator m x) where Just pi -> swap . (\act -> execRWS act pi def) $ do asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s }) asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f }) - + l <- asks piLimit case l of Just l' @@ -258,7 +258,7 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) data DBCell m x :: * dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget) - + -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x) -- | Format @DBTable@ when sort-circuiting dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget @@ -284,7 +284,7 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where dbCell = iso (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents)) (uncurry WidgetCell) - + -- dbWidget Proxy Proxy = iso (, ()) $ view _1 dbWidget _ _ = return . snd dbHandler _ _ f = return . over _2 f @@ -331,7 +331,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc dbCell = iso (\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents)) (\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget) - + -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi @@ -353,10 +353,10 @@ addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragmen instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where mempty = FormCell mempty (return mempty) (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c') - + instance IsDBTable m a => IsString (DBCell m a) where fromString = cell . fromString - + dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x) dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do @@ -378,7 +378,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , fieldView = error "multiTextField: should not be rendered" , fieldEnctype = UrlEncoded } - + piResult <- lift . runInputGetResult $ PaginationInput <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) @@ -571,6 +571,7 @@ formCell genIndex genForm input = FormCell -- Predefined colonnades +--Number column? dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index b4c18b801..c7b4e910f 100644 --- a/src/Model/Rating.hs +++ b/src/Model/Rating.hs @@ -2,8 +2,6 @@ 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) @@ -36,19 +34,3 @@ 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/templates/widgets/gradingSummary.hamlet b/templates/widgets/gradingSummary.hamlet index 3967a8f37..544651caf 100644 --- a/templates/widgets/gradingSummary.hamlet +++ b/templates/widgets/gradingSummary.hamlet @@ -1,6 +1,7 @@ $# Displays gradings Summary for various purposes $# --
| @@ -23,7 +24,9 @@ $# -- | #{display nrNoGrade}
$maybe _ <- positiveSum $ bonusSummary ^. _numSheets
_{MsgSheetTypeInfo} - _{MsgSheetGradingBonusIncluded} + $maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints) + _{MsgSheetGradingBonusIncluded} $nothing + $#TODO: MsgSheetTypeInfo into part about Bonus and about Informational $maybe _ <- positiveSum $ informationalSummary ^. _numSheets _{MsgSheetTypeInfo} \ No newline at end of file |
|---|