From ec6a8ae463ca42fd80538da782a864b739f6ba3e Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Mon, 16 Mar 2020 10:21:02 +0100
Subject: [PATCH] feat(exams): convenience for automatic grade calculation

---
 src/Handler/Utils/Exam.hs | 49 ++++++++++++++++++++++++++++++++++++++-
 src/Model/Types/Sheet.hs  |  2 ++
 2 files changed, 50 insertions(+), 1 deletion(-)

diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs
index cac40a135..00d060934 100644
--- a/src/Handler/Utils/Exam.hs
+++ b/src/Handler/Utils/Exam.hs
@@ -5,13 +5,14 @@ module Handler.Utils.Exam
   , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
   , examBonus, examBonusPossible, examBonusAchieved
   , examResultBonus, examGrade
+  , getRelevantSheetsUpTo, examBonusGrade
   , ExamAutoOccurrenceConfig
   , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
   , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
   , examAutoOccurrence
   ) where
 
-import Import.NoFoundation
+import Import
 
 import Database.Persist.Sql (SqlBackendCanRead)
 import qualified Database.Esqueleto as E
@@ -114,6 +115,31 @@ examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary ->
 examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap
 examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap
 
+getRelevantSheetsUpTo :: CourseId
+                      -> UserId
+                      -> Maybe UTCTime
+                      -> DB (Map SheetId (SheetType, Maybe Points))
+getRelevantSheetsUpTo cid uid mCutoff
+  = fmap postprocess . E.select . E.from $ \(sheet `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ sheet E.^. SheetId ] $ do
+      E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId)
+       E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
+                                                        E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId
+                      )
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+      case mCutoff of
+        Just cutoff -> E.where_ $ E.maybe E.true  (E.<=. E.val cutoff) (sheet E.^. SheetActiveTo)
+                            E.&&. E.maybe E.false (E.<=. E.val cutoff) (sheet E.^. SheetVisibleFrom)
+        Nothing -> E.where_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
+      return (sheet E.^. SheetId, sheet E.^. SheetType, submission)
+  where
+    postprocess :: [(E.Value SheetId, E.Value SheetType, Maybe (Entity Submission))]
+                -> Map SheetId (SheetType, Maybe Points)
+    postprocess = Map.fromList . map postprocess'
+      where postprocess' (E.Value sId, E.Value sType, fmap entityVal -> sub)
+              = (sId, ) . (sType, ) $ assertM submissionRatingDone sub >>= submissionRatingPoints
+              
+      
+
 
 examResultBonus :: ExamBonusRule
                 -> SheetGradeSummary -- ^ `examBonusPossible`
@@ -190,6 +216,27 @@ examGrade Exam{..} mBonus (otoList -> results)
             lowerBounds :: [(ExamGrade, Points)]
             lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'
 
+examBonusGrade :: ( MonoFoldable sheets
+                  , Element sheets ~ (SheetType, Maybe Points)
+                  , MonoFoldable results
+                  , Element results ~ ExamResultPoints
+                  )
+               => Exam
+               -> Either Points sheets -- ^ `Points` retrieved from relevant `ExamBonus`, iff it exists
+               -> results
+               -> Maybe ExamResultGrade
+examBonusGrade exam@Exam{..} bonusInp = examGrade exam mBonus
+  where mBonus = asum
+          [ bonusInp ^? _Left
+          , examResultBonus <$> examBonusRule <*> bonusPossible <*> bonusAchieved
+          ]
+        sheetSummary = flip (previews _Right) bonusInp . ofoldMap $ uncurry sheetTypeSum
+        bonusPossible = normalSummary <$> sheetSummary
+        bonusAchieved = (<>) <$> fmap normalSummary sheetSummary <*> fmap bonusSummary sheetSummary
+
+     
+
+  
 data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig
   { eaocMinimizeRooms :: Bool
   , eaocFinenessCost  :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms
diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs
index fb602feb0..10ec7ceef 100644
--- a/src/Model/Types/Sheet.hs
+++ b/src/Model/Types/Sheet.hs
@@ -118,6 +118,8 @@ deriveJSON defaultOptions
   } ''SheetType
 derivePersistFieldJSON ''SheetType
 
+makePrisms ''SheetType
+
 data SheetTypeSummary = SheetTypeSummary
   { normalSummary
   , bonusSummary