chore(test): inform test about changed types
This commit is contained in:
Wolfgang Witt
Gregor Kleen
parent
483ec3fa85
commit
3a92fd7ed0
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user