chore(test): increase test size + prepare for matriculation tests

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   -- examOccurrenceExam
-        <*> arbitrary                       -- examOccurrenceName
+        <*> arbitrary   -- examOccurrenceName
-        <*> arbitrary                       -- examOccurrenceRoom
+        <*> arbitrary   -- examOccurrenceRoom
-        <*> arbitrary                       -- examOccurrenceRoomHidden
+        <*> arbitrary   -- examOccurrenceRoomHidden
-        <*> elements [10, 20, 50, 100, 200] -- examOccurrenceCapacity
+        <*> frequency [(let d = fromIntegral i in ceiling $ 100 * exp(- d*d / 50), pure i) | i <- [10 ..1000]]   -- examOccurrenceCapacity
-        <*> arbitrary                       -- examOccurrenceStart
+        <*> arbitrary   -- examOccurrenceStart
-        <*> arbitrary                       -- examOccurrenceEnd
+        <*> arbitrary   -- examOccurrenceEnd
-        <*> arbitrary                       -- examOccurrenceDescription
+        <*> 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_ universeF $ \nudges -> describe (show nudges) $
-                forM_ [minBound .. maxBound] $ \preselection ->
+                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 _rule _users (Nothing, _userMap) = False
-        showsCorrectRanges users (Just (examOccurrenceMappingMapping -> mappingRanges), userMap)
+        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]
+                                ciTag :: [CI Char]
-                                ciSurname = map CI.mk $ Text.unpack userSurname
+                                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