chore(test): use annotate to easier see which test failed
This commit is contained in:
Wolfgang Witt
Wolfgang Witt
parent
479f4326b2
commit
385af53372
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user