chore: examAutoOccurrence converted to Either

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
 

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
 

package.yaml

@@ -162,6 +162,8 @@ dependencies:
   - nonce
   - IntervalMap
   - haskell-src-meta
+  - either
+
 other-extensions:
   - GeneralizedNewtypeDeriving
   - IncoherentInstances

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'
+  = Left ExamAutoOccurrenceExceptionNotEnoughSpace
-  = nullResult
+  | 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
+      _ -> bimap (ExamOccurrenceMapping rule) (Map.unionWith (<|>) (view _2 <$> users)) . postprocess <$> bestOption
-          -> ( Just $ ExamOccurrenceMapping rule resMapping
-             , Map.unionWith (<|>) (view _2 <$> users) result
-             )
-      _ -> nullResult
   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

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

templates/widgets/exam-occurrence-mapping-description.hamlet

@@ -13,3 +13,5 @@ $newline never
             #{titleCase special}…
           $else
             …#{titleCase special}
+        $of ExamOccurrenceMappingRandom
+          Random

templates/widgets/exam-occurrence-mapping.hamlet

@@ -14,6 +14,9 @@ $newline never
           $of ExamRoomMatriculation
             <th .table__th>
               _{MsgExamRoomMappingMatriculation}
+          $of ExamRoomRandom
+            <th .table__th>
+              _{MsgExamRoomMappingRandom}
           $of _
             <th .table__td>
       <th .table__th>