From a692899ae6d210f31f46c84df885fbdc481c1c33 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Mon, 8 Feb 2021 16:45:55 +0100 Subject: [PATCH] chore(test): make UserProperties a newtype --- test/Handler/Utils/ExamSpec.hs | 95 +++++++++++++--------------------- 1 file changed, 36 insertions(+), 59 deletions(-) diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs index 06b5fd722..53f2e2878 100644 --- a/test/Handler/Utils/ExamSpec.hs +++ b/test/Handler/Utils/ExamSpec.hs @@ -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