140 lines
6.8 KiB
Haskell
140 lines
6.8 KiB
Haskell
module Handler.Utils.Exam
|
|
( fetchExamAux
|
|
, fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
|
|
, examBonus, examBonusPossible, examBonusAchieved
|
|
, 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
|
|
|
|
|
|
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) ->
|
|
Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub
|
|
in rawData .| accum
|
|
|
|
examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary
|
|
examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap
|
|
examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap
|
|
|
|
|
|
examGrade :: ( MonoFoldable mono
|
|
, Element mono ~ ExamResultPoints
|
|
)
|
|
=> Entity Exam
|
|
-> SheetGradeSummary -- ^ `examBonusPossible`
|
|
-> SheetGradeSummary -- ^ `examBonusAchieved`
|
|
-> mono -- ^ `ExamPartResult`s
|
|
-> Maybe ExamResultGrade
|
|
examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results)
|
|
| null results
|
|
= Nothing
|
|
| otherwise
|
|
= traverse pointsToGrade achievedPoints'
|
|
where
|
|
achievedPoints' :: ExamResultPoints
|
|
achievedPoints' = withBonus . getSum <$> foldMap (fmap Sum) results
|
|
|
|
withBonus :: Points -> Points
|
|
withBonus ps
|
|
| Just ExamBonusPoints{..} <- examBonusRule
|
|
= if
|
|
| not bonusOnlyPassed
|
|
|| fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True)
|
|
-> ps + roundToPoints (toRational bonusMaxPoints * bonusProp)
|
|
| otherwise
|
|
-> ps
|
|
| otherwise
|
|
= ps
|
|
where
|
|
bonusProp :: Rational
|
|
bonusProp = clamp 0 1 $ toRational (getSum (achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved))
|
|
/ toRational (getSum (sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible))
|
|
where
|
|
scalePasses :: Integer -> Points
|
|
-- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
|
|
scalePasses passes = fromInteger passes / (fromInteger . getSum $ numSheetsPasses bonusPossible) * (getSum $ sumSheetsPoints bonusPossible)
|
|
|
|
roundToPoints :: forall a. HasResolution a => Rational -> Fixed a
|
|
roundToPoints = MkFixed . round . ((*) . toRational $ resolution (Proxy @a))
|
|
|
|
pointsToGrade :: Points -> Maybe ExamGrade
|
|
pointsToGrade ps
|
|
| Just ExamGradingKey{..} <- examGradingRule
|
|
= Just $ gradeFromKey examGradingKey
|
|
| otherwise
|
|
= Nothing
|
|
where
|
|
gradeFromKey :: [Points] -> ExamGrade
|
|
gradeFromKey examGradingKey' = maximum $ impureNonNull [ g | (g, b) <- lowerBounds, b <= clampMin 0 ps ]
|
|
where
|
|
lowerBounds :: [(ExamGrade, Points)]
|
|
lowerBounds = zip [Grade50, Grade40 ..] $ 0 : examGradingKey'
|
|
|