From e03326e1ac27b8b75fc3fc9b93710af667c82523 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Mon, 1 Mar 2021 15:30:51 +0100 Subject: [PATCH] chore: examAutoOccurrence converted to Either --- messages/uniworx/misc/de-de-formal.msg | 7 +++- messages/uniworx/misc/en-eu.msg | 5 +++ package.yaml | 2 + src/Handler/Utils/Exam.hs | 40 ++++++++++++------- src/Model/Types/Exam.hs | 1 + ...exam-occurrence-mapping-description.hamlet | 2 + .../widgets/exam-occurrence-mapping.hamlet | 3 ++ 7 files changed, 45 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index 3be85654d..1c7505108 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -2800,9 +2800,14 @@ BtnExamAutoOccurrenceNudgeUp: + BtnExamAutoOccurrenceNudgeDown: - ExamRoomMappingSurname: Nachnamen beginnend mit ExamRoomMappingMatriculation: Matrikelnummern endend in +ExamRoomMappingRandom: Zufällige Zuordnung ExamRoomLoad: Auslastung ExamRegisteredCount: Anmeldungen ExamRegisteredCountOf num@Int64 count@Int64: #{num}/#{count} +ExamAutoOccurrenceExceptionRuleNoOp: Keine Automatische Verteilung gewählt +ExamAutoOccurrenceExceptionNotEnoughSpace: Nicht ausreichend Platz +ExamAutoOccurrenceExceptionNoUsers: Keine Nutzer +ExamAutoOccurrenceExceptionRoomTooSmall: Automatische Verteilung gescheitert. Es kann helfen kleine Räume zu entfernen. NoFilter: Keine Einschränkung @@ -3181,4 +3186,4 @@ WGFFileUpload: Dateifeld WorkflowGraphFormUploadIsDirectory: Upload ist Verzeichnis WorkflowGraphFormInvalidNumberOfFiles: Es muss genau eine Datei hochgeladen werden -CourseSortingOnlyLoggedIn: Das Benutzerinterface zur Sortierung dieser Tabelle ist nur für eingeloggte Benutzer aktiv \ No newline at end of file +CourseSortingOnlyLoggedIn: Das Benutzerinterface zur Sortierung dieser Tabelle ist nur für eingeloggte Benutzer aktiv diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 3f425b064..d89a5a61e 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -2800,9 +2800,14 @@ BtnExamAutoOccurrenceNudgeUp: + BtnExamAutoOccurrenceNudgeDown: - ExamRoomMappingSurname: Surnames starting with ExamRoomMappingMatriculation: Matriculation numbers ending in +ExamRoomMappingRandom: Random assignment ExamRoomLoad: Utilisation ExamRegisteredCount: Registrations ExamRegisteredCountOf num count: #{num}/#{count} +ExamAutoOccurrenceExceptionRuleNoOp: Didn't chose an automatic distribution +ExamAutoOccurrenceExceptionNotEnoughSpace: Not enough space +ExamAutoOccurrenceExceptionNoUsers: No participants +ExamAutoOccurrenceExceptionRoomTooSmall: Automatic distribution failed. Removing small rooms might help. NoFilter: No restriction diff --git a/package.yaml b/package.yaml index bd5247ac1..c9d092443 100644 --- a/package.yaml +++ b/package.yaml @@ -162,6 +162,8 @@ dependencies: - nonce - IntervalMap - haskell-src-meta + - either + other-extensions: - GeneralizedNewtypeDeriving - IncoherentInstances diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 6b7f9c505..00c1c655e 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -47,6 +47,8 @@ import qualified Data.Array.ST as ST import Data.List (findIndex, unfoldr) import qualified Data.List as List +import Data.Either.Combinators (maybeToRight) + import Data.ExtendedReal import Data.Ratio (Ratio) @@ -256,6 +258,16 @@ deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''ExamAutoOccurrenceConfig +data ExamAutoOccurrenceException + = ExamAutoOccurrenceExceptionRuleNoOp + | ExamAutoOccurrenceExceptionNotEnoughSpace + | ExamAutoOccurrenceExceptionNoUsers + | ExamAutoOccurrenceExceptionRoomTooSmall + deriving (Show, Generic, Typeable) + +instance Exception ExamAutoOccurrenceException + +embedRenderMessage ''UniWorX ''ExamAutoOccurrenceException id examAutoOccurrence :: forall seed. Hashable seed @@ -264,16 +276,20 @@ examAutoOccurrence :: forall seed. -> ExamAutoOccurrenceConfig -> Map ExamOccurrenceId Natural -> Map UserId (User, Maybe ExamOccurrenceId) - -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) + -> Either ExamAutoOccurrenceException (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId)) examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users | sum occurrences' < usersCount || sum occurrences' <= 0 - || Map.null users' - = nullResult + = Left ExamAutoOccurrenceExceptionNotEnoughSpace + | Map.null users' + = Left ExamAutoOccurrenceExceptionNoUsers | otherwise = case rule of ExamRoomRandom - -> ( Nothing + -> Right ( ExamOccurrenceMapping { + examOccurrenceMappingRule=rule, + examOccurrenceMappingMapping=Map.fromList $ (set _2 $ Set.singleton ExamOccurrenceMappingRandom) <$> occurrences'' + } , Map.union (view _2 <$> assignedUsers) randomlyAssignedUsers ) where @@ -307,13 +323,8 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences where newUsers, remainingUsers :: [UserId] (newUsers, remainingUsers) = List.genericSplitAt roomSize userList - _ | Just (postprocess -> (resMapping, result)) <- bestOption - -> ( Just $ ExamOccurrenceMapping rule resMapping - , Map.unionWith (<|>) (view _2 <$> users) result - ) - _ -> nullResult + _ -> bimap (ExamOccurrenceMapping rule) (Map.unionWith (<|>) (view _2 <$> users)) . postprocess <$> bestOption where - nullResult = (Nothing, view _2 <$> users) usersCount :: forall a. Num a => a usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users' @@ -519,13 +530,13 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge - bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] + bestOption :: Either ExamAutoOccurrenceException [(ExamOccurrenceId, [[CI Char]])] bestOption = case rule of - ExamRoomSurname -> do + ExamRoomSurname -> maybeToRight ExamAutoOccurrenceExceptionRoomTooSmall $ do (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences'' lineNudges charCost -- traceM $ show cost return res - ExamRoomMatriculation -> do + ExamRoomMatriculation -> maybeToRight ExamAutoOccurrenceExceptionRoomTooSmall $ do let usersFineness n = Map.toAscList $ fromIntegral . Set.size <$> Map.mapKeysWith Set.union (reverse . take (fromIntegral n) . reverse) users' -- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences' @@ -556,7 +567,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences (_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1 return res - _other -> Nothing + _other -> Left ExamAutoOccurrenceExceptionRuleNoOp postprocess :: [(ExamOccurrenceId, [[CI Char]])] -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) @@ -690,6 +701,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences checkSpecial = case rule of ExamRoomMatriculation -> isSuffixOf _rule -> isPrefixOf + ExamOccurrenceMappingRandom -> False -- Something went wrong, throw an error instead? resultUsers :: Map UserId (Maybe ExamOccurrenceId) resultUsers = Map.fromList $ do diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 1a9cb0ef4..3910f402a 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -191,6 +191,7 @@ examOccurrenceRuleAutomatic x = any ($ x) data ExamOccurrenceMappingDescription = ExamOccurrenceMappingRange { eaomrStart, eaomrEnd :: [CI Char] } | ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] } + | ExamOccurrenceMappingRandom deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 diff --git a/templates/widgets/exam-occurrence-mapping-description.hamlet b/templates/widgets/exam-occurrence-mapping-description.hamlet index 356911383..3546b7928 100644 --- a/templates/widgets/exam-occurrence-mapping-description.hamlet +++ b/templates/widgets/exam-occurrence-mapping-description.hamlet @@ -13,3 +13,5 @@ $newline never #{titleCase special}… $else …#{titleCase special} + $of ExamOccurrenceMappingRandom + Random diff --git a/templates/widgets/exam-occurrence-mapping.hamlet b/templates/widgets/exam-occurrence-mapping.hamlet index 0d0b87940..69f7af6f8 100644 --- a/templates/widgets/exam-occurrence-mapping.hamlet +++ b/templates/widgets/exam-occurrence-mapping.hamlet @@ -14,6 +14,9 @@ $newline never $of ExamRoomMatriculation _{MsgExamRoomMappingMatriculation} + $of ExamRoomRandom + + _{MsgExamRoomMappingRandom} $of _