Fixes #222. Fixes #213. Bug with Summary-Display (not summing up properly).

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

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)))
+                in protoCell & cellContents %~ (<* tell (sheetTypeSum sheetType submissionRatingPoints))
-      , sortable Nothing -- (Just "percent")
+      , sortable Nothing -- (Just "percent") 
                         (i18nCell MsgRatingPercent)
           $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
               (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->

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

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?!)
+data SheetGradeSummary = SheetGradeSummary 
-getMaxPoints :: SheetGrading -> Points
+  { sumGradePoints :: Sum Points
-getMaxPoints PassBinary = 0
+  , numGradePasses :: Sum Int
-getMaxPoints other = maxPoints other 
+  , achievedPoints :: Maybe (Sum Points)
+  , achievedPasses :: Maybe (Sum Int)
+} deriving (Generic)
 
-getPassPoints :: SheetGrading -> Points
+instance Monoid SheetGradeSummary where
-getPassPoints PassPoints {..} = passingPoints
+  mempty  = memptydefault
-getPassPoints _ = 0
+  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
+  { normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary
-  , sumNormalPoints :: Sum Points
+  , numNotGraded  :: Sum Int
-  , numPassSheets   :: Sum Int
-  , numPassBonus    :: Sum Int
-  , numNotGraded    :: Sum Int
-  , achievedBonus   :: Maybe (Sum Points)
-  , achievedNormal  :: Maybe (Sum Points)
-  , achievedPasses  :: Maybe (Sum Int)
   } deriving (Generic)
 
 instance Monoid SheetTypeSummary where
-  mempty = memptydefault
+  mempty  = memptydefault
   mappend = mappenddefault
 
-
+sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
-sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary
+sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps } 
--- sheetTypeSum (Bonus{..},         achieved) = mempty { sumBonusPoints = Sum $ fromMaybe 0 (grading ^? _maxPoints), achievedBonus = Sum <$> achieved }
+sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps } 
-sheetTypeSum = error "TODO"
+sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } 
-{-
+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
   = Arbitrary { maxParticipants :: Natural }

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
 

templates/widgets/sheetTypeSummary.hamlet

@@ -1,23 +1,33 @@
-<div>
+$with realGrades <- normalSummary <> bonusSummary 
-  $if 0 < getSum sumNormalPoints
+  $with allGrades <- realGrades <> informationalSummary
-    Gesamtpunktzahl #{display (getSum sumNormalPoints)}
+    <div>
-    $maybe nPts <- (maybeAdd (getSum <$> achievedNormal) (getSum <$> achievedBonus))
+      $maybe realPoints <- positiveSum (sumGradePoints realGrades)      
-      \ davon #{display nPts} erreicht
+        Gesamtpunktzahl #{display realPoints}
-      $maybe bPts <- getSum <$> achievedBonus
+        $maybe nPts <- getSum <$> achievedPoints realGrades
-        \ (inklusive #{display bPts} #
+          \ davon #{display nPts} erreicht
-        $if 0 < getSum sumBonusPoints
+          $maybe bPts <- getSum <$> achievedPoints bonusSummary
-          von #{display $ getSum sumBonusPoints} erreichbaren #
+            \ (inklusive #{display bPts} #
-        Bonuspunkten)
+            $maybe achievedBonus <- positiveSum (sumGradePoints bonusSummary)
-      \ #{textPercent $ realToFrac $ nPts / (getSum sumNormalPoints)}
+              von #{display achievedBonus} erreichbaren #
-
+            Bonuspunkten)
-
+          \ #{textPercent $ realToFrac $ nPts / realPoints}    
-<div>
+      $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
-  $if 0 < getSum numPassSheets
+        <em>Hinweis: 
-    Blätter zum Bestehen: #{display (getSum numPassSheets)}
+        \ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
-    $maybe passed <- getSum <$> achievedPasses
+        welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
-      \ davon #{display passed} bestanden.
+        $maybe achievedFakes <- getSum <$> achievedPoints informationalSummary
-
+          , davon wurden #{display achievedFakes} erreicht
-<div>
+          \ #{textPercent $ realToFrac $ achievedFakes / fakePoints}    
-  $if 0 < getSum numNotGraded
+        .
-    Unbewertet: #{display (getSum numNotGraded)} Blätter
+    <div>
-
+      $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)
+          .
+    <div>
+      $maybe noGradeSheets <- positiveSum numNotGraded
+        #{display noGradeSheets} unbewertete Aufgabenblätter.
+