From 27f30dcd17bab4bfa2327cc4a0f7141bea9ed69c Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Mon, 1 Feb 2021 14:13:08 +0100 Subject: [PATCH] chore(test): rearrange to allow easier parameter adjustments --- test/Handler/Utils/ExamSpec.hs | 73 ++++++++++++++++++---------------- 1 file changed, 39 insertions(+), 34 deletions(-) diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs index ae6783595..d7a3fc517 100644 --- a/test/Handler/Utils/ExamSpec.hs +++ b/test/Handler/Utils/ExamSpec.hs @@ -28,6 +28,11 @@ instance Arbitrary ExamOccurrence where <*> arbitrary -- examOccurrenceEnd <*> arbitrary -- examOccurrenceDescription + +data Preselection = NoPreselection | SomePreselection + +data Nudges = NoNudges | SomeNudges | LargeNudges + -- function Handler.Utils.examAutoOccurrence -- examAutoOccurrence :: forall seed. -- Hashable seed @@ -44,42 +49,46 @@ spec = do describe "Surname" $ do let rule :: ExamOccurrenceRule rule = ExamRoomSurname - prop "no Nudges, no preselection" $ do - (users, occurrences) <- genUsersWithOccurrences False - let result@(_maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users - pure $ ioProperty $ do - -- every user got assigned a room - shouldBe (length userMap) (length users) - shouldSatisfy userMap $ all isJust - -- no room is overfull - shouldSatisfy (occurrences, userMap) $ uncurry fitsInRooms - -- all users match the shown ranges - shouldSatisfy (users, result) $ uncurry showsCorrectRanges - prop "no Nudges, some preselected" $ do - (users, occurrences) <- genUsersWithOccurrences True - let result@(_maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users - pure $ ioProperty $ do - -- every user got assigned a room - shouldBe (length userMap) (length users) - shouldSatisfy userMap $ all isJust - -- no room is overfull - shouldSatisfy (occurrences, userMap) $ uncurry fitsInRooms - -- all users match the shown ranges or their preselection - shouldSatisfy (users, result) $ uncurry showsCorrectRanges + describe "No Nudges" $ do + let nudges = NoNudges + prop "no preselected" $ propertyTest rule nudges NoPreselection + prop "some preselected" $ propertyTest rule nudges SomePreselection -- TODO test with some users fixed/preselected to certain rooms -- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), ExamRoomMatriculation, ExamRoomRandom where + seed :: () + seed = () + -- TODO adjust with different nudges, depended on occurrences list/map + -- def {eaocNudge = Map.singleton occ20Id (-11)} + --ExamAutoOccurrenceConfig {eaocMinimizeRooms = False, eaocFinenessCost = 1 % 5, eaocNudge = fromList [(SqlBackendKey {unSqlBackendKey = 4},-11)], eaocNudgeSize = 1 % 20} + propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property + propertyTest rule nudges preselection = do + (users, occurrences) <- genUsersWithOccurrences preselection + let config :: ExamAutoOccurrenceConfig + config = case nudges of + NoNudges -> def + SomeNudges -> def --TODO, (Map.fromList . concatJust) <$> mapM (\(occurrenceId, _size) -> frequency _someChances) occurrences + LargeNudges -> def --TODO + result@(_maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users + pure $ ioProperty $ do + -- every user got assigned a room + shouldBe (length userMap) (length users) + shouldSatisfy userMap $ all isJust + -- no room is overfull + shouldSatisfy (occurrences, userMap) $ uncurry fitsInRooms + -- all users match the shown ranges + shouldSatisfy (users, result) $ uncurry showsCorrectRanges -- | generate users without any pre-assigned rooms - genUsersWithOccurrences :: Bool -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural) - genUsersWithOccurrences assignSomeUsers = do + genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural) + genUsersWithOccurrences preselection = do rawUsers <- listOf1 $ Entity <$> arbitrary <*> arbitrary occurrences <- genOccurrences $ length rawUsers -- user surnames anpassen, sodass interessante instanz users <- fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do userSurname <- elements surnames - assignedRoom <- if assignSomeUsers - then frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)] - else pure Nothing + assignedRoom <- case preselection of + NoPreselection -> pure Nothing + SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)] pure (entityKey, (entityVal {userSurname}, assignedRoom)) pure (users, occurrences) genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural) @@ -105,13 +114,6 @@ spec = do , "Clark", "Lewis", "Robinson", "Walker" , "Perez", "Hall", "Young", "Allen" ] - seed :: () - seed = () - config :: ExamAutoOccurrenceConfig - config = def - -- TODO adjust with different nudges, depended on occurrences list/map - -- def {eaocNudge = Map.singleton occ20Id (-11)} - --ExamAutoOccurrenceConfig {eaocMinimizeRooms = False, eaocFinenessCost = 1 % 5, eaocNudge = fromList [(SqlBackendKey {unSqlBackendKey = 4},-11)], eaocNudgeSize = 1 % 20} occurrenceMap :: Map UserId (Maybe ExamOccurrenceId) -> Map ExamOccurrenceId [UserId] occurrenceMap userMap = foldl' (\acc (userId, maybeOccurrenceId) -> appendJust maybeOccurrenceId userId acc) Map.empty $ Map.toAscList userMap @@ -119,6 +121,7 @@ spec = do appendJust :: Maybe ExamOccurrenceId -> UserId -> Map ExamOccurrenceId [UserId] -> Map ExamOccurrenceId [UserId] appendJust Nothing _userId = id appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId] + -- | Are all rooms large enough to hold all assigned Users? fitsInRooms :: Map ExamOccurrenceId Natural -> Map UserId (Maybe ExamOccurrenceId) -> Bool @@ -129,6 +132,8 @@ spec = do roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of Nothing -> False (Just capacity) -> length userIds <= fromIntegral capacity + -- | Does the (currently surname) User fit to the displayed ranges? + -- Users with a previously assigned room are checked if the assignment stays the same, regardless of the ranges. showsCorrectRanges :: Map UserId (User, Maybe ExamOccurrenceId) -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) -> Bool