Summary shown for all submission, but mislabelled

src/Handler/Corrections.hs

@@ -56,25 +56,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, _, _) } ->
@@ -176,23 +184,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 -> _ -> Handler (DBResult m x)
+                     => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (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
@@ -356,9 +360,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
             addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
       redirect currentRoute
 
+  SheetTypeSummary{..} <- 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")
   fmap toTypedContent . defaultLayout $ do
     setTitleI MsgCourseCorrectionsTitle
     $(widgetFile "corrections")
+
   where
     authorizedToAssign :: SubmissionId -> DB Bool
     authorizedToAssign sId = do

src/Handler/Sheet.hs

@@ -236,9 +236,9 @@ 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")
-    $(widgetFile "widgets/sheetTypeSummary")
 
 data ButtonGeneratePseudonym = BtnGenerate
   deriving (Enum, Eq, Ord, Bounded, Read, Show)

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/widgets/sheetTypeSummary.hamlet

@@ -1,9 +1,8 @@
 $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 +15,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 +26,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 +35,6 @@ $with realGrades <- normalSummary <> bonusSummary
             \.
 
       $maybe noGradeSheets <- positiveSum numNotGraded
-        <li>
+        <p>
           #{display noGradeSheets} unbewertete Aufgabenblätter.