fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(test): inform test about changed types

Browse Source
This commit is contained in:
Wolfgang Witt 2021-03-10 17:45:26 +01:00 committed by Gregor Kleen
parent 483ec3fa85
commit 3a92fd7ed0
1 changed files with 33 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
test/Handler/Utils/ExamSpec.hs
View File

@ -61,7 +61,7 @@ instance Arbitrary ExamOccurrence where
<*> arbitrary -- examOccurrenceName <*> arbitrary -- examOccurrenceName
<*> arbitrary -- examOccurrenceRoom <*> arbitrary -- examOccurrenceRoom
<*> arbitrary -- examOccurrenceRoomHidden <*> 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 -- examOccurrenceStart
<*> arbitrary -- examOccurrenceEnd <*> arbitrary -- examOccurrenceEnd
<*> arbitrary -- examOccurrenceDescription <*> arbitrary -- examOccurrenceDescription
@ -148,7 +148,7 @@ spec = do
myAnnotate "unjustified nullResult" myAnnotate "unjustified nullResult"
$ shouldSatisfy (autoOccurrenceException, rule, userProperties, occurrences) $ uncurry4 isNullResultJustified $ shouldSatisfy (autoOccurrenceException, rule, userProperties, occurrences) $ uncurry4 isNullResultJustified
-- | generate users without any pre-assigned rooms -- | 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 genUsersWithOccurrences preselection = do
rawUsers <- listOf $ Entity <$> arbitrary <*> arbitrary -- consider applying `scale (50 *)` to uncover additional issues rawUsers <- listOf $ Entity <$> arbitrary <*> arbitrary -- consider applying `scale (50 *)` to uncover additional issues
occurrences <- genOccurrences $ length rawUsers occurrences <- genOccurrences $ length rawUsers
@ -160,15 +160,15 @@ spec = do
SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)] SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)]
pure (entityKey, (entityVal {userSurname}, assignedRoom)) pure (entityKey, (entityVal {userSurname}, assignedRoom))
pure (users, occurrences) pure (users, occurrences)
genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural) genOccurrences :: Int -> Gen (Map ExamOccurrenceId ExamOccurrenceCapacity)
genOccurrences numUsers = do genOccurrences numUsers = do
-- extra space to allow nice borders -- extra space to allow nice borders
extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2] extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2]
let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
createOccurrences acc createOccurrences acc
| sum (map snd acc) < totalSpaceRequirement = do | fold (map snd acc) < Restricted totalSpaceRequirement = do
Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary
createOccurrences $ (entityKey, fromIntegral $ examOccurrenceCapacity entityVal) : acc createOccurrences $ (entityKey, view (from _examOccurrenceCapacityIso) $ fromIntegral <$> examOccurrenceCapacity entityVal) : acc
| otherwise = pure acc | otherwise = pure acc
Map.fromList <$> createOccurrences [] Map.fromList <$> createOccurrences []
genNudge :: [(Int, Integer)] -> Map ExamOccurrenceId Integer -> ExamOccurrenceId -> Gen (Map ExamOccurrenceId Integer) 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] appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId]
-- | Are all rooms large enough to hold all assigned Users? -- | Are all rooms large enough to hold all assigned Users?
fitsInRooms :: Map UserId (UserProperties, Maybe ExamOccurrenceId) fitsInRooms :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
-> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId ExamOccurrenceCapacity
-> Map UserId (Maybe ExamOccurrenceId) -> Map UserId (Maybe ExamOccurrenceId)
-> Bool -> Bool
fitsInRooms userProperties occurrences userMap fitsInRooms userProperties occurrences userMap
@ -211,7 +211,7 @@ spec = do
roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool
roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of
Nothing -> False Nothing -> False
(Just capacity) -> length userIds <= fromIntegral capacity (Just capacity) -> Restricted (fromIntegral $ length userIds) <= capacity
|| all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds) || all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds)
-- | No range overlap for different rooms + end is always the greater value -- | No range overlap for different rooms + end is always the greater value
validRangeDescription :: ExamOccurrenceRule -> ExamOccurrenceMapping ExamOccurrenceId -> Bool validRangeDescription :: ExamOccurrenceRule -> ExamOccurrenceMapping ExamOccurrenceId -> Bool
@ -308,11 +308,12 @@ spec = do
isNullResultJustified :: ExamAutoOccurrenceException isNullResultJustified :: ExamAutoOccurrenceException
-> ExamOccurrenceRule -> ExamOccurrenceRule
-> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
-> Map ExamOccurrenceId Natural -> Bool -> Map ExamOccurrenceId ExamOccurrenceCapacity
-> Bool
isNullResultJustified ExamAutoOccurrenceExceptionRuleNoOp rule _userProperties _occurrences isNullResultJustified ExamAutoOccurrenceExceptionRuleNoOp rule _userProperties _occurrences
= not $ examOccurrenceRuleAutomatic rule = not $ examOccurrenceRuleAutomatic rule
isNullResultJustified ExamAutoOccurrenceExceptionNotEnoughSpace rule userProperties occurrences 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 isNullResultJustified ExamAutoOccurrenceExceptionNoUsers rule userProperties _occurrences
= noRelevantUsers rule userProperties = noRelevantUsers rule userProperties
isNullResultJustified ExamAutoOccurrenceExceptionRoomTooSmall rule userProperties occurrences isNullResultJustified ExamAutoOccurrenceExceptionRoomTooSmall rule userProperties occurrences
@ -330,23 +331,28 @@ spec = do
ExamRoomMatriculation -> maybe False (not . null) userMatrikelnummer ExamRoomMatriculation -> maybe False (not . null) userMatrikelnummer
ExamRoomRandom -> True ExamRoomRandom -> True
_rule -> False _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 mappingImpossiblePlausible
rule rule
userProperties@(sortBy RFC5051.compareUnicode . mapRuleProperty rule . Map.elems . relevantUsers rule -> users') userProperties@(sortBy RFC5051.compareUnicode . mapRuleProperty rule . Map.elems . relevantUsers rule -> users')
(map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go 0 users' occurrences' (map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go 0 users' occurrences'
where where
smallestRoom :: Natural smallestRoom :: ExamOccurrenceCapacity
smallestRoom = maybe 0 minimum $ fromNullable occurrences' 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 -- 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) -- It may still work, but is not guaranteed (e.g. both the first bucket)
go :: forall a. Eq a => Natural -> [a] -> [Natural] -> Bool go :: forall a. Eq a => Natural -> [a] -> [ExamOccurrenceCapacity] -> Bool
go biggestUserBucket [] _occurrences = biggestUserBucket > smallestRoom go biggestUserBucket [] _occurrences = Restricted biggestUserBucket > smallestRoom
go _biggestUserBucket _remainingUsers [] = True 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) go biggestUserBucket remainingUsers@(h:_t) (firstOccurrence:laterOccurrences)
| nextUsers <= firstOccurrence | Restricted nextUsers <= firstOccurrence
= go (max biggestUserBucket nextUsers) remainingUsers' $ firstOccurrence - nextUsers : laterOccurrences = go (max biggestUserBucket nextUsers) remainingUsers'
$ (under (from _examOccurrenceCapacityIso) (fmap (flip (-) nextUsers)) firstOccurrence)
: laterOccurrences
| otherwise | otherwise
= go biggestUserBucket remainingUsers laterOccurrences = go biggestUserBucket remainingUsers laterOccurrences
where where
@ -364,11 +370,15 @@ spec = do
ExamRoomMatriculation -> maybe Text.empty (Text.takeEnd n) . userMatrikelnummer . user ExamRoomMatriculation -> maybe Text.empty (Text.takeEnd n) . userMatrikelnummer . user
_rule -> const $ pack $ show rule _rule -> const $ pack $ show rule
-- copied and adjusted from Hander.Utils.Exam -- 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 -- ^ reduce room capacity for every pre-assigned user by 1
adjustOccurrences userProperties occurrences adjustOccurrences userProperties occurrences
= foldl' (flip $ Map.update predToPositive) (Map.filter (> 0) occurrences) $ Map.mapMaybe snd userProperties = foldl' (flip $ Map.update predToPositive) (Map.filter (> Restricted 0) occurrences)
predToPositive :: Natural -> Maybe Natural $ Map.mapMaybe snd userProperties
predToPositive 0 = Nothing predToPositive :: ExamOccurrenceCapacity -> Maybe ExamOccurrenceCapacity
predToPositive 1 = Nothing predToPositive Unrestricted = Just Unrestricted
predToPositive n = Just $ pred n predToPositive (Restricted 0) = Nothing
predToPositive (Restricted 1) = Nothing
predToPositive (Restricted n) = Just $ Restricted $ pred n