7e1b75c2e1
previously, they stopped just before leading to clashes with the next range e.g. Äm would cause Am as mapping end with the next starting at An Now, the mapping end is AZ with the next starting at BA
344 lines
20 KiB
Haskell
344 lines
20 KiB
Haskell
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
|
|
|
module Handler.Utils.ExamSpec (spec) where
|
|
|
|
import TestImport
|
|
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
|
|
import qualified Data.Text as Text
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.RFC5051 as RFC5051
|
|
|
|
import Handler.Utils.Exam
|
|
|
|
|
|
-- 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
|
|
-- '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
|
|
-- @
|
|
myAnnotate :: (HasCallStack) => String -> Expectation -> Expectation
|
|
myAnnotate 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
|
|
<*> arbitrary -- examOccurrenceName
|
|
<*> arbitrary -- examOccurrenceRoom
|
|
<*> arbitrary -- examOccurrenceRoomHidden
|
|
<*> frequency [(let d = fromIntegral i in ceiling $ 100 * exp(- d*d / 50), pure i) | i <- [10 ..1000]] -- examOccurrenceCapacity
|
|
<*> arbitrary -- examOccurrenceStart
|
|
<*> arbitrary -- examOccurrenceEnd
|
|
<*> arbitrary -- examOccurrenceDescription
|
|
|
|
|
|
data Preselection = NoPreselection | SomePreselection
|
|
deriving stock (Show, Bounded, Enum)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
data Nudges = NoNudges | SmallNudges | LargeNudges
|
|
deriving stock (Show, Bounded, Enum)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
|
|
uncurry3 f (a, b, c) = f a b c
|
|
|
|
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)
|
|
newtype UserProperties = UserProperties {user :: User}
|
|
|
|
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.
|
|
-- Hashable seed
|
|
-- => seed
|
|
-- -> ExamOccurrenceRule
|
|
-- -> ExamAutoOccurrenceConfig
|
|
-- -> Map ExamOccurrenceId Natural
|
|
-- -> Map UserId (User, Maybe ExamOccurrenceId)
|
|
-- -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
|
|
-- examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
|
|
spec :: Spec
|
|
spec = do
|
|
describe "examAutoOccurrence" $ do
|
|
describe "Surname" $ testWithRule ExamRoomSurname
|
|
describe "Matriculation" $ testWithRule ExamRoomMatriculation
|
|
describe "Random" $ testWithRule ExamRoomRandom
|
|
where
|
|
testWithRule :: ExamOccurrenceRule -> Spec
|
|
testWithRule rule =
|
|
forM_ universeF $ \nudges -> describe (show nudges) $
|
|
forM_ universeF $ \preselection ->
|
|
prop (show preselection) $ propertyTest rule nudges preselection
|
|
seed :: ()
|
|
seed = ()
|
|
propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property
|
|
propertyTest rule nudges preselection = do
|
|
(users, occurrences) <- genUsersWithOccurrences preselection
|
|
eaocNudge <- case nudges of
|
|
NoNudges -> pure Map.empty
|
|
SmallNudges -> let nudgeFrequency = [(10, 0), (5, 1), (5, -1), (3, 2), (3, -2), (1, 3), (1, -3)]
|
|
in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
|
|
LargeNudges -> let nudgeFrequency = [(7, 0), (5, 3), (5, -3), (3, 6), (3, -6), (2, 9), (2, -9),
|
|
(2, 11), (2, -11), (1, 15), (1,-15), (1, 17), (1, -17)]
|
|
in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
|
|
let config :: ExamAutoOccurrenceConfig
|
|
config = def {eaocNudge}
|
|
(maybeMapping, userMap) = examAutoOccurrence seed rule config occurrences users
|
|
pure $ ioProperty $ do
|
|
-- user count stays constant
|
|
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 UserProperties) users
|
|
myAnnotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
|
|
case maybeMapping of
|
|
(Just occurrenceMapping) -> do
|
|
-- mapping is a valid description
|
|
myAnnotate "invalid mapping description" $ shouldSatisfy occurrenceMapping validRangeDescription
|
|
-- 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)
|
|
myAnnotate "user didn't get a room" $ shouldSatisfy userMap $ foldr foldFn True . Map.toList
|
|
-- all users match the shown ranges
|
|
myAnnotate "shown ranges don't match userMap"
|
|
$ shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges
|
|
-- is a nullResult justified?
|
|
Nothing ->
|
|
-- disabled for now, probably not correct with the current implementation
|
|
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)
|
|
genUsersWithOccurrences preselection = do
|
|
rawUsers <- scale (50 *) $ listOf $ Entity <$> arbitrary <*> arbitrary
|
|
occurrences <- genOccurrences $ length rawUsers
|
|
-- user surnames anpassen, sodass interessante instanz
|
|
users <- fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do
|
|
userSurname <- elements surnames
|
|
assignedRoom <- case preselection of
|
|
NoPreselection -> pure Nothing
|
|
SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)]
|
|
pure (entityKey, (entityVal {userSurname}, assignedRoom))
|
|
pure (users, occurrences)
|
|
genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural)
|
|
genOccurrences numUsers = do
|
|
-- extra space to allow nice borders
|
|
extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2]
|
|
let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
|
|
createOccurrences acc
|
|
| sum (map snd acc) < totalSpaceRequirement = do
|
|
Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary
|
|
createOccurrences $ (entityKey, examOccurrenceCapacity entityVal) : acc
|
|
| otherwise = pure acc
|
|
Map.fromList <$> createOccurrences []
|
|
genNudge :: [(Int, Integer)] -> Map ExamOccurrenceId Integer -> ExamOccurrenceId -> Gen (Map ExamOccurrenceId Integer)
|
|
genNudge nudgesList acc occurrenceId
|
|
= fmap appendNonZero $ frequency $ map (second pure) nudgesList
|
|
where
|
|
appendNonZero :: Integer -> Map ExamOccurrenceId Integer
|
|
appendNonZero 0 = acc
|
|
appendNonZero nudge = Map.insert occurrenceId nudge acc
|
|
-- name list copied from test/Database/Fill.hs
|
|
surnames :: [Text]
|
|
surnames = [ "Smith", "Johnson", "Williams", "Brown"
|
|
, "Jones", "Miller", "Davis", "Garcia"
|
|
, "Rodriguez", "Wilson", "Martinez", "Anderson"
|
|
, "Taylor", "Thomas", "Hernandez", "Moore"
|
|
, "Martin", "Jackson", "Thompson", "White"
|
|
, "Lopez", "Lee", "Gonzalez", "Harris"
|
|
, "Clark", "Lewis", "Robinson", "Walker"
|
|
, "Perez", "Hall", "Young", "zu Allen", "Fu"
|
|
, "Únîcòdé", "Ähm-Ümlaüte", "von Leerzeichen"
|
|
]
|
|
occurrenceMap :: Map UserId (Maybe ExamOccurrenceId) -> Map ExamOccurrenceId [UserId]
|
|
occurrenceMap userMap = foldl' (\acc (userId, maybeOccurrenceId) -> appendJust maybeOccurrenceId userId acc)
|
|
Map.empty $ Map.toAscList userMap
|
|
where
|
|
appendJust :: Maybe ExamOccurrenceId -> UserId -> Map ExamOccurrenceId [UserId] -> Map ExamOccurrenceId [UserId]
|
|
appendJust Nothing _userId = id
|
|
appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId]
|
|
-- | Are all rooms large enough to hold all assigned Users?
|
|
fitsInRooms :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
|
-> Map ExamOccurrenceId Natural
|
|
-> Map UserId (Maybe ExamOccurrenceId)
|
|
-> Bool
|
|
fitsInRooms userProperties occurrences userMap
|
|
= all roomIsBigEnough $ Map.toAscList $ occurrenceMap userMap
|
|
where
|
|
roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool
|
|
roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of
|
|
Nothing -> False
|
|
(Just capacity) -> length userIds <= fromIntegral capacity
|
|
|| all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds)
|
|
-- | No range overlap for different rooms + end is always the greater value
|
|
validRangeDescription :: ExamOccurrenceMapping ExamOccurrenceId -> Bool
|
|
validRangeDescription ExamOccurrenceMapping {examOccurrenceMappingMapping}
|
|
= all (\(roomId, ranges) -> all (descriptionValid roomId) ranges) $ Map.toAscList examOccurrenceMappingMapping
|
|
where
|
|
descriptionValid:: ExamOccurrenceId -> ExamOccurrenceMappingDescription -> Bool
|
|
descriptionValid roomId description
|
|
= endAfterStart description && all (all $ noDirectOverlap description) (Map.delete roomId examOccurrenceMappingMapping)
|
|
endAfterStart :: ExamOccurrenceMappingDescription -> Bool
|
|
endAfterStart
|
|
ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase -> end)}
|
|
= RFC5051.compareUnicode start end /= GT
|
|
endAfterStart ExamOccurrenceMappingSpecial {} = True
|
|
noDirectOverlap :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription -> Bool
|
|
noDirectOverlap
|
|
ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> s0), eaomrEnd=(pack . map CI.foldedCase -> e0)}
|
|
ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> s1), eaomrEnd=(pack . map CI.foldedCase -> e1)}
|
|
= (RFC5051.compareUnicode s0 s1 == LT && RFC5051.compareUnicode e0 s1 == LT)
|
|
|| (RFC5051.compareUnicode s0 e1 == GT && RFC5051.compareUnicode e0 s1 == GT)
|
|
noDirectOverlap
|
|
ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
|
|
ExamOccurrenceMappingSpecial {eaomrSpecial}
|
|
= noDirectOverlapRangeSpecial eaomrStart eaomrEnd eaomrSpecial
|
|
noDirectOverlap
|
|
ExamOccurrenceMappingSpecial {eaomrSpecial}
|
|
ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
|
|
= noDirectOverlapRangeSpecial eaomrStart eaomrEnd eaomrSpecial
|
|
noDirectOverlap ExamOccurrenceMappingSpecial {eaomrSpecial=s1} ExamOccurrenceMappingSpecial {eaomrSpecial=s2}
|
|
= s1 /= s2
|
|
noDirectOverlapRangeSpecial :: [CI Char] -> [CI Char] -> [CI Char] -> Bool
|
|
noDirectOverlapRangeSpecial
|
|
(pack . map CI.foldedCase -> start)
|
|
(pack . map CI.foldedCase -> end)
|
|
(pack . map CI.foldedCase -> special)
|
|
= RFC5051.compareUnicode special start == LT || RFC5051.compareUnicode special end == GT
|
|
-- RFC5051.compareUnicode :: Text -> Text -> Ordering
|
|
-- | Does the (currently surname) User fit to the displayed ranges?
|
|
-- Users with a previously assigned room are checked if the assignment stays the same, regardless of the ranges.
|
|
showsCorrectRanges :: ExamOccurrenceRule
|
|
-> Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
|
-> ExamOccurrenceMapping ExamOccurrenceId
|
|
-> Map UserId (Maybe ExamOccurrenceId)
|
|
-> Bool
|
|
showsCorrectRanges rule userProperties ExamOccurrenceMapping {examOccurrenceMappingMapping} userMap
|
|
= all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
|
|
where
|
|
userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
|
|
userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
|
|
case (Map.lookup roomId examOccurrenceMappingMapping, Map.lookup userId userProperties) of
|
|
(_maybeRanges, Just (_userProperty, Just fixedRoomId))
|
|
-> roomId == fixedRoomId
|
|
(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 userSurname -> Nothing
|
|
| otherwise-> Just userSurname
|
|
ExamRoomMatriculation
|
|
| maybe True Text.null userMatrikelnummer -> Nothing
|
|
| otherwise -> userMatrikelnummer
|
|
_rule -> Nothing
|
|
fitsInRange :: ExamOccurrenceMappingDescription -> Bool
|
|
fitsInRange mappingDescription = case (ciTag, mappingDescription) of
|
|
(Nothing, _mappingDescription) -> True
|
|
(Just tag, ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase-> end)})
|
|
-> (RFC5051.compareUnicode start (pack $ map CI.foldedCase $ transformTag start tag) /= GT)
|
|
&& (RFC5051.compareUnicode end (pack $ map CI.foldedCase $ transformTag end tag) /= LT)
|
|
(Just tag, ExamOccurrenceMappingSpecial {eaomrSpecial})
|
|
-> checkSpecial eaomrSpecial tag
|
|
transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char]
|
|
transformTag (length -> rangeLength) = case rule of
|
|
ExamRoomMatriculation -> reverse . take rangeLength . reverse
|
|
_rule -> take rangeLength
|
|
checkSpecial :: [CI Char] -> [CI Char] -> Bool
|
|
checkSpecial = case rule of
|
|
ExamRoomMatriculation -> isSuffixOf
|
|
_rule -> isPrefixOf
|
|
_otherwise -> (rule /= ExamRoomSurname) && (rule /= ExamRoomMatriculation)
|
|
-- | Is mapping impossible?
|
|
isNullResultJustified :: ExamOccurrenceRule
|
|
-> Map UserId (UserProperties, Maybe ExamOccurrenceId)
|
|
-> Map ExamOccurrenceId Natural -> Bool
|
|
isNullResultJustified rule userProperties occurrences
|
|
= noRelevantUsers rule userProperties || mappingImpossible rule userProperties occurrences || True
|
|
noRelevantUsers :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Bool
|
|
noRelevantUsers rule = null . Map.filter (isRelevantUser rule)
|
|
isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool
|
|
isRelevantUser _rule (_user, Just _assignedRoom) = False
|
|
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
|
|
rule
|
|
userProperties@(sort . map (ruleProperty rule . fst) . Map.elems . Map.filter (isRelevantUser rule) -> relevantUsers)
|
|
(map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go relevantUsers occurrences'
|
|
where
|
|
go :: [Maybe Text] -> [Natural] -> Bool
|
|
go [] _occurrences = False
|
|
go _remainingUsers [] = True
|
|
go remainingUsers (0:t) = go remainingUsers t
|
|
go remainingUsers@(h:_t) (firstOccurrence:laterOccurrences)
|
|
| nextUsers <= firstOccurrence = go remainingUsers' $ firstOccurrence - nextUsers : laterOccurrences
|
|
| otherwise = go remainingUsers laterOccurrences
|
|
where
|
|
(fromIntegral . length -> nextUsers, remainingUsers') = span (== h) remainingUsers
|
|
ruleProperty :: ExamOccurrenceRule -> UserProperties -> Maybe Text
|
|
ruleProperty rule = case rule of
|
|
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
|
|
-- ^ reduce room capacity for every pre-assigned user by 1
|
|
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
|
|
predToPositive n = Just $ pred n
|