Neue Statistik nun auch für Blattübersicht

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

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

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")
 

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 
+  | rp < 0
-    = [RatingNegative] 
+    = [RatingNegative]
-  | NotGraded <- ratingSheetType 
+  | 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")

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
 

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

templates/widgets/gradingSummary.hamlet

@@ -1,6 +1,7 @@
 $# Displays gradings Summary for various purposes
 $# --
 <div>
+  <h3>_{MsgSheetGradingSummaryTitle $ getSum $ numSheets $ sumSummaries}
   <table .table .table--striped>
     <tr .table__row .table__row--head>
       <th>
@@ -23,7 +24,9 @@ $# --
         <td .table__td>#{display nrNoGrade}
   $maybe _ <- positiveSum $ bonusSummary ^. _numSheets
     <p>_{MsgSheetTypeInfo}
-    <p>_{MsgSheetGradingBonusIncluded}
+    $maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
+      <p>_{MsgSheetGradingBonusIncluded}
   $nothing
+    $#TODO: MsgSheetTypeInfo into part about Bonus and about Informational
     $maybe _ <- positiveSum $ informationalSummary ^. _numSheets
       <p>_{MsgSheetTypeInfo}