From 3a92fd7ed059229c102401da04729fc4b2677739 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Wed, 10 Mar 2021 17:45:26 +0100 Subject: [PATCH] chore(test): inform test about changed types --- test/Handler/Utils/ExamSpec.hs | 56 ++++++++++++++++++++-------------- 1 file changed, 33 insertions(+), 23 deletions(-) diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs index 989225abb..c0675a2cd 100644 --- a/test/Handler/Utils/ExamSpec.hs +++ b/test/Handler/Utils/ExamSpec.hs @@ -61,7 +61,7 @@ instance Arbitrary ExamOccurrence where <*> arbitrary -- examOccurrenceName <*> arbitrary -- examOccurrenceRoom <*> arbitrary -- examOccurrenceRoomHidden - <*> frequency [(let d = fromIntegral i in ceiling $ 100 * exp(- d*d / 50), pure i) | i <- [10 ..1000]] -- examOccurrenceCapacity + <*> (Just <$> frequency [(let d = fromIntegral i in ceiling $ 100 * exp(- d*d / 50), pure i) | i <- [10 ..1000]]) -- examOccurrenceCapacity <*> arbitrary -- examOccurrenceStart <*> arbitrary -- examOccurrenceEnd <*> arbitrary -- examOccurrenceDescription @@ -148,7 +148,7 @@ spec = do myAnnotate "unjustified nullResult" $ 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 -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId ExamOccurrenceCapacity) genUsersWithOccurrences preselection = do rawUsers <- listOf $ Entity <$> arbitrary <*> arbitrary -- consider applying `scale (50 *)` to uncover additional issues occurrences <- genOccurrences $ length rawUsers @@ -160,15 +160,15 @@ spec = do 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) + genOccurrences :: Int -> Gen (Map ExamOccurrenceId ExamOccurrenceCapacity) genOccurrences numUsers = do -- extra space to allow nice borders extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2] let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace createOccurrences acc - | sum (map snd acc) < totalSpaceRequirement = do + | fold (map snd acc) < Restricted totalSpaceRequirement = do Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary - createOccurrences $ (entityKey, fromIntegral $ examOccurrenceCapacity entityVal) : acc + createOccurrences $ (entityKey, view (from _examOccurrenceCapacityIso) $ fromIntegral <$> examOccurrenceCapacity entityVal) : acc | otherwise = pure acc Map.fromList <$> createOccurrences [] genNudge :: [(Int, Integer)] -> Map ExamOccurrenceId Integer -> ExamOccurrenceId -> Gen (Map ExamOccurrenceId Integer) @@ -202,7 +202,7 @@ spec = do appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId] -- | Are all rooms large enough to hold all assigned Users? fitsInRooms :: Map UserId (UserProperties, Maybe ExamOccurrenceId) - -> Map ExamOccurrenceId Natural + -> Map ExamOccurrenceId ExamOccurrenceCapacity -> Map UserId (Maybe ExamOccurrenceId) -> Bool fitsInRooms userProperties occurrences userMap @@ -211,7 +211,7 @@ spec = do roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of Nothing -> False - (Just capacity) -> length userIds <= fromIntegral capacity + (Just capacity) -> Restricted (fromIntegral $ length userIds) <= capacity || all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds) -- | No range overlap for different rooms + end is always the greater value validRangeDescription :: ExamOccurrenceRule -> ExamOccurrenceMapping ExamOccurrenceId -> Bool @@ -308,11 +308,12 @@ spec = do isNullResultJustified :: ExamAutoOccurrenceException -> ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) - -> Map ExamOccurrenceId Natural -> Bool + -> Map ExamOccurrenceId ExamOccurrenceCapacity + -> Bool isNullResultJustified ExamAutoOccurrenceExceptionRuleNoOp rule _userProperties _occurrences = not $ examOccurrenceRuleAutomatic rule isNullResultJustified ExamAutoOccurrenceExceptionNotEnoughSpace rule userProperties occurrences - = fromIntegral (length $ relevantUsers rule userProperties) > sum occurrences + = Restricted (fromIntegral $ length $ relevantUsers rule userProperties) > fold occurrences isNullResultJustified ExamAutoOccurrenceExceptionNoUsers rule userProperties _occurrences = noRelevantUsers rule userProperties isNullResultJustified ExamAutoOccurrenceExceptionRoomTooSmall rule userProperties occurrences @@ -330,23 +331,28 @@ spec = do ExamRoomMatriculation -> maybe False (not . null) userMatrikelnummer ExamRoomRandom -> True _rule -> False - mappingImpossiblePlausible :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Bool + mappingImpossiblePlausible :: ExamOccurrenceRule + -> Map UserId (UserProperties, Maybe ExamOccurrenceId) + -> Map ExamOccurrenceId ExamOccurrenceCapacity + -> Bool mappingImpossiblePlausible rule userProperties@(sortBy RFC5051.compareUnicode . mapRuleProperty rule . 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' + smallestRoom :: ExamOccurrenceCapacity + smallestRoom = maybe (Restricted 0) minimum $ fromNullable occurrences' -- If there exists a bucket with the same tag bigger than the smallest room a nullResult might be returned -- It may still work, but is not guaranteed (e.g. both the first bucket) - go :: forall a. Eq a => Natural -> [a] -> [Natural] -> Bool - go biggestUserBucket [] _occurrences = biggestUserBucket > smallestRoom + go :: forall a. Eq a => Natural -> [a] -> [ExamOccurrenceCapacity] -> Bool + go biggestUserBucket [] _occurrences = Restricted biggestUserBucket > smallestRoom go _biggestUserBucket _remainingUsers [] = True - go biggestUserBucket remainingUsers (0:t) = go biggestUserBucket remainingUsers t + go biggestUserBucket remainingUsers (Restricted 0:t) = go biggestUserBucket remainingUsers t go biggestUserBucket remainingUsers@(h:_t) (firstOccurrence:laterOccurrences) - | nextUsers <= firstOccurrence - = go (max biggestUserBucket nextUsers) remainingUsers' $ firstOccurrence - nextUsers : laterOccurrences + | Restricted nextUsers <= firstOccurrence + = go (max biggestUserBucket nextUsers) remainingUsers' + $ (under (from _examOccurrenceCapacityIso) (fmap (flip (-) nextUsers)) firstOccurrence) + : laterOccurrences | otherwise = go biggestUserBucket remainingUsers laterOccurrences where @@ -364,11 +370,15 @@ spec = do ExamRoomMatriculation -> maybe Text.empty (Text.takeEnd n) . userMatrikelnummer . user _rule -> const $ pack $ show rule -- copied and adjusted from Hander.Utils.Exam - adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural + adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId) + -> Map ExamOccurrenceId ExamOccurrenceCapacity + -> Map ExamOccurrenceId ExamOccurrenceCapacity -- ^ reduce room capacity for every pre-assigned user by 1 adjustOccurrences userProperties occurrences - = foldl' (flip $ Map.update predToPositive) (Map.filter (> 0) occurrences) $ Map.mapMaybe snd userProperties - predToPositive :: Natural -> Maybe Natural - predToPositive 0 = Nothing - predToPositive 1 = Nothing - predToPositive n = Just $ pred n + = foldl' (flip $ Map.update predToPositive) (Map.filter (> Restricted 0) occurrences) + $ Map.mapMaybe snd userProperties + predToPositive :: ExamOccurrenceCapacity -> Maybe ExamOccurrenceCapacity + predToPositive Unrestricted = Just Unrestricted + predToPositive (Restricted 0) = Nothing + predToPositive (Restricted 1) = Nothing + predToPositive (Restricted n) = Just $ Restricted $ pred n