diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs index 2566ab76a..06b5fd722 100644 --- a/test/Handler/Utils/ExamSpec.hs +++ b/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 - 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 + -- user count stays constant + annotate "number of users changed" $ shouldBe (length userMap) (length users) -- 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) - -> shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges + (Just occurrenceMapping) -> do + -- every (relevant) user got assigned a room + 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 - ExamRoomMatriculation -> pMatrikelnummer + ExamRoomSurname + | 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 - -- FIXME what about capacity-0 in occurrences? - -- what if the first word is too big for the first room? + adjustOccurrences userProperties occurrences + = foldl' (flip $ Map.update predToPositive) (Map.filter (> 0) occurrences) $ Map.mapMaybe snd userProperties predToPositive :: Natural -> Maybe Natural predToPositive 0 = Nothing predToPositive 1 = Nothing