chore(test): prepare for ExamRoomMatriculation-Tests
This commit is contained in:
Wolfgang Witt
Wolfgang Witt
parent
44a52e034f
commit
4dccd2830b
@ -42,6 +42,13 @@ data Nudges = NoNudges | SmallNudges | LargeNudges
|
||||
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
|
||||
uncurry3 f (a, b, c) = f a b c
|
||||
|
||||
-- | Kopie der User-Datenstruktur beschränkt auf interessante Felder (besser verständliche Show-Instanz)
|
||||
data UserProperties = UserProperties {pSurname :: Text, pMatrikelnummer :: Maybe Text}
|
||||
deriving (Show)
|
||||
|
||||
extractProperties :: User -> UserProperties
|
||||
extractProperties User {userSurname, userMatrikelnummer} = UserProperties userSurname userMatrikelnummer
|
||||
|
||||
-- function Handler.Utils.examAutoOccurrence
|
||||
-- examAutoOccurrence :: forall seed.
|
||||
-- Hashable seed
|
||||
@ -55,12 +62,14 @@ uncurry3 f (a, b, c) = f a b c
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "examAutoOccurrence" $ do
|
||||
{-
|
||||
describe "Surname" $ do
|
||||
let rule :: ExamOccurrenceRule
|
||||
rule = ExamRoomSurname
|
||||
forM_ universeF $ \nudges -> describe (show nudges) $
|
||||
forM_ universeF $ \preselection ->
|
||||
prop (show preselection) $ propertyTest rule nudges preselection
|
||||
-}
|
||||
describe "Matriculation" $ do
|
||||
let rule :: ExamOccurrenceRule
|
||||
rule = ExamRoomMatriculation
|
||||
@ -76,7 +85,7 @@ spec = do
|
||||
--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
|
||||
(users, occurrences) <- genUsersWithOccurrences rule preselection
|
||||
eaocNudge <- case nudges of
|
||||
NoNudges -> pure Map.empty
|
||||
SmallNudges -> let nudgeFrequency = [(10, 0), (5, 1), (5, -1), (3, 2), (3, -2), (1, 3), (1, -3)]
|
||||
@ -90,14 +99,18 @@ spec = do
|
||||
pure $ ioProperty $ do
|
||||
-- every user got assigned a room
|
||||
shouldBe (length userMap) (length users)
|
||||
shouldSatisfy userMap $ all isJust
|
||||
shouldSatisfy userMap $ all isJust -- FIXME fails for users without a Just userMatrikelnummer
|
||||
-- no room is overfull
|
||||
shouldSatisfy (users, occurrences, userMap) $ uncurry3 fitsInRooms
|
||||
let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||
userProperties = Map.map (first extractProperties) users
|
||||
shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
|
||||
-- all users match the shown ranges
|
||||
shouldSatisfy (rule, users, result) $ uncurry3 showsCorrectRanges
|
||||
shouldSatisfy (rule, userProperties, result) $ uncurry3 showsCorrectRanges
|
||||
-- | generate users without any pre-assigned rooms
|
||||
genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
|
||||
genUsersWithOccurrences preselection = do
|
||||
genUsersWithOccurrences :: ExamOccurrenceRule
|
||||
-> Preselection
|
||||
-> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
|
||||
genUsersWithOccurrences rule preselection = do
|
||||
rawUsers <- scale (50 *) $ listOf1 $ Entity <$> arbitrary <*> arbitrary
|
||||
occurrences <- genOccurrences $ length rawUsers
|
||||
-- user surnames anpassen, sodass interessante instanz
|
||||
@ -107,7 +120,16 @@ spec = do
|
||||
NoPreselection -> pure Nothing
|
||||
SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)]
|
||||
pure (entityKey, (entityVal {userSurname}, assignedRoom))
|
||||
pure (users, occurrences)
|
||||
case rule of
|
||||
ExamRoomMatriculation | null matrUsersList -> discard
|
||||
where
|
||||
-- copied directly from examAutoOccurrence, user' definition
|
||||
-- FIXME if it is empty an error is raised
|
||||
matrUsersList = [ (map CI.mk $ unpack matriculation', Set.singleton uid)
|
||||
| (uid, (User{..}, Nothing)) <- Map.toList users
|
||||
, matriculation' <- userMatrikelnummer ^.. _Just . filtered (not . null)
|
||||
]
|
||||
_rule -> pure (users, occurrences)
|
||||
genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural)
|
||||
genOccurrences numUsers = do
|
||||
-- TODO is this realistic?
|
||||
@ -146,44 +168,45 @@ spec = do
|
||||
appendJust Nothing _userId = id
|
||||
appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId]
|
||||
-- | Are all rooms large enough to hold all assigned Users?
|
||||
fitsInRooms :: Map UserId (User, Maybe ExamOccurrenceId)
|
||||
fitsInRooms :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||
-> Map ExamOccurrenceId Natural
|
||||
-> Map UserId (Maybe ExamOccurrenceId)
|
||||
-> Bool
|
||||
fitsInRooms users occurrences userMap
|
||||
fitsInRooms userProperties occurrences userMap
|
||||
= all roomIsBigEnough $ Map.toAscList $ occurrenceMap userMap
|
||||
where
|
||||
roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool
|
||||
roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of
|
||||
Nothing -> False
|
||||
(Just capacity) -> length userIds <= fromIntegral capacity
|
||||
|| all (isJust . snd) (Map.restrictKeys users $ Set.fromList userIds)
|
||||
|| all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds)
|
||||
-- | 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 :: ExamOccurrenceRule
|
||||
-> Map UserId (User, Maybe ExamOccurrenceId)
|
||||
-> Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
|
||||
-> Bool
|
||||
showsCorrectRanges _rule _users (Nothing, _userMap) = False
|
||||
showsCorrectRanges rule users (Just (examOccurrenceMappingMapping -> mappingRanges), userMap)
|
||||
showsCorrectRanges _rule _userProperties (Nothing, _userMap) = False
|
||||
showsCorrectRanges rule userProperties (Just (examOccurrenceMappingMapping -> mappingRanges), userMap)
|
||||
= all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
|
||||
where
|
||||
userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
|
||||
userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
|
||||
case (Map.lookup roomId mappingRanges, Map.lookup userId users) of
|
||||
(_maybeRanges, Just (User {}, Just fixedRoomId))
|
||||
case (Map.lookup roomId mappingRanges, Map.lookup userId userProperties) of
|
||||
(_maybeRanges, Just (_userProperty, Just fixedRoomId))
|
||||
-> roomId == fixedRoomId
|
||||
(Just ranges, Just (User {userSurname, userMatrikelnummer}, Nothing))
|
||||
(Just ranges, Just (UserProperties {pSurname, pMatrikelnummer}, Nothing))
|
||||
-> any fitsInRange ranges
|
||||
where
|
||||
ciTag :: [CI Char]
|
||||
ciTag = map CI.mk $ Text.unpack $ case rule of
|
||||
ExamRoomSurname -> userSurname
|
||||
ExamRoomMatriculation -> error $ show userMatrikelnummer
|
||||
_rule -> error $ show rule
|
||||
ciTag :: Maybe [CI Char]
|
||||
ciTag = map CI.mk . Text.unpack <$> case rule of
|
||||
ExamRoomSurname -> Just pSurname
|
||||
ExamRoomMatriculation -> pMatrikelnummer
|
||||
_rule -> Nothing
|
||||
fitsInRange :: ExamOccurrenceMappingDescription -> Bool
|
||||
fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
|
||||
= eaomrStart <= ciTag && (take (length eaomrEnd) ciTag <= eaomrEnd)
|
||||
fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = case ciTag of
|
||||
Nothing -> True
|
||||
(Just tag) -> eaomrStart <= tag && (take (length eaomrEnd) tag <= eaomrEnd)
|
||||
fitsInRange ExamOccurrenceMappingSpecial {}
|
||||
= True -- FIXME what is the meaning of special?
|
||||
_otherwise -> False
|
||||
|
||||
Loading…
Reference in New Issue
Block a user