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

chore(test): refine ExamOccurence-creation

Browse Source
This commit is contained in:
Wolfgang Witt 2021-01-30 15:59:57 +01:00 committed by Wolfgang Witt
parent 52678cddf4
commit aba5c53a0b
1 changed files with 34 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15,21 +15,19 @@ import Control.Applicative (ZipList(..))
import Handler.Utils.Exam import Handler.Utils.Exam
-- TODO
-- use frequency instead of elements?
-- are these capacity values realistic?
instance Arbitrary ExamOccurrence where instance Arbitrary ExamOccurrence where
arbitrary = ExamOccurrence <$> arbitrary -- examOccurrenceExam arbitrary = ExamOccurrence
<*> arbitrary -- examOccurrenceName <$> arbitrary -- examOccurrenceExam
<*> arbitrary -- examOccurrenceRoom <*> arbitrary -- examOccurrenceName
<*> arbitrary -- examOccurrenceRoomHidden <*> arbitrary -- examOccurrenceRoom
<*> arbitrary -- examOccurrenceCapacity <*> arbitrary -- examOccurrenceRoomHidden
<*> arbitrary -- examOccurrenceStart <*> elements [10, 20, 50, 100, 200] -- examOccurrenceCapacity
<*> arbitrary -- examOccurrenceEnd <*> arbitrary -- examOccurrenceStart
<*> arbitrary -- examOccurrenceDescription <*> arbitrary -- examOccurrenceEnd
<*> arbitrary -- examOccurrenceDescription
newtype FixedHash = FixedHash Int
instance Hashable FixedHash where
hashWithSalt _salt (FixedHash h) = h
-- function Handler.Utils.examAutoOccurrence -- function Handler.Utils.examAutoOccurrence
-- examAutoOccurrence :: forall seed. -- examAutoOccurrence :: forall seed.
@ -43,19 +41,31 @@ instance Hashable FixedHash where
-- examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users -- examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
spec :: Spec spec :: Spec
spec = do spec = do
--it "examAutoOccurrence error case" $ flip shouldSatisfy fitsInRooms
-- $ examAutoOccurrence seed rule config occurrences users
prop "property test" $ do -- TODO prop "property test" $ do -- TODO
rawUsers <- listOf1 $ Entity <$> arbitrary <*> arbitrary rawUsers <- listOf1 $ Entity <$> arbitrary <*> arbitrary
-- user surnames anpassen, sodass interessante instanz -- user surnames anpassen, sodass interessante instanz
let users = Map.fromList $ map (\Entity {entityKey, entityVal} -> (entityKey, (entityVal, Nothing))) rawUsers adjustedUsers <- forM rawUsers $ \Entity {entityKey, entityVal} -> do
rawOccurrences <- listOf $ Entity <$> arbitrary <*> arbitrary userSurname <- elements surnames
let occurrences = Map.fromList $ map (\Entity {entityKey, entityVal} -> (entityKey, examOccurrenceCapacity entityVal)) rawOccurrences pure (entityKey, (entityVal {userSurname}, Nothing))
let users = Map.fromList adjustedUsers
numUsers = length users
-- TODO is this realistic?
-- extra space to get nice borders
extraSpace <- elements [numUsers `div` 4 .. numUsers]
let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
createOccurrences acc
| sum (map snd acc) < totalSpaceRequirement = do
Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary
createOccurrences $ (entityKey, examOccurrenceCapacity entityVal) : acc
| otherwise = pure acc
occurrences <- Map.fromList <$> createOccurrences []
--let occurrences = Map.empty :: Map ExamOccurrenceId Natural --let occurrences = Map.empty :: Map ExamOccurrenceId Natural
let (maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users let (maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
pure $ ioProperty $ do pure $ ioProperty $ do
shouldSatisfy rawUsers $ not . null print $ Map.map (userSurname . fst) users
shouldSatisfy users $ not . null
shouldSatisfy occurrences $ not . null shouldSatisfy occurrences $ not . null
-- TODO test with some users fixed to certain rooms
where where
-- name list copied from test/Database/Fill.hs -- name list copied from test/Database/Fill.hs
surnames = [ "Smith", "Johnson", "Williams", "Brown" surnames = [ "Smith", "Johnson", "Williams", "Brown"
@ -87,10 +97,12 @@ spec = do
fitsInRooms occurrences (Just (examOccurrenceMappingMapping -> m), _userMap) fitsInRooms occurrences (Just (examOccurrenceMappingMapping -> m), _userMap)
= all (\(roomId, mappingSet) -> maybe False ((< length mappingSet) . fromIntegral) $ lookup roomId occurrences) $ Map.toAscList m = all (\(roomId, mappingSet) -> maybe False ((< length mappingSet) . fromIntegral) $ lookup roomId occurrences) $ Map.toAscList m
-- TODO how do I create UserId/ExamOccurrenceId?
{- {-
newtype FixedHash = FixedHash Int
instance Hashable FixedHash where
hashWithSalt _salt (FixedHash h) = h
seed = FixedHash -7234408896601100696 seed = FixedHash -7234408896601100696
rule = ExamRoomSurname rule = ExamRoomSurname
config = ExamAutoOccurrenceConfig {eaocMinimizeRooms = False, eaocFinenessCost = 1 % 5, eaocNudge = fromList [(SqlBackendKey {unSqlBackendKey = 4},-11)], eaocNudgeSize = 1 % 20} config = ExamAutoOccurrenceConfig {eaocMinimizeRooms = False, eaocFinenessCost = 1 % 5, eaocNudge = fromList [(SqlBackendKey {unSqlBackendKey = 4},-11)], eaocNudgeSize = 1 % 20}