diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 92b904a09..5e3b77421 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 9d96a5802..067b17ccd 100644 --- a/src/Handler/Admin.hs +++ b/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 Finite ButtonInferStudyTerms +instance Universe ButtonAdminStudyTerms +instance Finite ButtonAdminStudyTerms -nullaryPathPiece ''ButtonInferStudyTerms camelToPathPiece +nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece +embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id -instance Button UniWorX ButtonInferStudyTerms where - btnLabel ButtonInferStudyTerms = "Studienfachzuordnung automatisch lernen" - btnClasses ButtonInferStudyTerms = [BCIsButton, BCPrimary] +instance Button UniWorX ButtonAdminStudyTerms where + btnClasses BtnCandidatesInfer = [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 newKeys = + mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget) + 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 "isnew") (i18nCell MsgStudyTermIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey)) - , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName)) - , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand)) + [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey)) + , sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _entityKey)) + , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _entityKey)) + , 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)) ] diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 7abd6b4d7..28b3df6b2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/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 diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs index 5eeba9a56..c986ed61b 100644 --- a/src/Handler/Utils/TermCandidates.hs +++ b/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 diff --git a/src/Utils.hs b/src/Utils.hs index 018babd9d..f6ebd76d6 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -140,8 +140,13 @@ hasTickmark :: Bool -> Markup hasTickmark True = [shamlet||] hasTickmark False = mempty +isBad :: Bool -> Markup +-- ^ Display an icon that denotes that something™ is bad +isBad True = [shamlet||] -- or times?! +isBad False = mempty + isNew :: Bool -> Markup -isNew True = [shamlet||] +isNew True = [shamlet||] -- was exclamation isNew False = mempty