diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs index 53b140654..8b4f75ddc 100644 --- a/test/Handler/Utils/ExamSpec.hs +++ b/test/Handler/Utils/ExamSpec.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wwarn #-} - module Handler.Utils.ExamSpec where import TestImport @@ -9,6 +7,7 @@ import ModelSpec () -- instance Arbitrary User import Test.Hspec.QuickCheck (prop) import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI @@ -30,8 +29,10 @@ instance Arbitrary ExamOccurrence where data Preselection = NoPreselection | SomePreselection + deriving (Show, Bounded, Enum) data Nudges = NoNudges | SmallNudges | LargeNudges + deriving (Show, Bounded, Enum) -- function Handler.Utils.examAutoOccurrence -- examAutoOccurrence :: forall seed. @@ -49,19 +50,9 @@ spec = do describe "Surname" $ do let rule :: ExamOccurrenceRule rule = ExamRoomSurname - describe "No Nudges" $ do - let nudges = NoNudges - prop "no preselected" $ propertyTest rule nudges NoPreselection - 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 + forM_ [minBound .. maxBound] $ \nudges -> describe (show nudges) $ + forM_ [minBound .. maxBound] $ \preselection -> + prop (show preselection) $ propertyTest rule nudges preselection -- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), ExamRoomMatriculation, ExamRoomRandom where seed :: () @@ -87,7 +78,7 @@ spec = do shouldBe (length userMap) (length users) shouldSatisfy userMap $ all isJust -- no room is overfull - shouldSatisfy (occurrences, userMap) $ uncurry fitsInRooms + shouldSatisfy (occurrences, userMap) $ uncurry $ fitsInRooms users -- all users match the shown ranges shouldSatisfy (users, result) $ uncurry showsCorrectRanges -- | generate users without any pre-assigned rooms @@ -141,16 +132,18 @@ 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 ExamOccurrenceId Natural + fitsInRooms :: Map UserId (User, Maybe ExamOccurrenceId) + -> Map ExamOccurrenceId Natural -> Map UserId (Maybe ExamOccurrenceId) -> Bool - fitsInRooms occurrences userMap + fitsInRooms users 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) -- | 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)