Statistik für Übungsblätter

src/Handler/Sheet.hs

@@ -236,7 +236,7 @@ getSheetListR tid csh = do
       , ( "rating"
         , SortColumn $ \(_ `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> submission E.?. SubmissionRatingPoints
         )
---    GitLab Issue $1??:
+--    GitLab Issue $1??: HOW TO SORT?
 --       , ( "percent"
 --         , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` ))) ->
 --             case sheetType of -- no Haskell inside Esqueleto, right?
@@ -248,12 +248,22 @@ getSheetListR tid csh = do
     , dbtStyle     = def
     , dbtIdent     = "sheets" :: Text
     }
---   stats <- runDB $ do
+  cTime <- Just <$> liftIO getCurrentTime -- TODO: remove me, see issue #???
---     <- E.select $ E.from $
+  rawStats <- runDB $ do
---
+    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
+        E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+        E.&&.   (E.not_ $ E.isNothing $ sheet E.^. SheetVisibleFrom)
+        E.&&.   sheet E.^. SheetVisibleFrom E.<=. E.val cTime
+      return $ (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
+
+  let sheetTypeSummary = foldl' sumSheetTypes emptySheetTypeSummary
+                       $ map (\(st,mp) -> (E.unValue st, join $ E.unValue mp)) rawStats
   defaultLayout $ do
     $(widgetFile "sheetList")
-
+    $(widgetFile "widgets/sheetTypeSummary")
 
 -- Show single sheet
 getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html

src/Model/Types.hs

@@ -76,6 +76,32 @@ instance DisplayAble SheetType where
 deriveJSON defaultOptions ''SheetType
 derivePersistFieldJSON "SheetType"
 
+data SheetTypeSummary = SheetTypeSummary
+  { sumBonusPoints  :: Points
+  , sumNormalPoints :: Points
+  , numPassSheets   :: Int
+  , numNotGraded    :: Int
+  , achievedBonus   :: Maybe Points
+  , achievedNormal  :: Maybe Points
+  , achievedPasses  :: Maybe Int
+  }
+
+
+emptySheetTypeSummary :: SheetTypeSummary
+emptySheetTypeSummary = SheetTypeSummary 0 0 0 0 Nothing Nothing Nothing
+
+-- TODO: refactor with lenses!
+sumSheetTypes :: SheetTypeSummary -> (SheetType, Maybe Points) -> SheetTypeSummary
+sumSheetTypes sts@(SheetTypeSummary {..}) (Bonus {..}, achieved)
+  = sts{ sumBonusPoints =sumBonusPoints +maxPoints, achievedBonus  = maybeAdd achievedBonus  achieved }
+sumSheetTypes sts@(SheetTypeSummary {..}) (Normal {..}, achieved)
+  = sts{ sumNormalPoints=sumNormalPoints+maxPoints, achievedNormal = maybeAdd achievedNormal achieved }
+sumSheetTypes sts@(SheetTypeSummary {..}) (Pass   {..}, achieved)
+  = sts{ numPassSheets=numPassSheets+1, achievedPasses = maybeAdd achievedPasses (bool 0 1 <$> (passingPoints <=) <$> achieved) }
+sumSheetTypes sts@(SheetTypeSummary {..}) (NotGraded, _achieved)
+  = sts{ numNotGraded=numNotGraded+1 }
+
+
 data SheetGroup
   = Arbitrary { maxParticipants :: Int }
   | RegisteredGroups

src/Utils.hs

@@ -224,6 +224,11 @@ toMaybe :: Bool -> a -> Maybe a
 toMaybe True  = Just
 toMaybe False = const Nothing
 
+maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
+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 Nothing  _ = mempty