StudyTermCandidates Deletion Buttons

messages/uniworx/de.msg

@@ -5,6 +5,9 @@ BtnRegister: Anmelden
 BtnDeregister: Abmelden
 BtnHijack: Sitzung übernehmen
 BtnSave: Speichern
+BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
+BtnCandidatesDeleteConflicts: Konflikte löschen
+BtnCandidatesDeleteAll: Alle Beobachtungen löschen
 
 Aborted: Abgebrochen
 Remarks: Hinweise
@@ -15,6 +18,11 @@ RegisterFrom: Anmeldungen von
 RegisterTo: Anmeldungen bis
 DeRegUntil: Abmeldungen bis
 
+GenericKey: Schlüssel
+GenericShort: Kürzel
+GenericIsNew: Neu
+GenericHasConflict: Konflikt
+
 SummerTerm year@Integer: Sommersemester #{display year}
 WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
 SummerTermShort year@Integer: SoSe #{display year}
@@ -439,10 +447,10 @@ StudyFeatureType:
 StudyFeatureValid: Aktiv
 StudyFeatureUpdate: Abgeglichen
 
-DegreeKey: Schlüssel Abschluss
+DegreeKey: Abschlussschlüssel
 DegreeName: Abschluss
 DegreeShort: Abschlusskürzel
-StudyTermsKey: Schlüssel Studiengang
+StudyTermsKey: Studiengangschlüssel
 StudyTermsName: Studiengang
 StudyTermsShort: Studiengangkürzel
 StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert
@@ -452,6 +460,8 @@ AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat
 RedundantCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Kandidat" "bekannte Kandiaten"} entfernt
 CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
 NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
+AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht.
+IncidencesDeleted n@Int: #{show n} #{pluralDE n "Beobachtung" "Beobachtungen"} gelöscht
 StudyTermIsNew: Neu
 StudyFeatureConflict: Es wurden Konflikte in der Studiengang-Zuordnung gefunden
 

src/Handler/Admin.hs

@@ -204,7 +204,7 @@ postAdminTestR = do
     buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag
 
   -- The actual call to @massInput@ is comparatively simple:
-    
+
   ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing
 
 
@@ -269,29 +269,34 @@ postAdminErrMsgR = do
 
 
 -- BEGIN - Buttons needed only for StudyTermCandidateManagement
-data ButtonInferStudyTerms = ButtonInferStudyTerms
+data ButtonAdminStudyTerms
+  = BtnCandidatesInfer
+  | BtnCandidatesDeleteConflicts
+  | BtnCandidatesDeleteAll
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonInferStudyTerms
+instance Universe ButtonAdminStudyTerms
-instance Finite ButtonInferStudyTerms
+instance Finite ButtonAdminStudyTerms
 
-nullaryPathPiece ''ButtonInferStudyTerms camelToPathPiece
+nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece
+embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id
 
-instance Button UniWorX ButtonInferStudyTerms where
+instance Button UniWorX ButtonAdminStudyTerms where
-  btnLabel   ButtonInferStudyTerms = "Studienfachzuordnung automatisch lernen"
+  btnClasses BtnCandidatesInfer           = [BCIsButton, BCPrimary]
-  btnClasses ButtonInferStudyTerms = [BCIsButton, BCPrimary]
+  btnClasses BtnCandidatesDeleteConflicts = [BCIsButton, BCDanger]
+  btnClasses BtnCandidatesDeleteAll       = [BCIsButton, BCDanger]
 -- END Button needed only here
 
 getAdminFeaturesR, postAdminFeaturesR :: Handler Html
 getAdminFeaturesR = postAdminFeaturesR
 postAdminFeaturesR = do
-    ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonInferStudyTerms)
+    ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
     let btnForm = wrapForm btnWdgt def
           { formAction = Just $ SomeRoute AdminFeaturesR
           , formEncoding = btnEnctype
           , formSubmit = FormNoSubmit
           }
     (infConflicts,infAccepted) <- case btnResult of
-      FormSuccess ButtonInferStudyTerms -> do
+      FormSuccess BtnCandidatesInfer -> do
         (infConflicts, infAmbiguous, infRedundant, infAccepted) <- Candidates.inferHandler
         unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
         unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
@@ -301,6 +306,16 @@ postAdminFeaturesR = do
           | otherwise
             -> addMessageI Success . MsgCandidatesInferred $ length infAccepted
         return (infConflicts, infAccepted)
+      FormSuccess BtnCandidatesDeleteConflicts -> runDB $ do
+        confs <- Candidates.conflicts
+        incis <- Candidates.getIncidencesFor (entityKey <$> confs)
+        deleteWhere [StudyTermCandidateIncidence <-. (E.unValue <$> incis)]
+        addMessageI Success $ MsgIncidencesDeleted $ length incis
+        return ([],[])
+      FormSuccess BtnCandidatesDeleteAll -> runDB $ do
+        deleteWhere ([] :: [Filter StudyTermCandidate])
+        addMessageI Success MsgAllIncidencesDeleted
+        (, []) <$> Candidates.conflicts
       _other -> (, []) <$> runDB Candidates.conflicts
 
     (   (degreeResult,degreeTable)
@@ -308,6 +323,7 @@ postAdminFeaturesR = do
       , ((), candidateTable)) <- runDB $ (,,)
       <$> mkDegreeTable
       <*> mkStudytermsTable (Set.fromList $ map (StudyTermsKey' . fst) infAccepted)
+                            (Set.fromList $ map entityKey infConflicts)
       <*> mkCandidateTable
 
     -- This needs to happen after calls to `dbTable` so they can short-circuit correctly
@@ -352,7 +368,7 @@ postAdminFeaturesR = do
           dbtRowKey     = (E.^. StudyDegreeKey)
           dbtProj       = return
           dbtColonnade  = formColonnade $ mconcat
-            [ sortable (Just "key")   (i18nCell MsgDegreeKey)   (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
+            [ sortable (Just "key")   (i18nCell MsgGenericKey)  (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
             , sortable (Just "name")  (i18nCell MsgDegreeName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName))
             , sortable (Just "short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
             , dbRow
@@ -366,11 +382,12 @@ postAdminFeaturesR = do
           dbtFilterUI   = mempty
           dbtParams     = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
                               }
-          psValidator   = def & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+          psValidator   = def  -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
+                        & defaultSorting [SortAscBy "key"]
       in dbTable psValidator DBTable{..}
 
-    mkStudytermsTable :: Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
+    mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
-    mkStudytermsTable newKeys =
+    mkStudytermsTable newKeys badKeys =
       let dbtIdent      = "admin-studyterms" :: Text
           dbtStyle      = def
           dbtSQLQuery   :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery ( E.SqlExpr (Entity StudyTerms))
@@ -378,15 +395,17 @@ postAdminFeaturesR = do
           dbtRowKey     = (E.^. StudyTermsKey)
           dbtProj       = return
           dbtColonnade  = formColonnade $ mconcat
-            [ sortable (Just "key")   (i18nCell MsgStudyTermsKey)   (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
+            [ sortable (Just "key")   (i18nCell MsgGenericKey)         (numCell . view (_dbrOutput . _entityVal . _studyTermsKey))
-            , sortable (Just "isnew") (i18nCell MsgStudyTermIsNew)  (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
+            , sortable (Just "isnew") (i18nCell MsgGenericIsNew)       (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey))
-            , sortable (Just "name")  (i18nCell MsgStudyTermsName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
+            , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey))
-            , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
+            , sortable (Just "name")  (i18nCell MsgStudyTermsName)     (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
+            , sortable (Just "short") (i18nCell MsgStudyTermsShort)    (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand))
             , dbRow
             ]
           dbtSorting    = Map.fromList
             [ ("key"   , SortColumn (E.^. StudyTermsKey))
             , ("isnew" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList newKeys)))
+            , ("isbad" , SortColumn (\studyTerm -> studyTerm E.^. StudyTermsId `E.in_` E.valList (Set.toList badKeys)))
             , ("name"  , SortColumn (E.^. StudyTermsName))
             , ("short" , SortColumn (E.^. StudyTermsShorthand))
             ]

src/Handler/Utils/Table/Cells.hs

@@ -57,6 +57,10 @@ sqlCell act = mempty & cellContents .~ lift act
 tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
 tickmarkCell = cell . toWidget . hasTickmark
 
+-- | Maybe display an icon for tainted rows
+isBadCell :: (IsDBTable m a) => Bool -> DBCell m a
+isBadCell = cell . toWidget . isBad
+
 -- | Maybe display a exclamation icon
 isNewCell :: (IsDBTable m a) => Bool -> DBCell m a
 isNewCell = cell . toWidget . isNew

src/Handler/Utils/TermCandidates.hs

@@ -180,5 +180,8 @@ conflicts = E.select $ E.from $ \studyTerms -> do
         E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
   return studyTerms
 
-
+-- | retrieve all incidence keys having containing a certain @StudyTermKey @
-
+getIncidencesFor :: [Key StudyTerms] -> DB [E.Value TermCandidateIncidence]
+getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
+  E.where_ $ candidate E.^. StudyTermCandidateKey `E.in_` E.valList (unStudyTermsKey <$> stks)
+  return $ candidate E.^. StudyTermCandidateIncidence

src/Utils.hs

@@ -140,8 +140,13 @@ hasTickmark :: Bool -> Markup
 hasTickmark True  = [shamlet|<i .fas .fa-check>|]
 hasTickmark False = mempty
 
+isBad :: Bool -> Markup
+-- ^ Display an icon that denotes that something™ is bad
+isBad True  = [shamlet|<i .fas .fa-bolt>|] -- or times?!
+isBad False = mempty
+
 isNew :: Bool -> Markup
-isNew True  = [shamlet|<i .fas .fa-exclamation>|]
+isNew True  = [shamlet|<i .fas .fa-seedling>|] -- was exclamation
 isNew False = mempty