chore: create (incomplete) ignore/reconsider buttons

messages/uniworx/misc/de-de-formal.msg

@@ -2824,6 +2824,8 @@ BtnExamAutoOccurrenceCalculate: Verteilungstabelle berechnen
 BtnExamAutoOccurrenceAccept: Verteilung akzeptieren
 BtnExamAutoOccurrenceNudgeUp: +
 BtnExamAutoOccurrenceNudgeDown: -
+BtnExamAutoOccurrenceIgnoreEnable: Ignorieren
+BtnExamAutoOccurrenceIgnoreDisable: Berücksichtigen
 ExamRoomMappingSurname: Nachnamen beginnend mit
 ExamRoomMappingMatriculation: Matrikelnummern endend in
 ExamRoomMappingRandom: Verteilung

messages/uniworx/misc/en-eu.msg

@@ -2824,6 +2824,8 @@ BtnExamAutoOccurrenceCalculate: Calculate assignment rules
 BtnExamAutoOccurrenceAccept: Accept assignments
 BtnExamAutoOccurrenceNudgeUp: +
 BtnExamAutoOccurrenceNudgeDown: -
+BtnExamAutoOccurrenceIgnoreEnable: Ignore
+BtnExamAutoOccurrenceIgnoreDisable: Reconsider
 ExamRoomMappingSurname: Surnames starting with
 ExamRoomMappingMatriculation: Matriculation numbers ending in
 ExamRoomMappingRandom: Distribution

src/Handler/Exam/AutoOccurrence.hs

@@ -10,6 +10,7 @@ import Handler.Utils
 import Handler.Utils.Exam
 
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 
 import qualified Database.Esqueleto as E
 import Database.Persist.Sql (updateWhereCount)
@@ -35,6 +36,7 @@ data ExamAutoOccurrenceButton
   = BtnExamAutoOccurrenceCalculate
   | BtnExamAutoOccurrenceAccept
   | BtnExamAutoOccurrenceNudgeUp | BtnExamAutoOccurrenceNudgeDown
+  | BtnExamAutoOccurrenceIgnoreEnable | BtnExamAutoOccurrenceIgnoreDisable
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 instance Universe ExamAutoOccurrenceButton
 instance Finite ExamAutoOccurrenceButton
@@ -53,8 +55,14 @@ examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig }
   = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm
   where
     eaocForm =
-      (set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms))
+      (set _eaocIgnoreRooms . automaticIfTrue <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just . ignoreRooms $ eaofConfig ^. _eaocIgnoreRooms))
       <*> pure def
+    automaticIfTrue :: Bool -> ExamAutoOccurrenceIgnoreRooms
+    automaticIfTrue True  = EAOIRAutomatic
+    automaticIfTrue False = EAOIRManual Set.empty
+    ignoreRooms :: ExamAutoOccurrenceIgnoreRooms -> Bool
+    ignoreRooms EAOIRAutomatic = True
+    ignoreRooms (EAOIRManual s) = null s
 
 examAutoOccurrenceNudgeForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm
 examAutoOccurrenceNudgeForm occId protoForm html = do
@@ -73,6 +81,28 @@ examAutoOccurrenceNudgeForm occId protoForm html = do
       oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False
   return (res, wgt <> oldDataView)
 
+examAutoOccurrenceIgnoreRoomsForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm
+examAutoOccurrenceIgnoreRoomsForm occId protoForm html = do
+  cID <- encrypt occId
+  -- TODO new constructor instead of FIDExamAutoOccurrenceNudge
+  -- type FormIdentifier, lives in Utils.Form
+  (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceIgnoreRooms $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceIgnoreEnable, BtnExamAutoOccurrenceIgnoreDisable]) html
+  oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField
+  oldDataId <- newIdent
+
+  let protoForm' = fromMaybe def $ oldDataRes <|> protoForm
+      genForm btn = protoForm' & _eaofConfig . _eaocIgnoreRooms %~ EAOIRManual . action occId . toManualSet
+        where
+          toManualSet EAOIRAutomatic = Set.empty
+          toManualSet (EAOIRManual s) = s
+          action = case btn of
+            BtnExamAutoOccurrenceIgnoreEnable  -> Set.insert
+            BtnExamAutoOccurrenceIgnoreDisable -> Set.delete
+            _other                             -> flip const  -- i.e. ignore argument
+      res = genForm <$> btnRes
+      oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False
+  return (res, wgt <> oldDataView)
+
 examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm
 examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do
   (confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData
@@ -102,8 +132,11 @@ postEAutoOccurrenceR tid ssh csh examn = do
 
   nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->
     runFormPost $ examAutoOccurrenceNudgeForm occId (formResult' calculateRes)
+  
+  ignoreRoomsRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->
+    runFormPost $ examAutoOccurrenceIgnoreRoomsForm occId (formResult' calculateRes)
 
-  let calculateRes' = asum $ calculateRes : nudgeRes ^.. folded . _1 . _1
+  let calculateRes' = asum $ calculateRes : nudgeRes ^.. folded . _1 . _1 ++ ignoreRoomsRes ^.. folded . _1 . _1
 
   calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do
     participants <- E.select . E.from $ \(registration `E.InnerJoin` user) -> do
@@ -115,11 +148,12 @@ postEAutoOccurrenceR tid ssh csh examn = do
           return (uid, (userRec, examRegistrationOccurrence))
         occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, _examOccurrenceCapacityIso # (fromIntegral <$> examOccurrenceCapacity))) occurrences
         autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
-    (eaofMapping, eaofAssignment) <- case autoOccurrenceResult of
+    (eaofMapping, eaofAssignment, _ignoredOccurrences) <- case autoOccurrenceResult of
       (Left e) -> do
         addMessageI Error e
         redirect $ CExamR tid ssh csh examn EUsersR
       (Right r) -> pure r
+    -- TODO use returned ignoredOccurrences
     return $ Just ExamAutoOccurrenceAcceptForm{..}
 
   ((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult
@@ -153,6 +187,14 @@ postEAutoOccurrenceR tid ssh csh examn = do
           , formAttrs = [("class", "buttongroup")]
           }
 
+  let ignoreRoomWgt = ignoreRoomsRes <&> \((_, ignoreRoomsView), ignoreRoomsEncoding) ->
+        wrapForm ignoreRoomsView def
+          { formAction   = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
+          , formEncoding = ignoreRoomsEncoding
+          , formSubmit   = FormNoSubmit
+          , formAttrs = [("class", "buttongroup")]
+          }
+
   ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult
 
   let heading = MsgTitleExamAutoOccurrence tid ssh csh examn

src/Handler/Utils/Exam.hs

@@ -6,7 +6,7 @@ module Handler.Utils.Exam
   , examRelevantSheets, examBonusPossible, examBonusAchieved
   , examResultBonus, examGrade
   , examBonusGrade
-  , ExamAutoOccurrenceConfig
+  , ExamAutoOccurrenceConfig, ExamAutoOccurrenceIgnoreRooms(..)
   , eaocIgnoreRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
   , _eaocIgnoreRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
   , ExamAutoOccurrenceException(..)

src/Utils/Form.hs

@@ -229,7 +229,7 @@ data FormIdentifier
   | FIDUserAuthMode | FIDUserAssimilate | FIDUserRights | FIDUserAuthentication
   | FIDAllUsersAction
   | FIDLanguage
-  | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID
+  | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID | FIDExamAutoOccurrenceIgnoreRooms UUID
   | FIDAllocationAccept
   | FIDTestDownload
   | FIDAllocationRegister

templates/widgets/exam-occurrence-mapping.hamlet

@@ -34,6 +34,8 @@ $newline never
         <td .table__td>
           $maybe nudgeWgt' <- Map.lookup occId nudgeWgt
             ^{nudgeWgt'}
+          $maybe ignoreRoomWgt' <- Map.lookup occId ignoreRoomWgt
+            ^{ignoreRoomWgt'}
         <td .table__td>
           $maybe mappingWgt <- occMapping occId
             ^{mappingWgt}