Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

.vscode/tasks.json

@@ -11,7 +11,7 @@
       },
       "presentation": {
         "echo": true,
-        "reveal": "silent",
+        "reveal": "always",
         "focus": false,
         "panel": "dedicated",
         "showReuseMessage": false

messages/uniworx/de.msg

@@ -380,7 +380,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
 
@@ -388,7 +390,11 @@ 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 angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer.
+SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter.
+SheetTypeInfoNotGraded: 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 erreichten normalen Punkten hinzugezählt.
+SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Blätter
+SubmissionGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben
 
 SheetTypeBonus': Bonus
 SheetTypeNormal': Normal

src/Foundation.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto
 
 module Foundation where
@@ -144,7 +145,7 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr
 pattern CSubmissionR tid ssh csh shn cid ptn
   = CSheetR tid ssh csh shn (SubmissionR cid ptn)
 
--- Messages
+-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
 mkMessage "UniWorX" "messages/uniworx" "de"
 mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
 mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
@@ -224,6 +225,16 @@ instance RenderMessage UniWorX SheetType where
 newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
 embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
 
+newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
+  deriving (Generic, Typeable)
+  deriving newtype (Semigroup, Monoid, IsList)
+
+instance RenderMessage UniWorX UniWorXMessages where
+  renderMessage foundation ls (UniWorXMessages msgs) =
+    intercalate " " $ map (renderMessage foundation ls) msgs
+
+uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
+uniworxMessages = UniWorXMessages . map SomeMessage
 
 -- Menus and Favourites
 data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary

src/Handler/Corrections.hs

@@ -7,6 +7,7 @@ import Jobs
 import Handler.Utils
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
+import Handler.Utils.SheetType
 -- import Handler.Utils.Zip
 
 import Utils.Lens
@@ -56,25 +57,33 @@ import Data.Foldable (foldrM)
 
 
 
-type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
+type CorrectionTableExpr  = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
-            (expr (Entity Course), expr (Entity Sheet), expr (Entity Submission))
+type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
-            -> expr (E.Value Bool)
-
-ratedBy :: Key User -> CorrectionsWhere
-ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
-
-courseIs :: Key Course -> CorrectionsWhere
-courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
-
-sheetIs :: Key Sheet -> CorrectionsWhere
-sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
-
-submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere
-submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
-
-
 type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
 
+correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v
+correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
+    E.on $ corrector E.?. UserId   E.==. submission E.^. SubmissionRatingBy
+    E.on $ sheet     E.^. SheetId  E.==. submission E.^. SubmissionSheet
+    E.on $ course    E.^. CourseId E.==. sheet      E.^. SheetCourse
+    E.where_ $ whereClause t
+    return $ returnStatement t
+
+-- Where Clauses
+ratedBy :: UserId -> CorrectionTableWhere
+ratedBy uid   ((_course `E.InnerJoin` _sheet `E.InnerJoin`  submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
+
+courseIs :: CourseId -> CorrectionTableWhere
+courseIs cid  (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid
+
+sheetIs :: Key Sheet -> CorrectionTableWhere
+sheetIs shid  ((_course `E.InnerJoin`  sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
+
+submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere
+submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
+
+
+-- Columns
 colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
         $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
@@ -94,6 +103,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
@@ -116,7 +129,7 @@ colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult
 colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
 
 colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
-colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
+colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
   csh = course ^. _2
   tid = course ^. _3
   ssh = course ^. _4
@@ -138,6 +151,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $  \DBRow{ dbrOutput=(
       tid = course ^. _3
       ssh = course ^. _4
       -- shn = sheetName
+
       mkRoute = do
         cid <- encrypt subId
         return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
@@ -176,23 +190,19 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
   (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
 
 
-type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
-
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
+                     => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
 makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
   let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
-      dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
+      dbtSQLQuery = correctionsTableQuery whereClause
-        E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
+          (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
-        E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
+            let crse =  ( course E.^. CourseName      :: E.SqlExpr (E.Value CourseName)
-        E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
+                        , course E.^. CourseShorthand
-        E.where_ $ whereClause (course,sheet,submission)
+                        , course E.^. CourseTerm
-        let crse =  ( course E.^. CourseName      :: E.SqlExpr (E.Value CourseName)
+                        , course E.^. CourseSchool    :: E.SqlExpr (E.Value SchoolId)
-                    , course E.^. CourseShorthand
+                        )
-                    , course E.^. CourseTerm
+            in (submission, sheet, crse, corrector)
-                    , course E.^. CourseSchool    :: E.SqlExpr (E.Value SchoolId)
+          )
-                    )
-        return (submission, sheet, crse, corrector)
       dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
       dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
         submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
@@ -200,7 +210,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
            E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
           E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
           E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
-          E.orderBy [E.asc $ user E.^. UserId]
+          E.orderBy [E.asc $ user E.^. UserDisplayName]
           return (user, pseudonym E.?. SheetPseudonymPseudonym)
         let
           submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
@@ -231,6 +241,16 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
       , ( "assignedtime"
         , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned
         )
+      , ( "submittors"
+        , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) ->
+            E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+              E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+              E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+              E.orderBy [E.asc $ user E.^. UserDisplayName]
+              E.limit 1
+              return (user E.^. UserDisplayName)
+
+        )
       ]
     , dbtFilter    = Map.fromList
       [ ( "term"
@@ -356,9 +376,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
             addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
       redirect currentRoute
 
+  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 = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
   fmap toTypedContent . defaultLayout $ do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
+
   where
     authorizedToAssign :: SubmissionId -> DB Bool
     authorizedToAssign sId = do

src/Handler/Sheet.hs

@@ -6,6 +6,7 @@ import System.FilePath (takeFileName)
 import Handler.Utils
 -- import Handler.Utils.Zip
 import Handler.Utils.Table.Cells
+import Handler.Utils.SheetType
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -41,7 +42,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
@@ -97,7 +98,8 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
       <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
       <*> sheetTypeAFormReq   (fslI MsgSheetType
-            & setTooltip MsgSheetTypeInfo)                  (sfType        <$> template)
+            & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
+                                                          (sfType        <$> template)
       <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
             & setTooltip MsgSheetVisibleFromTip)
@@ -152,18 +154,19 @@ 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)
+      [ dbRow
-          $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
+      , sortable (Just "name") (i18nCell MsgSheet)
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
       , sortable (Just "last-edit") (i18nCell MsgLastEdit)
-          $ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime
+          $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty timeCell mEditTime
       , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
-          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveFrom
       , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
-          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveTo
       , sortable Nothing (i18nCell MsgSheetType)
-          $ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> i18nCell sheetType
       , sortable Nothing (i18nCell MsgSubmission)
-          $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
               Nothing -> mempty
               (Just (Entity sid Submission{..})) ->
                 let mkCid = encrypt sid -- TODO: executed twice
@@ -172,7 +175,7 @@ getSheetListR tid ssh csh = do
                       return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
                 in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
       , sortable (Just "rating") (i18nCell MsgRating)
-          $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
               Nothing -> mempty
               (Just (Entity sid Submission{..})) ->
                 let mkCid = encrypt sid
@@ -182,7 +185,7 @@ getSheetListR tid ssh csh = do
                 in anchorCellM mkRoute $(widgetFile "widgets/rating")
       , sortable Nothing -- (Just "percent")
                         (i18nCell MsgRatingPercent)
-          $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
+          $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub)} -> case mbSub of
               (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
                 case preview (_grading . _maxPoints) sType of
                   Just maxPoints
@@ -197,8 +200,8 @@ getSheetListR tid ssh csh = do
   table <- runDB $ dbTableWidget' psValidator DBTable
     { dbtSQLQuery  = sheetData
     , dbtColonnade = sheetCol
-    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
+    , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
-                   -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
+                   -> dbr <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
     , dbtSorting   = Map.fromList
       [ ( "name"
         , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
@@ -228,7 +231,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 MsgSheetGradingSummaryTitle <$> 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
@@ -238,7 +241,6 @@ getSheetListR tid ssh csh = do
     return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
   defaultLayout $ do
     $(widgetFile "sheetList")
-    $(widgetFile "widgets/sheetTypeSummary")
 
 data ButtonGeneratePseudonym = BtnGenerate
   deriving (Enum, Eq, Ord, Bounded, Read, Show)

src/Handler/Utils/Form.hs

@@ -335,17 +335,17 @@ sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Han
 sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
   where
     selOptions = Map.fromList
-      [ ( Points', Points <$> maxPointsReq )
+      [ ( Points',     Points     <$> maxPointsReq )
       , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
       , ( PassBinary', pure PassBinary)
       ]
     classify' :: SheetGrading -> SheetGrading'
     classify' = \case
-      Points {} -> Points'
+      Points     {} -> Points'
       PassPoints {} -> PassPoints'
       PassBinary {} -> PassBinary'
 
-    maxPointsReq  = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints)
+    maxPointsReq  = apreq pointsField (fslI MsgSheetGradingMaxPoints)     (template >>= preview _maxPoints)
     passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints)
 
 

src/Handler/Utils/SheetType.hs

@@ -0,0 +1,39 @@
+module Handler.Utils.SheetType
+  (
+    gradeSummaryWidget
+  ) where
+
+import Import
+import Data.Monoid (Sum(..))
+import Utils.Lens hiding ((<.>))
+
+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 ::  RenderMessage UniWorX msg => (Int -> msg) -> SheetTypeSummary -> Widget
+gradeSummaryWidget title 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

@@ -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/Import/NoFoundation.hs

@@ -35,10 +35,12 @@ import Mail                   as Import
 import Data.Data              as Import (Data)
 import Data.Typeable          as Import (Typeable)
 import GHC.Generics           as Import (Generic)
+import GHC.Exts               as Import (IsList)
 
 import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (NonEmpty(..))
 import Data.Text.Encoding.Error    as Import(UnicodeException(..))
+import Data.Semigroup         as Import (Semigroup)
 
 import Control.Monad.Morph    as Import (MFunctor(..))
 

src/Model/Rating.hs

@@ -2,7 +2,6 @@ module Model.Rating where
 
 import ClassyPrelude.Yesod
 import Model
-
 -- import Data.Text (Text)
 import Data.Text.Encoding.Error (UnicodeException(..))
 import GHC.Generics (Generic)

src/Model/Types.hs

@@ -135,10 +135,11 @@ gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints
 gradingPassed (PassBinary {}) pts = Just $ pts /= 0
 
 data SheetGradeSummary = SheetGradeSummary
-  { sumGradePoints :: Sum Points
+  { numSheets      :: Sum Int
   , numGradePasses :: Sum Int
-  , achievedPoints :: Maybe (Sum Points)
+  , sumGradePoints :: Sum Points
   , achievedPasses :: Maybe (Sum Int)
+  , achievedPoints :: Maybe (Sum Points)
   } deriving (Generic, Read, Show, Eq)
 
 instance Monoid SheetGradeSummary where
@@ -146,18 +147,25 @@ instance Monoid SheetGradeSummary where
   mappend = mappenddefault
 
 instance Semigroup SheetGradeSummary where
-  (<>) = mappend -- remove for GHC > 8.4.x
+  (<>) = mappend -- TODO: remove for GHC > 8.4.x
+
+makeLenses_ ''SheetGradeSummary
 
 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
   = Normal        { grading :: SheetGrading }
@@ -174,19 +182,26 @@ deriveJSON defaultOptions
 derivePersistFieldJSON ''SheetType
 
 data SheetTypeSummary = SheetTypeSummary
-  { normalSummary, bonusSummary, informationalSummary :: SheetGradeSummary
+  { normalSummary
-  , numNotGraded  :: Sum Int
+  , bonusSummary
+  , informationalSummary :: SheetGradeSummary
+  , numNotGraded :: Sum Int
   } deriving (Generic, Read, Show, Eq)
 
 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 Normal{..}        mps = mempty { normalSummary        = 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

@@ -213,6 +213,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
 
@@ -317,14 +320,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
@@ -339,7 +341,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
@@ -369,7 +371,6 @@ instance Ord a => Ord (NTop (Maybe a)) where
   compare (NTop (Just x)) (NTop (Just y)) = compare x y
 
 
-
 ------------
 -- Either --
 ------------

templates/corrections.hamlet

@@ -1,5 +1,7 @@
-<div .container>
+<section>
   <form method=POST enctype=#{tableEncoding} action=@{currentRoute}>
     ^{table}
     <button type=submit>
       _{MsgBtnSubmit}
+<section>
+  ^{statistics}

templates/sheetList.hamlet

@@ -1 +1,4 @@
-^{table}
+<section>
+  ^{table}
+<section>
+  ^{statistics}

templates/standalone/alerts.julius

@@ -29,7 +29,7 @@
       var iconEl = document.createElement('DIV');
       var closeEl = document.createElement('DIV');
       var dataDecay = alertEl.dataset.decay;
-      var autoDecay = 30;
+      var autoDecay = 10;
       if (dataDecay) {
         autoDecay = parseInt(dataDecay, 10);
       }

templates/widgets/gradingSummary.hamlet

@@ -0,0 +1,30 @@
+$# Displays gradings Summary for various purposes
+$# --
+<div>
+  <h3>_{title $ getSum $ numSheets $ sumSummaries}
+  <table .table .table--striped>
+    <tr .table__row .table__row--head>
+      <th>
+      $# empty cell for row headers
+      $maybe _ <- hasPassings
+        <th .table__th colspan=2>_{MsgSheetGradingPassing'}
+      $maybe _ <- hasPoints
+        <th .table__th colspan=2>_{MsgSheetGradingPoints'}
+      <th .table__th>_{MsgSheetGradingCount'}
+        $# Number of Sheet/Submissions used for calculating maximum passes/points
+    $forall row <- rowWdgts
+      ^{row}
+    $maybe nrNoGrade <- positiveSum $ numNotGraded
+      <tr .table__row>
+        <th .table__th>_{MsgSheetTypeNotGraded}
+        $maybe _ <- hasPassings
+          <td colspan=2>
+        $maybe _ <- hasPoints
+          <td .table__td colspan=2>
+        <td .table__td>#{display nrNoGrade}
+  $maybe _ <- positiveSum $ bonusSummary ^. _numSheets
+    <p>_{MsgSheetTypeInfoBonus}
+      $maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
+        _{MsgSheetGradingBonusIncluded}
+  $maybe _ <- positiveSum $ informationalSummary ^. _numSheets
+    <p>_{MsgSheetTypeInfoNotGraded}

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 .table__row >
+      <th .table__th>_{sumHeader}
+      $maybe _ <- hasPassings
+        $with Sum pmax <- summary ^. _numGradePasses
+          $maybe Sum pacv <- summary ^. _achievedPasses
+              <td .table__td>
+                $if pmax /= 0
+                  #{textPercentInt pacv pmax}
+              <td .table__td>
+                #{display pacv} / #{display pmax}
+          $nothing
+            <td .table__td colspan=2>
+              #{display pmax }
+      $maybe _ <- hasPoints
+        $with Sum pmax <- summary ^. _sumGradePoints
+          $maybe Sum pacv <- summary ^. _achievedPoints
+              <td .table__td>
+                $if pmax /= 0
+                  #{textPercent $ realToFrac $ pacv / pmax}
+              <td .table__td>
+                #{display pacv} / #{display pmax}
+          $nothing
+            <td .table__td colspan=2>
+              #{display pmax }
+      <td .table__td>#{display nrSheets}

templates/widgets/rating.hamlet

@@ -6,15 +6,16 @@ $maybe points <- submissionRatingPoints
     $case grading
       $of Points{..}
         _{MsgAchievedOf points maxPoints}
-      $of PassPoints{}
+      $of PassPoints{maxPoints}
         $if fromMaybe False (gradingPassed grading points)
-          _{MsgPassed}
+          _{MsgPassed}, _{MsgAchievedOf points maxPoints}
         $else
-          _{MsgNotPassed}
+          _{MsgNotPassed}, _{MsgAchievedOf points maxPoints}
       $of PassBinary
         $if fromMaybe False (gradingPassed grading points)
           _{MsgPassed}
         $else
           _{MsgNotPassed}
+    , _{SheetTypeHeader sheetType}
   $nothing
     #{tickmarkS}

templates/widgets/sheetTypeSummary.hamlet

@@ -1,9 +1,9 @@
+$# DEPRECATED IN FAVOUR OF widgets/gradingSummary.hamlet DO NOT USE !!!
 $with realGrades <- normalSummary <> bonusSummary
   $# $with allGrades <- realGrades <> informationalSummary
   <div>
-    <ul>    
       $maybe realPoints <- positiveSum (sumGradePoints realGrades)
-        <li>     
+        <p>
           Gesamtpunktzahl #{display realPoints}
           $maybe nPts <- getSum <$> achievedPoints realGrades
             \ davon #{display nPts} erreicht
@@ -16,7 +16,7 @@ $with realGrades <- normalSummary <> bonusSummary
               \ #{textPercent $ realToFrac $ nPts / realPoints}
             \.
       $maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
-        <li>
+        <p>
           <em>Hinweis:
           \ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
           welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
@@ -27,7 +27,7 @@ $with realGrades <- normalSummary <> bonusSummary
           \.
 
       $maybe reqPasses <- positiveSum (numGradePasses normalSummary)
-        <li>
+        <p>
           Aufgaben zum Bestehen: #{display reqPasses}
           $maybe passed <- getSum <$> achievedPasses realGrades
             \ davon #{display passed} bestanden
@@ -36,6 +36,6 @@ $with realGrades <- normalSummary <> bonusSummary
             \.
 
       $maybe noGradeSheets <- positiveSum numNotGraded
-        <li>
+        <p>
           #{display noGradeSheets} unbewertete Aufgabenblätter.