diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs index 8b4f75ddc..a02ff8c6d 100644 --- a/test/Handler/Utils/ExamSpec.hs +++ b/test/Handler/Utils/ExamSpec.hs @@ -1,6 +1,9 @@ -module Handler.Utils.ExamSpec where +{-# OPTIONS_GHC -Wwarn #-} + +module Handler.Utils.ExamSpec (spec) where import TestImport +import Data.Universe (Universe, Finite, universeF) import ModelSpec () -- instance Arbitrary User @@ -18,21 +21,26 @@ import Handler.Utils.Exam -- are these capacity values realistic? instance Arbitrary ExamOccurrence where arbitrary = ExamOccurrence - <$> arbitrary -- examOccurrenceExam - <*> arbitrary -- examOccurrenceName - <*> arbitrary -- examOccurrenceRoom - <*> arbitrary -- examOccurrenceRoomHidden - <*> elements [10, 20, 50, 100, 200] -- examOccurrenceCapacity - <*> arbitrary -- examOccurrenceStart - <*> arbitrary -- examOccurrenceEnd - <*> arbitrary -- examOccurrenceDescription + <$> arbitrary -- examOccurrenceExam + <*> arbitrary -- examOccurrenceName + <*> arbitrary -- examOccurrenceRoom + <*> arbitrary -- examOccurrenceRoomHidden + <*> frequency [(let d = fromIntegral i in ceiling $ 100 * exp(- d*d / 50), pure i) | i <- [10 ..1000]] -- examOccurrenceCapacity + <*> arbitrary -- examOccurrenceStart + <*> arbitrary -- examOccurrenceEnd + <*> arbitrary -- examOccurrenceDescription data Preselection = NoPreselection | SomePreselection - deriving (Show, Bounded, Enum) + deriving stock (Show, Bounded, Enum) + deriving anyclass (Universe, Finite) data Nudges = NoNudges | SmallNudges | LargeNudges - deriving (Show, Bounded, Enum) + deriving stock (Show, Bounded, Enum) + deriving anyclass (Universe, Finite) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c -- function Handler.Utils.examAutoOccurrence -- examAutoOccurrence :: forall seed. @@ -50,8 +58,14 @@ spec = do describe "Surname" $ do let rule :: ExamOccurrenceRule rule = ExamRoomSurname - forM_ [minBound .. maxBound] $ \nudges -> describe (show nudges) $ - forM_ [minBound .. maxBound] $ \preselection -> + forM_ universeF $ \nudges -> describe (show nudges) $ + forM_ universeF $ \preselection -> + prop (show preselection) $ propertyTest rule nudges preselection + describe "Matriculation" $ do + let rule :: ExamOccurrenceRule + rule = ExamRoomMatriculation + forM_ universeF $ \nudges -> describe (show nudges) $ + forM_ universeF $ \preselection -> prop (show preselection) $ propertyTest rule nudges preselection -- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), ExamRoomMatriculation, ExamRoomRandom where @@ -78,13 +92,13 @@ spec = do shouldBe (length userMap) (length users) shouldSatisfy userMap $ all isJust -- no room is overfull - shouldSatisfy (occurrences, userMap) $ uncurry $ fitsInRooms users + shouldSatisfy (users, occurrences, userMap) $ uncurry3 fitsInRooms -- all users match the shown ranges - shouldSatisfy (users, result) $ uncurry showsCorrectRanges + shouldSatisfy (rule, users, result) $ uncurry3 showsCorrectRanges -- | generate users without any pre-assigned rooms genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural) genUsersWithOccurrences preselection = do - rawUsers <- listOf1 $ Entity <$> arbitrary <*> arbitrary + rawUsers <- scale (50 *) $ listOf1 $ Entity <$> arbitrary <*> arbitrary occurrences <- genOccurrences $ length rawUsers -- user surnames anpassen, sodass interessante instanz users <- fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do @@ -98,7 +112,7 @@ spec = do genOccurrences numUsers = do -- TODO is this realistic? -- extra space to get nice borders - extraSpace <- elements [numUsers `div` 4 .. numUsers `div` 2] + extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2] let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace createOccurrences acc | sum (map snd acc) < totalSpaceRequirement = do @@ -146,11 +160,12 @@ spec = do || all (isJust . snd) (Map.restrictKeys users $ 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 :: Map UserId (User, Maybe ExamOccurrenceId) + showsCorrectRanges :: ExamOccurrenceRule + -> Map UserId (User, Maybe ExamOccurrenceId) -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) -> Bool - showsCorrectRanges _users (Nothing, _userMap) = False - showsCorrectRanges users (Just (examOccurrenceMappingMapping -> mappingRanges), userMap) + showsCorrectRanges _rule _users (Nothing, _userMap) = False + showsCorrectRanges rule users (Just (examOccurrenceMappingMapping -> mappingRanges), userMap) = all userFitsInRange $ Map.toAscList $ occurrenceMap userMap where userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool @@ -158,14 +173,17 @@ spec = do case (Map.lookup roomId mappingRanges, Map.lookup userId users) of (_maybeRanges, Just (User {}, Just fixedRoomId)) -> roomId == fixedRoomId - (Just ranges, Just (User {userSurname}, Nothing)) + (Just ranges, Just (User {userSurname, userMatrikelnummer}, Nothing)) -> any fitsInRange ranges where - ciSurname :: [CI Char] - ciSurname = map CI.mk $ Text.unpack userSurname + ciTag :: [CI Char] + ciTag = map CI.mk $ Text.unpack $ case rule of + ExamRoomSurname -> userSurname + ExamRoomMatriculation -> error $ show userMatrikelnummer + _rule -> error $ show rule fitsInRange :: ExamOccurrenceMappingDescription -> Bool fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} - = eaomrStart <= ciSurname && (take (length eaomrEnd) ciSurname <= eaomrEnd) + = eaomrStart <= ciTag && (take (length eaomrEnd) ciTag <= eaomrEnd) fitsInRange ExamOccurrenceMappingSpecial {} = True -- FIXME what is the meaning of special? _otherwise -> False