diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 4beaff758..03296e157 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -9,6 +9,7 @@ module Handler.Utils.Exam , ExamAutoOccurrenceConfig , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize + , ExamAutoOccurrenceException(..) , examAutoOccurrence , deregisterExamUsersCount, deregisterExamUsers , examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs index 30cb9b883..3244c9ff0 100644 --- a/test/Handler/Utils/ExamSpec.hs +++ b/test/Handler/Utils/ExamSpec.hs @@ -90,15 +90,6 @@ instance Show UserProperties where ++ ", userMatrikelnummer=" ++ show userMatrikelnummer ++ "}" -- function Handler.Utils.examAutoOccurrence --- examAutoOccurrence :: forall seed. --- Hashable seed --- => seed --- -> ExamOccurrenceRule --- -> ExamAutoOccurrenceConfig --- -> Map ExamOccurrenceId Natural --- -> Map UserId (User, Maybe ExamOccurrenceId) --- -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) --- examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users spec :: Spec spec = do describe "examAutoOccurrence" $ do @@ -125,16 +116,16 @@ spec = do in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences let config :: ExamAutoOccurrenceConfig config = def {eaocNudge} - (maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users + autoOccurrenceResult = examAutoOccurrence seed rule config occurrences users pure $ ioProperty $ do - -- user count stays constant - myAnnotate "number of users changed" $ shouldBe (length userMap) (length users) - -- no room is overfull let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId) userProperties = Map.map (first UserProperties) users - myAnnotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms - case maybeMapping of - (Just occurrenceMapping) -> do + case autoOccurrenceResult of + (Right (occurrenceMapping, userMap)) -> do + -- user count stays constant + myAnnotate "number of users changed" $ shouldBe (length userMap) (length users) + -- no room is overfull + myAnnotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms -- mapping is a valid description myAnnotate "invalid mapping description" $ shouldSatisfy (rule, occurrenceMapping) $ uncurry validRangeDescription -- every (relevant) user got assigned a room @@ -151,10 +142,10 @@ spec = do myAnnotate "shown ranges don't match userMap" $ shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges -- is a nullResult justified? - Nothing -> + (Left autoOccurrenceException) -> -- disabled for now, probably not correct with the current implementation myAnnotate "unjustified nullResult" - $ shouldSatisfy (rule, userProperties, occurrences) $ uncurry3 isNullResultJustified + $ shouldSatisfy (autoOccurrenceException, rule, userProperties, occurrences) $ uncurry4 isNullResultJustified -- | generate users without any pre-assigned rooms genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural) genUsersWithOccurrences preselection = do @@ -234,9 +225,11 @@ spec = do endAfterStart ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase -> end)} = RFC5051.compareUnicode start end /= GT - endAfterStart ExamOccurrenceMappingSpecial {} = True + endAfterStart _mappingDescription = True -- also check for equal length with ExamRoomMatriculation noDirectOverlap :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription -> Bool + noDirectOverlap ExamOccurrenceMappingRandom other = other == ExamOccurrenceMappingRandom + noDirectOverlap other ExamOccurrenceMappingRandom = other == ExamOccurrenceMappingRandom noDirectOverlap ExamOccurrenceMappingRange {eaomrStart=cs0@(pack . map CI.foldedCase -> s0), eaomrEnd=ce0@(pack . map CI.foldedCase -> e0)} ExamOccurrenceMappingRange {eaomrStart=cs1@(pack . map CI.foldedCase -> s1), eaomrEnd=ce1@(pack . map CI.foldedCase -> e1)} @@ -294,6 +287,7 @@ spec = do _rule -> Nothing fitsInRange :: ExamOccurrenceMappingDescription -> Bool fitsInRange mappingDescription = case (ciTag, mappingDescription) of + (_tag, ExamOccurrenceMappingRandom) -> True (Nothing, _mappingDescription) -> True (Just tag, ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase-> end)}) -> (RFC5051.compareUnicode start (pack $ map CI.foldedCase $ transformTag start tag) /= GT) @@ -309,25 +303,37 @@ spec = do ExamRoomMatriculation -> isSuffixOf _rule -> isPrefixOf _otherwise -> (rule /= ExamRoomSurname) && (rule /= ExamRoomMatriculation) - -- | Is mapping impossible? - isNullResultJustified :: ExamOccurrenceRule + -- | Is mapping impossible due to the given reason? + isNullResultJustified :: ExamAutoOccurrenceException + -> ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Bool - isNullResultJustified rule userProperties occurrences - = noRelevantUsers rule userProperties || mappingImpossible rule userProperties occurrences || True + isNullResultJustified ExamAutoOccurrenceExceptionRuleNoOp rule _userProperties _occurrences + = not $ examOccurrenceRuleAutomatic rule + isNullResultJustified ExamAutoOccurrenceExceptionNotEnoughSpace rule userProperties occurrences + = fromIntegral (length $ relevantUsers rule userProperties) > sum occurrences + isNullResultJustified ExamAutoOccurrenceExceptionNoUsers rule userProperties _occurrences + = noRelevantUsers rule userProperties + isNullResultJustified ExamAutoOccurrenceExceptionRoomTooSmall rule userProperties occurrences + = mappingImpossible rule userProperties occurrences noRelevantUsers :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Bool - noRelevantUsers rule = null . Map.filter (isRelevantUser rule) + noRelevantUsers rule = null . relevantUsers rule + relevantUsers :: ExamOccurrenceRule + -> Map UserId (UserProperties, Maybe ExamOccurrenceId) + -> Map UserId (UserProperties, Maybe ExamOccurrenceId) + relevantUsers rule = Map.filter $ isRelevantUser rule isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool isRelevantUser _rule (_user, Just _assignedRoom) = False isRelevantUser rule (UserProperties User {userSurname, userMatrikelnummer}, Nothing) = case rule of ExamRoomSurname -> not $ null userSurname ExamRoomMatriculation -> maybe False (not . null) userMatrikelnummer + ExamRoomRandom -> True _rule -> False mappingImpossible :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Bool mappingImpossible rule - userProperties@(sort . map (ruleProperty rule . fst) . Map.elems . Map.filter (isRelevantUser rule) -> relevantUsers) - (map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go 0 relevantUsers occurrences' + userProperties@(sort . map (ruleProperty rule . fst) . Map.elems . relevantUsers rule -> users') + (map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go 0 users' occurrences' where smallestRoom :: Natural smallestRoom = maybe 0 minimum $ fromNullable occurrences'