chore(test): abuse Show+Enum+Bounded for more concise test specification

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
+            forM_ [minBound .. maxBound] $ \nudges -> describe (show nudges) $
-                let nudges = NoNudges
+                forM_ [minBound .. maxBound] $ \preselection ->
-                prop "no preselected" $ propertyTest rule nudges NoPreselection
+                    prop (show preselection) $ propertyTest rule nudges preselection
-                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 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)