NO COMPILE. Templates for summaries done, but nestes does not (still) work. Duh.

.vscode/tasks.json

@@ -1,4 +1,4 @@
-{  
+{
   "version": "2.0.0",
   "tasks": [
     {
@@ -11,7 +11,7 @@
       },
       "presentation": {
         "echo": true,
-        "reveal": "silent",
+        "reveal": "always",
         "focus": false,
         "panel": "dedicated",
         "showReuseMessage": false

messages/uniworx/de.msg

@@ -379,7 +379,9 @@ SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tsh
 SheetGradingPassBinary:  Bestanden/Nicht Bestanden
 SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
 
+SheetGradingCount': Anzahl
 SheetGradingPoints': Punkte
+SheetGradingPassing': Bestehen
 SheetGradingPassPoints': Bestehen nach Punkten
 SheetGradingPassBinary': Bestanden/Nicht bestanden
 

src/Handler/Corrections.hs

@@ -360,12 +360,12 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
             addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
       redirect currentRoute
 
-  SheetTypeSummary{..} <- runDB $ do
+  gradingSummary <- runDB $ do
       let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime)
       points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints
       -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn []
       return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points
-  let statistics = $(widgetFile "widgets/sheetTypeSummary")
+  let statistics = $(widgetFile "widgets/gradingSummary")
   fmap toTypedContent . defaultLayout $ do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
@@ -383,6 +383,11 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
       let route  = CSubmissionR tid ssh csh shn cID SAssignR
       (== Authorized) <$> evalAccessDB route True
 
+gradeSummaryWidget ::  SheetTypeSummary -> Widget UniWorX IO ()
+gradeSummaryWidget sts = undefined
+
+
+
 type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
 
 downloadAction :: ActionCorrections'

src/Model/Rating.hs

@@ -2,7 +2,8 @@ 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)
@@ -35,3 +36,19 @@ 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

src/Model/Types.hs

@@ -121,10 +121,10 @@ data SheetGrading
   | PassBinary -- non-zero means passed
   deriving (Eq, Read, Show)
 
-deriveJSON defaultOptions 
+deriveJSON defaultOptions
   { constructorTagModifier = intercalate "-" . map toLower . splitCamel
   , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , sumEncoding = TaggedObject "type" "data"  
+  , sumEncoding = TaggedObject "type" "data"
   } ''SheetGrading
 derivePersistFieldJSON ''SheetGrading
 
@@ -133,59 +133,74 @@ gradingPassed (Points {}) _ = Nothing
 gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints
 gradingPassed (PassBinary {}) pts = Just $ pts /= 0
 
-data SheetGradeSummary = SheetGradeSummary 
+data SheetGradeSummary = SheetGradeSummary
-  { sumGradePoints :: Sum Points
+  { numSheets      :: Sum Int
   , numGradePasses :: Sum Int
-  , achievedPoints :: Maybe (Sum Points)
+  , sumGradePoints :: Sum Points
   , achievedPasses :: Maybe (Sum Int)
-} deriving (Generic)
+  , achievedPoints :: Maybe (Sum Points)
+} deriving (Generic, Show) -- TODO: Show added for Debugging only
 
 instance Monoid SheetGradeSummary where
   mempty  = memptydefault
   mappend = mappenddefault
 
-instance Semigroup SheetGradeSummary where 
+instance Semigroup SheetGradeSummary where
-  (<>) = mappend -- remove for GHC > 8.4.x
+  (<>) = mappend -- TODO: remove for GHC > 8.4.x
 
-sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary                                              
+makeLenses_ ''SheetGradeSummary
-sheetGradeSum gr (Just p) = 
+
-  let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p } 
+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 (Points {..})    Nothing = mempty { numSheets      = Sum 1
-sheetGradeSum (PassPoints{..}) Nothing = mempty { sumGradePoints = Sum maxPoints 
+                                                , sumGradePoints = Sum maxPoints
-                                                , numGradePasses = Sum 1 }   
+                                                }
-sheetGradeSum (PassBinary)     Nothing = mempty { numGradePasses = Sum 1 }   
+sheetGradeSum (PassPoints{..}) Nothing = mempty { numSheets      = Sum 1
-                                                                  
+                                                , numGradePasses = Sum 1
+                                                , sumGradePoints = Sum maxPoints
+                                                }
+sheetGradeSum (PassBinary)     Nothing = mempty { numSheets      = Sum 1
+                                                , numGradePasses = Sum 1
+                                                }
 
-data SheetType 
+data SheetType
   = Normal        { grading :: SheetGrading }
   | Bonus         { grading :: SheetGrading }
   | Informational { grading :: SheetGrading }
   | NotGraded
-  deriving (Eq, Read, Show) 
+  deriving (Eq, Read, Show)
 
 deriveJSON defaultOptions
   { constructorTagModifier = intercalate "-" . map toLower . splitCamel
   , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , sumEncoding = TaggedObject "type" "data"  
+  , sumEncoding = TaggedObject "type" "data"
   } ''SheetType
 derivePersistFieldJSON ''SheetType
 
 data SheetTypeSummary = SheetTypeSummary
-  { normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary
+  { normalSummary
-  , numNotGraded  :: Sum Int
+  , bonusSummary
-  } deriving (Generic)
+  , informationalSummary :: SheetGradeSummary
+  , numNotGraded :: Sum Int
+  } deriving (Generic, Show) -- TODO: Show added for Debugging only
 
 instance Monoid SheetTypeSummary where
   mempty  = memptydefault
   mappend = mappenddefault
 
+instance Semigroup SheetTypeSummary where
+  (<>) = mappend -- TODO: remove for GHC > 8.4.x
+
+makeLenses_ ''SheetTypeSummary
+
 sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
-sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps } 
+sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps }
-sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps } 
+sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps }
-sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } 
+sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
-sheetTypeSum NotGraded _           = mempty { numNotGraded = Sum 1 }
+sheetTypeSum NotGraded _           = mempty { numNotGraded         = Sum 1 }
 
 data SheetGroup
   = Arbitrary { maxParticipants :: Natural }

src/Utils.hs

@@ -185,6 +185,9 @@ textPercent x = lz <> pack (show rx) <> "%"
    rx = fromIntegral (round' $ 1000.0*x) / 10.0
    lz = if rx < 10.0 then "0" else ""
 
+textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
+textPercentInt part whole = textPercent $ (fromIntegral part) / (fromIntegral whole)
+
 stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
 stepTextCounterCI = CI.map stepTextCounter
 
@@ -289,14 +292,13 @@ toNothing = const Nothing
 toNothingS :: String -> Maybe b
 toNothingS = const Nothing
 
-maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
+maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap
 maybeAdd (Just x) (Just y) = Just (x + y)
 maybeAdd Nothing y  = y
 maybeAdd x Nothing  = x
 
 maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
-maybeEmpty (Just x) f = f x
+maybeEmpty = flip foldMap
-maybeEmpty Nothing  _ = mempty
 
 whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
 whenIsJust (Just x) f = f x
@@ -311,7 +313,7 @@ maybePositive a | a > 0     = Just a
                 | otherwise = Nothing
 
 positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
-positiveSum (Sum x) = maybePositive x
+positiveSum = maybePositive . getSum
 
 maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
 maybeM dft act mb = mb >>= maybe dft act
@@ -341,7 +343,6 @@ instance Ord a => Ord (NTop (Maybe a)) where
   compare (NTop (Just x)) (NTop (Just y)) = compare x y
 
 
-
 ------------
 -- Either --
 ------------

templates/widgets/gradingSummary.hamlet

@@ -0,0 +1,35 @@
+$# Displays gradings Summary for various purposes
+$# --
+$with SheetTypeSummary{..} <- addBonusToPoints gradingSummary
+  $with sumSummaries <- mappend normalSummary (mappend bonusSummary informationalSummary)
+    $with hasPassings <- positiveSum $ numGradePasses sumSummaries
+      $with hasPoints  <- positiveSum $ sumGradePoints sumSummaries
+        <div>
+          <table>
+            <tr>
+              <th>
+              $# empty cell for row headers
+              $maybe _ <- hasPassings
+                <th colspan=2>_{MsgSheetGradingPassing'}
+              $maybe _ <- hasPoints
+                <th colspan=2>_{MsgSheetGradingPoints'}
+              <th>_{MsgSheetGradingCount'}
+                $# Number of Sheet/Submissions used for calculating maximum passes/points
+            $with sumHeader <- MsgSheetTypeNormal'
+              $with summary <- normalSummary
+                ^{gradingSummaryRow}
+            $# $for (sumHeader, summary) <- [(MsgSheetTypeNormal',normalSummary),(MsgSheetTypeBonus',bonusSummary),(MsgSheetTypeInformational',informationalSummary)]
+            $# ^{gradingSummaryRow}
+              DEBUG
+            $maybe nrNoGrade <- positiveSum $ numNotGraded
+              <tr>
+                <th>_{MsgSheetTypeNotGraded}
+                $maybe _ <- hasPassings
+                  <td colspan=2>
+                $maybe _ <- hasPoints
+                  <td colspan=2>
+                <td>#{display nrNoGrade}
+          $maybe _ <- positiveSum $ bonusSummary ^. _numSheets
+            <p>_{MsgSheetTypeInfo}
+          $nothing
+            <p>_{MsgSheetTypeInfo}

templates/widgets/gradingSummaryRow.hamlet

@@ -0,0 +1,33 @@
+$# Displays one row of the grading summary
+$# Expects several variables:
+$#  hasPassing :: Maybe Int    -- Should Passing be displayed?
+$#  hasPoints  :: Maybe Poibts -- Should Points  be displayed?
+$#  summary    :: SheetGradeSummary -- summary to display
+$#  sumHeader  :: UniWorXMessage    -- row header
+$#
+  $maybe nrSheets <- positiveSum $ summary ^. _numSheets
+    <tr>
+      <th>_{sumHeader}
+      $maybe _ <- hasPassings
+        $with Sum pmax <- sumHeader ^. _numGradePasses
+          $maybe Sum pacv <- summary ^. _achievedPasses
+              <td>
+                $if pmax /= 0
+                  #{textPercentInt pacv pmax}
+              <td>
+                #{display pacv} / #{display pmax}
+          $nothing
+            <td colspan=2>
+              #{display pmax }
+      $maybe _ <- hasPoints
+        $with Sum pmax <- sumHeader ^. _sumGradePoints
+          $maybe Sum pacv <- summary ^. _achievedPoints
+              <td>
+                $if pmax /= 0
+                  #{textPercent $ realToFrac $ pacv / pmax}
+              <td>
+                #{display pacv} / #{display pmax}
+          $nothing
+            <td colspan=2>
+              #{display pmax }
+      <td>#{display nrSheets}

templates/widgets/sheetTypeSummary.hamlet

@@ -1,3 +1,4 @@
+$# DEPRECATED IN FAVOUR OF widgets/gradingSummary.hamlet DO NOT USE !!!
 $with realGrades <- normalSummary <> bonusSummary
   $# $with allGrades <- realGrades <> informationalSummary
   <div>