fradrive/src/Handler/Utils/Exam.hs

module Handler.Utils.Exam
  ( fetchExamAux
  , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
  , examBonus, examBonusPossible, examBonusAchieved
  , examResultBonus, examGrade
  ) where

import Import.NoFoundation

import Database.Persist.Sql (SqlBackendCanRead)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Sql as E
import Database.Esqueleto.Utils.TH

import qualified Data.Conduit.List as C

import qualified Data.Map as Map

import Data.Fixed (Fixed(..))


fetchExamAux :: ( SqlBackendCanRead backend
                , E.SqlSelect b a
                , MonadHandler m
                , Typeable a
                )
             => (E.SqlExpr (Entity Exam) -> E.SqlExpr (Entity Course) -> b)
             -> TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT backend m a
fetchExamAux prj tid ssh csh examn =
    let cachId = encodeUtf8 $ tshow (tid, ssh, csh, examn)
    in  cachedBy cachId $ do
        tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do
            E.on     $ course E.^. CourseId E.==. tut E.^. ExamCourse
            E.where_ $ course E.^. CourseTerm      E.==. E.val tid
                E.&&.  course E.^. CourseSchool    E.==. E.val ssh
                E.&&.  course E.^. CourseShorthand E.==. E.val csh
                E.&&.  tut    E.^. ExamName    E.==. E.val examn
            return $ prj tut course
        case tutList of
          [tut] -> return tut
          _other  -> notFound

fetchExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Entity Exam)
fetchExam = fetchExamAux const

fetchExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Exam)
fetchExamId tid ssh cid examn = E.unValue <$> fetchExamAux (\tutorial _ -> tutorial E.^. ExamId) tid ssh cid examn

fetchCourseIdExamId  :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Key Exam)
fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. ExamId)) tid ssh cid examn

fetchCourseIdExam  :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam)
fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn


examBonus :: MonadHandler m => Entity Exam -> ReaderT SqlBackend m (Map UserId SheetTypeSummary)
examBonus (Entity eId Exam{..}) = runConduit $
  let
    rawData = E.selectSource . E.from $ \(((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` sheet) `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, 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.==. examRegistration E.^. ExamRegistrationUser
                                                        E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId
                      )
      E.on E.true
      E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId
      E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse
           E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId
      E.where_ $ E.case_ 
        [ E.when_
            ( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence )
          E.then_
            (       E.just (sheet E.^. SheetActiveTo) E.<=. examOccurrence E.?. ExamOccurrenceStart
              E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart
            )
        ]
        ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
        )
      return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission)
    accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) ->
      flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType $ assertM submissionRatingDone sub >>= submissionRatingPoints
   in rawData .| accum

examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> SheetGradeSummary
examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap
examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap


examResultBonus :: ExamBonusRule
                -> SheetGradeSummary -- ^ `examBonusPossible`
                -> SheetGradeSummary -- ^ `examBonusAchieved`
                -> Points
examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of
  ExamBonusManual{}
    -> 0
  ExamBonusPoints{..}
    -> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp
  where
    bonusProp :: Rational
    bonusProp
      | possible <= 0 = 1
      | otherwise = achieved / possible
      where
        achieved = toRational (getSum $ achievedPoints  bonusAchieved) + scalePasses (getSum $ achievedPasses  bonusAchieved)
        possible = toRational (getSum $ sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)
        
        scalePasses :: Integer -> Rational
        -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
        scalePasses passes
          | passesPossible <= 0 = 0
          | otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible
          where
            passesPossible = getSum $ numSheetsPasses bonusPossible
            pointsPossible = getSum $ sumSheetsPoints bonusPossible

    roundToPoints :: forall a. HasResolution a => Fixed a -> Rational -> Fixed a
    -- ^ 'round-to-nearest' whole multiple
    roundToPoints (MkFixed mult'@(fromInteger -> mult)) ((* toRational (resolution (Proxy @a))) -> raw)
      = MkFixed . (* mult') $
          let (whole, frac) = raw `divMod'` mult
           in if | abs frac < abs (mult / 2)
                   -> whole
                 | raw >= 0
                   -> succ whole
                 | otherwise
                   -> pred whole
 
examGrade :: ( MonoFoldable mono
             , Element mono ~ ExamResultPoints
             )
          => Exam
          -> Maybe Points -- ^ Bonus
          -> mono -- ^ `ExamPartResult`s
          -> Maybe ExamResultGrade
examGrade Exam{..} mBonus (otoList -> results)
  = traverse pointsToGrade achievedPoints'
  where
    achievedPoints' :: ExamResultPoints
    achievedPoints' = withBonus . getSum <$> foldMap (fmap Sum) results

    withBonus :: Points -> Points
    withBonus ps
      | Just bonusRule <- examBonusRule
      = if
          |    maybe True not (bonusRule ^? _bonusOnlyPassed)
            || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True)
            -> maybe id (+) mBonus ps
          | otherwise
            -> ps
      | otherwise
      = ps
    
    pointsToGrade :: Points -> Maybe ExamGrade
    pointsToGrade ps = examGradingRule <&> \case
      ExamGradingKey{..}
        -> gradeFromKey examGradingKey
      where
        gradeFromKey :: [Points] -> ExamGrade
        gradeFromKey examGradingKey' = maximum $ Grade50 `ncons` [ g | (g, b) <- lowerBounds, b <= ps ]
          where
            lowerBounds :: [(ExamGrade, Points)]
            lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'