chore(test): make UserProperties a newtype
This commit is contained in:
Wolfgang Witt
Wolfgang Witt
parent
344bd420cd
commit
a692899ae6
@ -19,7 +19,7 @@ import qualified Data.CaseInsensitive as CI
|
||||
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
|
||||
-- |
|
||||
-- If you have a test case that has multiple assertions, you can use the
|
||||
@ -39,8 +39,8 @@ import Handler.Utils.Exam
|
||||
-- expected: False
|
||||
-- but got: True
|
||||
-- @
|
||||
annotate :: (HasCallStack) => String -> Expectation -> Expectation
|
||||
annotate msg = handle $ \(HUnitFailure loc exn) ->
|
||||
myAnnotate :: (HasCallStack) => String -> Expectation -> Expectation
|
||||
myAnnotate msg = handle $ \(HUnitFailure loc exn) ->
|
||||
throwIO $ HUnitFailure loc $ case exn of
|
||||
Reason str ->
|
||||
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
|
||||
|
||||
-- | Kopie der User-Datenstruktur beschränkt auf interessante Felder (besser verständliche Show-Instanz)
|
||||
data UserProperties = UserProperties {pSurname :: Text, pMatrikelnummer :: Maybe Text}
|
||||
deriving (Show)
|
||||
newtype UserProperties = UserProperties {user :: User}
|
||||
|
||||
extractProperties :: User -> UserProperties
|
||||
extractProperties User {userSurname, userMatrikelnummer} = UserProperties userSurname userMatrikelnummer
|
||||
instance Show UserProperties where
|
||||
--show :: UserProperties -> String
|
||||
show UserProperties {user=User {userSurname, userMatrikelnummer}}
|
||||
= "User {userSurname=" ++ show userSurname
|
||||
++ ", userMatrikelnummer=" ++ show userMatrikelnummer ++ "}"
|
||||
|
||||
-- function Handler.Utils.examAutoOccurrence
|
||||
-- examAutoOccurrence :: forall seed.
|
||||
@ -99,20 +101,15 @@ extractProperties User {userSurname, userMatrikelnummer} = UserProperties userSu
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "examAutoOccurrence" $ do
|
||||
describe "Surname" $ do
|
||||
let rule :: ExamOccurrenceRule
|
||||
rule = ExamRoomSurname
|
||||
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
|
||||
--describe "Surname" $ testWithRule ExamOccurrenceRule
|
||||
describe "Matriculation" $ testWithRule ExamRoomMatriculation
|
||||
-- TODO test with ExamRoomManual, ExamRoomFifo, (ExamRoomSurname), (ExamRoomMatriculation), ExamRoomRandom
|
||||
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 = ()
|
||||
propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property
|
||||
@ -130,11 +127,11 @@ spec = do
|
||||
(maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
|
||||
pure $ ioProperty $ do
|
||||
-- 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
|
||||
let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
||||
userProperties = Map.map (first extractProperties) users
|
||||
annotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
|
||||
userProperties = Map.map (first UserProperties) users
|
||||
myAnnotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
|
||||
case maybeMapping of
|
||||
(Just occurrenceMapping) -> do
|
||||
-- every (relevant) user got assigned a room
|
||||
@ -146,12 +143,12 @@ spec = do
|
||||
-- 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
|
||||
myAnnotate "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"
|
||||
myAnnotate "shown ranges don't match userMap"
|
||||
$ shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges
|
||||
-- is a nullResult justified?
|
||||
Nothing -> annotate "unjustified nullResult"
|
||||
Nothing -> myAnnotate "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)
|
||||
@ -168,8 +165,7 @@ spec = do
|
||||
pure (users, occurrences)
|
||||
genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural)
|
||||
genOccurrences numUsers = do
|
||||
-- TODO is this realistic?
|
||||
-- extra space to get nice borders
|
||||
-- extra space to allow nice borders
|
||||
extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2]
|
||||
let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
|
||||
createOccurrences acc
|
||||
@ -226,49 +222,30 @@ 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
|
||||
(_maybeRanges, Just (_userProperty, Just fixedRoomId))
|
||||
-> roomId == fixedRoomId
|
||||
(Just ranges, Just (UserProperties {pSurname, pMatrikelnummer}, Nothing))
|
||||
(Just ranges, Just (UserProperties User {userSurname, userMatrikelnummer}, Nothing))
|
||||
-> any fitsInRange ranges
|
||||
where
|
||||
ciTag :: Maybe [CI Char]
|
||||
ciTag = map CI.mk . Text.unpack <$> case rule of
|
||||
ExamRoomSurname
|
||||
| Text.null pSurname -> Nothing
|
||||
| otherwise-> Just pSurname
|
||||
| Text.null userSurname -> Nothing
|
||||
| otherwise-> Just userSurname
|
||||
ExamRoomMatriculation
|
||||
| maybe True Text.null pMatrikelnummer -> Nothing
|
||||
| otherwise -> pMatrikelnummer
|
||||
| maybe True Text.null userMatrikelnummer -> Nothing
|
||||
| otherwise -> userMatrikelnummer
|
||||
_rule -> Nothing
|
||||
fitsInRange :: ExamOccurrenceMappingDescription -> Bool
|
||||
fitsInRange ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = case ciTag of
|
||||
Nothing -> True
|
||||
(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
|
||||
(Just tag) -> (eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd)
|
||||
fitsInRange ExamOccurrenceMappingSpecial {}
|
||||
= 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
|
||||
ExamRoomMatriculation -> reverse . take rangeLength . reverse
|
||||
_rule -> take rangeLength
|
||||
@ -283,9 +260,9 @@ spec = do
|
||||
noRelevantUsers rule = null . Map.filter (isRelevantUser rule)
|
||||
isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool
|
||||
isRelevantUser _rule (_user, Just _assignedRoom) = False
|
||||
isRelevantUser rule (UserProperties {pSurname, pMatrikelnummer}, Nothing) = case rule of
|
||||
ExamRoomSurname -> not $ null pSurname
|
||||
ExamRoomMatriculation -> maybe False (not . null) pMatrikelnummer
|
||||
isRelevantUser rule (UserProperties User {userSurname, userMatrikelnummer}, Nothing) = case rule of
|
||||
ExamRoomSurname -> not $ null userSurname
|
||||
ExamRoomMatriculation -> maybe False (not . null) userMatrikelnummer
|
||||
_rule -> False
|
||||
mappingImpossible :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Bool
|
||||
mappingImpossible
|
||||
@ -304,8 +281,8 @@ spec = do
|
||||
(fromIntegral . length -> nextUsers, remainingUsers') = span (== h) remainingUsers
|
||||
ruleProperty :: ExamOccurrenceRule -> UserProperties -> Maybe Text
|
||||
ruleProperty rule = case rule of
|
||||
ExamRoomSurname -> Just . pSurname
|
||||
ExamRoomMatriculation -> pMatrikelnummer
|
||||
ExamRoomSurname -> Just . userSurname . user
|
||||
ExamRoomMatriculation -> userMatrikelnummer . user
|
||||
_rule -> const Nothing
|
||||
-- copied and adjusted from Hander.Utils.Exam
|
||||
adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
|
||||
|
||||
Loading…
Reference in New Issue
Block a user