chore(test): use annotate to easier see which test failed

test/Handler/Utils/ExamSpec.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
 {-# OPTIONS_GHC -Wwarn #-}
 
 module Handler.Utils.ExamSpec (spec) where
@@ -8,6 +9,7 @@ import Data.Universe (Universe, Finite, universeF)
 import ModelSpec ()     -- instance Arbitrary User
 
 import Test.Hspec.QuickCheck (prop)
+import Test.HUnit.Lang (HUnitFailure(..), FailureReason(..))
 
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -16,6 +18,41 @@ import qualified Data.CaseInsensitive as CI
 
 import Handler.Utils.Exam
 
+
+-- direct copy&past from an (currently) unmerged pull request for hspec-expectations
+-- https://github.com/hspec/hspec-expectations/blob/6b4a475e42b0d44008c150727dea25dd79f568f2/src/Test/Hspec/Expectations.hs
+-- |
+-- If you have a test case that has multiple assertions, you can use the
+-- 'annotate' function to provide a string message that will be attached to
+-- the 'Expectation'.
+--
+-- @
+-- describe "annotate" $ do
+--   it "adds the message" $ do
+--     annotate "obvious falsehood" $ do
+--       True `shouldBe` False
+--
+-- ========>
+--
+-- 1) annotate, adds the message
+--       obvious falsehood
+--       expected: False
+--        but got: True
+-- @
+annotate :: (HasCallStack) => String -> Expectation -> Expectation
+annotate msg = handle $ \(HUnitFailure loc exn) ->
+  throwIO $ HUnitFailure loc $ case exn of
+    Reason str ->
+      Reason $ msg ++
+          if null str then str else ": " <> str
+    ExpectedButGot mmsg expected got ->
+      let
+        mmsg' =
+          Just $ msg <> maybe "" (": " <>) mmsg
+      in
+        ExpectedButGot mmsg' expected got
+
+
 instance Arbitrary ExamOccurrence where
     arbitrary = ExamOccurrence
         <$> arbitrary   -- examOccurrenceExam
@@ -92,27 +129,30 @@ spec = do
                 config = def {eaocNudge}
                 (maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
             pure $ ioProperty $ do
-                -- every (relevant) user got assigned a room
+                -- user count stays constant
-                shouldBe (length userMap) (length users)
+                annotate "number of users changed" $ shouldBe (length userMap) (length users)
-                let foldFn :: (UserId, Maybe ExamOccurrenceId) -> Bool -> Bool
-                    foldFn _userMapping False = False
-                    foldFn (_userId, Just _occurrenceId) True = True
-                    foldFn (userId, Nothing) True
-                        = (rule == ExamRoomMatriculation)
-                        -- every user with a userMatrikelnummer got a room
-                        -- fail on unknown user
-                        || (fromMaybe False $ isNothing . userMatrikelnummer . fst <$> Map.lookup userId users)
-                shouldSatisfy userMap $ foldr foldFn True . Map.toList
                 -- no room is overfull
                 let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
                     userProperties = Map.map (first extractProperties) users
-                shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
+                annotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
                 case maybeMapping of
-                    -- all users match the shown ranges
+                    (Just occurrenceMapping) -> do
-                    (Just occurrenceMapping)
+                        -- every (relevant) user got assigned a room
-                        -> shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges
+                        let foldFn :: (UserId, Maybe ExamOccurrenceId) -> Bool -> Bool
+                            foldFn _userMapping False = False
+                            foldFn (_userId, Just _occurrenceId) True = True
+                            foldFn (userId, Nothing) True
+                                = (rule == ExamRoomMatriculation)
+                                -- every user with a userMatrikelnummer got a room
+                                -- fail on unknown user
+                                || (fromMaybe False $ isNothing . userMatrikelnummer . fst <$> Map.lookup userId users)
+                        annotate "user didn't get a room" $ shouldSatisfy userMap $ foldr foldFn True . Map.toList
+                        -- all users match the shown ranges
+                        annotate "shown ranges don't match userMap"
+                            $ shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges
                     -- is a nullResult justified?
-                    Nothing -> shouldSatisfy (rule, userProperties, occurrences) $ uncurry3 isNullResultJustified
+                    Nothing -> annotate "unjustified nullResult"
+                            $ shouldSatisfy (rule, userProperties, occurrences) $ uncurry3 isNullResultJustified
         -- | generate users without any pre-assigned rooms
         genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
         genUsersWithOccurrences preselection = do
@@ -186,6 +226,17 @@ spec = do
         showsCorrectRanges rule userProperties (examOccurrenceMappingMapping -> mappingRanges) userMap
             = all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
             where
+                {-
+                minMatrLength :: Int
+                minMatrLength = case fromNullable $ Map.map (fromMaybe 0 . fmap length . pMatrikelnummer . fst)
+                                    $ Map.filter (isRelevantUser rule) userProperties of
+                    Nothing -> 0
+                    (Just matrLengthsMap) -> minimum matrLengthsMap
+                matrLengths :: [Int]
+                matrLengths = case rule of
+                    ExamRoomMatriculation -> [1..minMatrLength]
+                    _rule -> [0]
+                -}
                 userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
                 userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
                     case (Map.lookup roomId mappingRanges, Map.lookup userId userProperties) of
@@ -196,15 +247,31 @@ spec = do
                             where
                                 ciTag :: Maybe [CI Char]
                                 ciTag = map CI.mk . Text.unpack <$> case rule of
-                                    ExamRoomSurname -> Just pSurname
+                                    ExamRoomSurname
-                                    ExamRoomMatriculation -> pMatrikelnummer
+                                        | Text.null pSurname -> Nothing
+                                        | otherwise-> Just pSurname
+                                    ExamRoomMatriculation
+                                        | maybe True Text.null pMatrikelnummer -> Nothing
+                                        | otherwise -> pMatrikelnummer
                                     _rule -> Nothing
                                 fitsInRange :: ExamOccurrenceMappingDescription -> Bool
                                 fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = case ciTag of
                                     Nothing -> True
-                                    (Just tag) -> eaomrStart <= tag && (take (length eaomrEnd) tag <= eaomrEnd)
+                                    (Just tag) -> if (eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd)
+                                                    then True
+                                                    else traceShow (
+                                                            transformTag eaomrStart tag,
+                                                            transformTag eaomrEnd tag,
+                                                            pMatrikelnummer,
+                                                            pSurname,
+                                                            ranges
+                                                        ) False
                                 fitsInRange ExamOccurrenceMappingSpecial {}
                                     = True      -- FIXME what is the meaning of special?
+                                transformTag :: [a] -> [CI Char] -> [CI Char]
+                                transformTag (length -> rangeLength) = case rule of
+                                    ExamRoomMatriculation -> reverse . take rangeLength . reverse
+                                    _rule -> take rangeLength
                         _otherwise -> False
         -- | Is mapping impossible?
         isNullResultJustified :: ExamOccurrenceRule
@@ -243,9 +310,8 @@ spec = do
         -- copied and adjusted from Hander.Utils.Exam
         adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
         -- ^ reduce room capacity for every pre-assigned user by 1
-        adjustOccurrences userProperties occurrences = foldl' (flip $ Map.update predToPositive) occurrences $ Map.mapMaybe snd userProperties
+        adjustOccurrences userProperties occurrences
-        -- FIXME what about capacity-0 in occurrences?
+            = foldl' (flip $ Map.update predToPositive) (Map.filter (> 0) occurrences) $ Map.mapMaybe snd userProperties
-        -- what if the first word is too big for the first room?
         predToPositive :: Natural -> Maybe Natural
         predToPositive 0 = Nothing
         predToPositive 1 = Nothing