fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(test): make UserProperties a newtype

Browse Source
This commit is contained in:
Wolfgang Witt 2021-02-08 16:45:55 +01:00 committed by Wolfgang Witt
parent 344bd420cd
commit a692899ae6
1 changed files with 36 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
test/Handler/Utils/ExamSpec.hs
View File

@ -19,7 +19,7 @@ import qualified Data.CaseInsensitive as CI
import Handler.Utils.Exam import Handler.Utils.Exam
-- direct copy&past from an (currently) unmerged pull request for hspec-expectations -- direct copy&paste from an (currently) unmerged pull request for hspec-expectations
-- https://github.com/hspec/hspec-expectations/blob/6b4a475e42b0d44008c150727dea25dd79f568f2/src/Test/Hspec/Expectations.hs -- 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 -- If you have a test case that has multiple assertions, you can use the
@ -39,8 +39,8 @@ import Handler.Utils.Exam
-- expected: False -- expected: False
-- but got: True -- but got: True
-- @ -- @
annotate :: (HasCallStack) => String -> Expectation -> Expectation myAnnotate :: (HasCallStack) => String -> Expectation -> Expectation
annotate msg = handle $ \(HUnitFailure loc exn) -> myAnnotate msg = handle $ \(HUnitFailure loc exn) ->
throwIO $ HUnitFailure loc $ case exn of throwIO $ HUnitFailure loc $ case exn of
Reason str -> Reason str ->
Reason $ msg ++ Reason $ msg ++
@ -80,11 +80,13 @@ uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
uncurry4 f (a, b, c, d) = f a b c d uncurry4 f (a, b, c, d) = f a b c d
-- | Kopie der User-Datenstruktur beschränkt auf interessante Felder (besser verständliche Show-Instanz) -- | Kopie der User-Datenstruktur beschränkt auf interessante Felder (besser verständliche Show-Instanz)
data UserProperties = UserProperties {pSurname :: Text, pMatrikelnummer :: Maybe Text} newtype UserProperties = UserProperties {user :: User}
deriving (Show)
extractProperties :: User -> UserProperties instance Show UserProperties where
extractProperties User {userSurname, userMatrikelnummer} = UserProperties userSurname userMatrikelnummer --show :: UserProperties -> String
show UserProperties {user=User {userSurname, userMatrikelnummer}}
= "User {userSurname=" ++ show userSurname
++ ", userMatrikelnummer=" ++ show userMatrikelnummer ++ "}"
-- function Handler.Utils.examAutoOccurrence -- function Handler.Utils.examAutoOccurrence
-- examAutoOccurrence :: forall seed. -- examAutoOccurrence :: forall seed.
@ -99,20 +101,15 @@ extractProperties User {userSurname, userMatrikelnummer} = UserProperties userSu
spec :: Spec spec :: Spec
spec = do spec = do
describe "examAutoOccurrence" $ do describe "examAutoOccurrence" $ do
describe "Surname" $ do --describe "Surname" $ testWithRule ExamOccurrenceRule
let rule :: ExamOccurrenceRule describe "Matriculation" $ testWithRule ExamRoomMatriculation
rule = ExamRoomSurname -- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), (ExamRoomMatriculation), ExamRoomRandom
forM_ universeF $ \nudges -> describe (show nudges) $
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 where
testWithRule :: ExamOccurrenceRule -> Spec
testWithRule rule =
forM_ {-universeF-}[NoNudges] $ \nudges -> describe (show nudges) $
forM_ {-universeF-}[NoPreselection] $ \preselection ->
prop (show preselection) $ propertyTest rule nudges preselection
seed :: () seed :: ()
seed = () seed = ()
propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property
@ -130,11 +127,11 @@ spec = do
(maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users (maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
pure $ ioProperty $ do pure $ ioProperty $ do
-- user count stays constant -- user count stays constant
annotate "number of users changed" $ shouldBe (length userMap) (length users) myAnnotate "number of users changed" $ shouldBe (length userMap) (length users)
-- no room is overfull -- no room is overfull
let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId) let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
userProperties = Map.map (first extractProperties) users userProperties = Map.map (first UserProperties) users
annotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms myAnnotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
case maybeMapping of case maybeMapping of
(Just occurrenceMapping) -> do (Just occurrenceMapping) -> do
-- every (relevant) user got assigned a room -- every (relevant) user got assigned a room
@ -146,12 +143,12 @@ spec = do
-- every user with a userMatrikelnummer got a room -- every user with a userMatrikelnummer got a room
-- fail on unknown user -- fail on unknown user
|| (fromMaybe False $ isNothing . userMatrikelnummer . fst <$> Map.lookup userId users) || (fromMaybe False $ isNothing . userMatrikelnummer . fst <$> Map.lookup userId users)
annotate "user didn't get a room" $ shouldSatisfy userMap $ foldr foldFn True . Map.toList myAnnotate "user didn't get a room" $ shouldSatisfy userMap $ foldr foldFn True . Map.toList
-- all users match the shown ranges -- all users match the shown ranges
annotate "shown ranges don't match userMap" myAnnotate "shown ranges don't match userMap"
$ shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges $ shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges
-- is a nullResult justified? -- is a nullResult justified?
Nothing -> annotate "unjustified nullResult" Nothing -> myAnnotate "unjustified nullResult"
$ shouldSatisfy (rule, userProperties, occurrences) $ uncurry3 isNullResultJustified $ shouldSatisfy (rule, userProperties, occurrences) $ uncurry3 isNullResultJustified
-- | generate users without any pre-assigned rooms -- | generate users without any pre-assigned rooms
genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural) genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
@ -168,8 +165,7 @@ spec = do
pure (users, occurrences) pure (users, occurrences)
genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural) genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural)
genOccurrences numUsers = do genOccurrences numUsers = do
-- TODO is this realistic? -- extra space to allow nice borders
-- extra space to get nice borders
extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2] extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2]
let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
createOccurrences acc createOccurrences acc
@ -226,49 +222,30 @@ spec = do
showsCorrectRanges rule userProperties (examOccurrenceMappingMapping -> mappingRanges) userMap showsCorrectRanges rule userProperties (examOccurrenceMappingMapping -> mappingRanges) userMap
= all userFitsInRange $ Map.toAscList $ occurrenceMap userMap = all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
where 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 :: (ExamOccurrenceId, [UserId]) -> Bool
userFitsInRange (roomId, userIds) = flip all userIds $ \userId -> userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
case (Map.lookup roomId mappingRanges, Map.lookup userId userProperties) of case (Map.lookup roomId mappingRanges, Map.lookup userId userProperties) of
(_maybeRanges, Just (_userProperty, Just fixedRoomId)) (_maybeRanges, Just (_userProperty, Just fixedRoomId))
-> roomId == fixedRoomId -> roomId == fixedRoomId
(Just ranges, Just (UserProperties {pSurname, pMatrikelnummer}, Nothing)) (Just ranges, Just (UserProperties User {userSurname, userMatrikelnummer}, Nothing))
-> any fitsInRange ranges -> any fitsInRange ranges
where where
ciTag :: Maybe [CI Char] ciTag :: Maybe [CI Char]
ciTag = map CI.mk . Text.unpack <$> case rule of ciTag = map CI.mk . Text.unpack <$> case rule of
ExamRoomSurname ExamRoomSurname
| Text.null pSurname -> Nothing | Text.null userSurname -> Nothing
| otherwise-> Just pSurname | otherwise-> Just userSurname
ExamRoomMatriculation ExamRoomMatriculation
| maybe True Text.null pMatrikelnummer -> Nothing | maybe True Text.null userMatrikelnummer -> Nothing
| otherwise -> pMatrikelnummer | otherwise -> userMatrikelnummer
_rule -> Nothing _rule -> Nothing
fitsInRange :: ExamOccurrenceMappingDescription -> Bool fitsInRange :: ExamOccurrenceMappingDescription -> Bool
fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = case ciTag of fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = case ciTag of
Nothing -> True Nothing -> True
(Just tag) -> if (eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd) (Just tag) -> (eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd)
then True
else traceShow (
transformTag eaomrStart tag,
transformTag eaomrEnd tag,
pMatrikelnummer,
pSurname,
ranges
) False
fitsInRange ExamOccurrenceMappingSpecial {} fitsInRange ExamOccurrenceMappingSpecial {}
= True -- FIXME what is the meaning of special? = True -- FIXME what is the meaning of special?
transformTag :: [a] -> [CI Char] -> [CI Char] transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char]
transformTag (length -> rangeLength) = case rule of transformTag (length -> rangeLength) = case rule of
ExamRoomMatriculation -> reverse . take rangeLength . reverse ExamRoomMatriculation -> reverse . take rangeLength . reverse
_rule -> take rangeLength _rule -> take rangeLength
@ -283,9 +260,9 @@ spec = do
noRelevantUsers rule = null . Map.filter (isRelevantUser rule) noRelevantUsers rule = null . Map.filter (isRelevantUser rule)
isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool
isRelevantUser _rule (_user, Just _assignedRoom) = False isRelevantUser _rule (_user, Just _assignedRoom) = False
isRelevantUser rule (UserProperties {pSurname, pMatrikelnummer}, Nothing) = case rule of isRelevantUser rule (UserProperties User {userSurname, userMatrikelnummer}, Nothing) = case rule of
ExamRoomSurname -> not $ null pSurname ExamRoomSurname -> not $ null userSurname
ExamRoomMatriculation -> maybe False (not . null) pMatrikelnummer ExamRoomMatriculation -> maybe False (not . null) userMatrikelnummer
_rule -> False _rule -> False
mappingImpossible :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Bool mappingImpossible :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Bool
mappingImpossible mappingImpossible
@ -304,8 +281,8 @@ spec = do
(fromIntegral . length -> nextUsers, remainingUsers') = span (== h) remainingUsers (fromIntegral . length -> nextUsers, remainingUsers') = span (== h) remainingUsers
ruleProperty :: ExamOccurrenceRule -> UserProperties -> Maybe Text ruleProperty :: ExamOccurrenceRule -> UserProperties -> Maybe Text
ruleProperty rule = case rule of ruleProperty rule = case rule of
ExamRoomSurname -> Just . pSurname ExamRoomSurname -> Just . userSurname . user
ExamRoomMatriculation -> pMatrikelnummer ExamRoomMatriculation -> userMatrikelnummer . user
_rule -> const Nothing _rule -> const Nothing
-- copied and adjusted from Hander.Utils.Exam -- copied and adjusted from Hander.Utils.Exam
adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural