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

chore(test): add tests with nudges

Browse Source
This commit is contained in:
Wolfgang Witt 2021-02-01 14:51:53 +01:00 committed by Wolfgang Witt
parent 27f30dcd17
commit 46e6ca9217
1 changed files with 24 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -31,7 +31,7 @@ instance Arbitrary ExamOccurrence where
data Preselection = NoPreselection | SomePreselection data Preselection = NoPreselection | SomePreselection
data Nudges = NoNudges | SomeNudges | LargeNudges data Nudges = NoNudges | SmallNudges | LargeNudges
-- function Handler.Utils.examAutoOccurrence -- function Handler.Utils.examAutoOccurrence
-- examAutoOccurrence :: forall seed. -- examAutoOccurrence :: forall seed.
@ -53,6 +53,14 @@ spec = do
let nudges = NoNudges let nudges = NoNudges
prop "no preselected" $ propertyTest rule nudges NoPreselection prop "no preselected" $ propertyTest rule nudges NoPreselection
prop "some preselected" $ propertyTest rule nudges SomePreselection prop "some preselected" $ propertyTest rule nudges SomePreselection
describe "Small Nudges" $ do
let nudges = SmallNudges
prop "no preselected" $ propertyTest rule nudges NoPreselection
prop "some preselected" $ propertyTest rule nudges SomePreselection
describe "Large Nudges" $ do
let nudges = LargeNudges
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 some users fixed/preselected to certain rooms
-- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), ExamRoomMatriculation, ExamRoomRandom -- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), ExamRoomMatriculation, ExamRoomRandom
where where
@ -64,11 +72,15 @@ spec = do
propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property
propertyTest rule nudges preselection = do propertyTest rule nudges preselection = do
(users, occurrences) <- genUsersWithOccurrences preselection (users, occurrences) <- genUsersWithOccurrences 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)]
in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
LargeNudges -> let nudgeFrequency = [(7, 0), (5, 3), (5, -3), (3, 6), (3, -6), (2, 9), (2, -9),
(2, 11), (2, -11), (1, 15), (1,-15), (1, 17), (1, -17)]
in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
let config :: ExamAutoOccurrenceConfig let config :: ExamAutoOccurrenceConfig
config = case nudges of config = def {eaocNudge}
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 result@(_maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
pure $ ioProperty $ do pure $ ioProperty $ do
-- every user got assigned a room -- every user got assigned a room
@ -103,6 +115,13 @@ spec = do
createOccurrences $ (entityKey, examOccurrenceCapacity entityVal) : acc createOccurrences $ (entityKey, 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 nudgesList acc occurrenceId
= fmap appendNonZero $ frequency $ map (second pure) nudgesList
where
appendNonZero :: Integer -> Map ExamOccurrenceId Integer
appendNonZero 0 = acc
appendNonZero nudge = Map.insert occurrenceId nudge acc
-- name list copied from test/Database/Fill.hs -- name list copied from test/Database/Fill.hs
surnames :: [Text] surnames :: [Text]
surnames = [ "Smith", "Johnson", "Williams", "Brown" surnames = [ "Smith", "Johnson", "Williams", "Brown"