From 85b57654a5ee1dbf036c9a15ca7be9b0951e3ecf Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Wed, 1 Aug 2018 18:37:29 +0200
Subject: [PATCH] =?UTF-8?q?Statistik=20f=C3=BCr=20=C3=9Cbungsbl=C3=A4tter?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 src/Handler/Sheet.hs | 20 +++++++++++++++-----
 src/Model/Types.hs   | 26 ++++++++++++++++++++++++++
 src/Utils.hs         |  5 +++++
 3 files changed, 46 insertions(+), 5 deletions(-)

diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 9edeba5a2..0dc1351ec 100644
--- a/src/Handler/Sheet.hs
+++ b/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
---     <- E.select $ E.from $
---
+  cTime <- Just <$> liftIO getCurrentTime -- TODO: remove me, see issue #???
+  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
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index bf035c79c..aff3ccd1b 100644
--- a/src/Model/Types.hs
+++ b/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
diff --git a/src/Utils.hs b/src/Utils.hs
index 5a5428d70..9f70d3159 100644
--- a/src/Utils.hs
+++ b/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