diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 89f9dc9b9..97cf7991c 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -17,9 +17,11 @@ BtnHijack: Sitzung übernehmen BtnSave: Speichern PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert. BtnHandIn: Abgeben -BtnCandidatesInfer: Studienfachzuordnung automatisch lernen -BtnCandidatesDeleteConflicts: Konflikte löschen -BtnCandidatesDeleteAll: Alle Beobachtungen löschen +BtnNameCandidatesInfer: Studienfach-Namens-Zuordnung automatisch lernen +BtnNameCandidatesDeleteConflicts: Namenskonflikte löschen +BtnNameCandidatesDeleteAll: Alle Namens-Beobachtungen löschen +BtnParentCandidatesInfer: Unterstudiengangs-Zuordnung automatisch lernen +BtnParentCandidatesDeleteAll: Alle Unterstudiengangs-Beobachtungen löschen BtnResetTokens: Authorisierungs-Tokens invalidieren BtnLecInvAccept: Annehmen BtnLecInvDecline: Ablehnen @@ -764,10 +766,11 @@ NoStudyTermsKnown: Keine Studiengänge bekannt StudyFeaturesDegrees: Abschlüsse StudyFeaturesTerms: Studiengänge StudyFeaturesNameCandidates: Namens-Kandidaten -StudyFeaturesParentCandidates: Eltern-Kandidaten -StudyFeatureInference: Studiengangschlüssel-Inferenz -StudyFeatureInferenceNoConflicts: Keine Konflikte beobachtet -StudyFeatureInferenceConflictsHeading: Studiengangseinträge mit beobachteten Konflikten +StudyFeaturesParentCandidates: Kandidaten für Unterstudiengänge +StudyFeatureNameInference: Studiengangschlüssel-Inferenz +StudyFeatureParentInference: Unterstudiengang-Inferenz +StudyFeatureInferenceNoNameConflicts: Keine Konflikte beobachtet +StudyFeatureInferenceNameConflictsHeading: Studiengangseinträge mit beobachteten Konflikten StudyFeatureAge: Fachsemester StudyFeatureDegree: Abschluss FieldPrimary: Hauptfach @@ -788,13 +791,16 @@ StudyTermsShort: Studiengangkürzel StudyTermsChangeSuccess: Zuordnung Studiengänge aktualisiert StudyDegreeChangeSuccess: Zuordnung Abschlüsse aktualisiert StudyCandidateIncidence: Synchronisation -AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt +AmbiguousNameCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt RedundantNameCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Namenskandidat" "bekannte Namenskandiaten"} entfernt RedundantParentCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Elternkandidat" "bekannte Elternkandiaten"} entfernt RedundantStandaloneCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Einzelstudiengangskandidat" "bekannte Einzelstudiengangskandiaten"} entfernt -CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert -NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert -AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht. +NameCandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert +NoNameCandidatesInferred: Keine neuen Studienganszuordnungen inferiert +ParentCandidatesInferred n@Int: #{show n} #{pluralDE n "neuer Unterstudiengang" "neue Unterstudiengänge"} inferiert +NoParentCandidatesInferred: Keine neuen Unterstudiengänge inferiert +AllNameIncidencesDeleted: Alle Namens-Beobachtungen wurden gelöscht. +AllParentIncidencesDeleted: Alle Unterstudiengang-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/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 5634fd495..b2bcae6f2 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -17,9 +17,11 @@ BtnHijack: Hijack session BtnSave: Save PressSaveToSave: Changes will only be saved after clicking "Save". BtnHandIn: Hand in submission -BtnCandidatesInfer: Infer mapping -BtnCandidatesDeleteConflicts: Delete conflicts -BtnCandidatesDeleteAll: Delete all observations +BtnNameCandidatesInfer: Infer name-mapping +BtnNameCandidatesDeleteConflicts: Delete name-conflicts +BtnNameCandidatesDeleteAll: Delete all name-observations +BtnParentCandidatesInfer: Infer parent-relation +BtnParentCandidatesDeleteAll: Delete all parent-observations BtnResetTokens: Invalidate tokens BtnLecInvAccept: Accept BtnLecInvDecline: Decline @@ -762,9 +764,10 @@ StudyFeaturesDegrees: Degrees StudyFeaturesTerms: Terms of Study StudyFeaturesNameCandidates: Name candidates StudyFeaturesParentCandidates: Parent candidates -StudyFeatureInference: Infer field of study mapping -StudyFeatureInferenceNoConflicts: No observed conflicts -StudyFeatureInferenceConflictsHeading: Fields of study with observed conflicts +StudyFeatureNameInference: Infer field of study mapping +StudyFeatureParentInference: Infer field of study parent relation +StudyFeatureInferenceNoNameConflicts: No observed conflicts +StudyFeatureInferenceNameConflictsHeading: Fields of study with observed conflicts StudyFeatureAge: Semester StudyFeatureDegree: Degree FieldPrimary: Major @@ -785,13 +788,16 @@ StudyTermsShort: Field shorthand StudyTermsChangeSuccess: Successfully updated fields of study StudyDegreeChangeSuccess: Successfully updated degrees StudyCandidateIncidence: Synchronisation -AmbiguousCandidatesRemoved n: Successfully removed #{n} ambiguous #{pluralEN n "candidate" "candidates"} +AmbiguousNameCandidatesRemoved n: Successfully removed #{n} ambiguous #{pluralEN n "candidate" "candidates"} RedundantNameCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "name-candidate" "name-candidates"} RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "parent-candidate" "parent-candidates"} RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "standalone-candidate" "standalone-candidates"} -CandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"} -NoCandidatesInferred: No new mappings inferred -AllIncidencesDeleted: Successfully deleted all observations +NameCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"} +NoNameCandidatesInferred: No new name-mappings inferred +AllNameIncidencesDeleted: Successfully deleted all name observations +AllParentIncidencesDeleted: Successfully deleted all parent-relation observations +ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "parent-relation" "parent-reliations"} +NoParentCandidatesInferred: No new parent-relations inferred IncidencesDeleted n: Successfully deleted #{show n} #{pluralEN n "observation" "observations"} StudyTermIsNew: New StudyFeatureConflict: Observed conflicts in field mapping diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index b9cc734bb..5eae4b916 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -20,6 +20,7 @@ module Database.Esqueleto.Utils , maybe , SqlProject(..) , (->.) + , fromSqlKey , module Database.Esqueleto.Utils.TH ) where @@ -250,3 +251,6 @@ instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.E (->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b) (->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t + +fromSqlKey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value Int64) +fromSqlKey = E.veryUnsafeCoerceSqlExprValue diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs index b66884123..abfa5f831 100644 --- a/src/Handler/Admin/StudyFeatures.hs +++ b/src/Handler/Admin/StudyFeatures.hs @@ -18,41 +18,53 @@ import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter) import qualified Handler.Utils.TermCandidates as Candidates --- BEGIN - Buttons needed only for StudyTermNameCandidateManagement -data ButtonAdminStudyTerms - = BtnCandidatesInfer - | BtnCandidatesDeleteConflicts - | BtnCandidatesDeleteAll +data ButtonAdminStudyTermsNames + = BtnNameCandidatesInfer + | BtnNameCandidatesDeleteConflicts + | BtnNameCandidatesDeleteAll deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe ButtonAdminStudyTerms -instance Finite ButtonAdminStudyTerms +instance Universe ButtonAdminStudyTermsNames +instance Finite ButtonAdminStudyTermsNames -nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece -embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id +nullaryPathPiece ''ButtonAdminStudyTermsNames $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsNames id -instance Button UniWorX ButtonAdminStudyTerms where - btnClasses BtnCandidatesInfer = [BCIsButton, BCPrimary] - btnClasses BtnCandidatesDeleteConflicts = [BCIsButton, BCDanger] - btnClasses BtnCandidatesDeleteAll = [BCIsButton, BCDanger] --- END Button needed only here +instance Button UniWorX ButtonAdminStudyTermsNames where + btnClasses BtnNameCandidatesInfer = [BCIsButton, BCPrimary] + btnClasses BtnNameCandidatesDeleteConflicts = [BCIsButton, BCDanger] + btnClasses BtnNameCandidatesDeleteAll = [BCIsButton, BCDanger] +data ButtonAdminStudyTermsParents + = BtnParentCandidatesInfer + | BtnParentCandidatesDeleteAll + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonAdminStudyTermsParents +instance Finite ButtonAdminStudyTermsParents + +nullaryPathPiece ''ButtonAdminStudyTermsParents $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id + +instance Button UniWorX ButtonAdminStudyTermsParents where + btnClasses BtnParentCandidatesInfer = [BCIsButton, BCPrimary] + btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger] + + getAdminFeaturesR, postAdminFeaturesR :: Handler Html getAdminFeaturesR = postAdminFeaturesR postAdminFeaturesR = do uid <- requireAuthId - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms) - let btnForm = wrapForm btnWdgt def + ((nameBtnResult, nameBtnWdgt), nameBtnEnctype) <- runFormPost $ identifyForm ("infer-names-button" :: Text) buttonForm + let nameBtnForm = wrapForm nameBtnWdgt def { formAction = Just $ SomeRoute AdminFeaturesR - , formEncoding = btnEnctype + , formEncoding = nameBtnEnctype , formSubmit = FormNoSubmit } - infConflicts <- case btnResult of - FormSuccess BtnCandidatesInfer -> do - (infConflicts, infAmbiguous, (infRedundantNames, infRedundantParents, infRedundantStandalone), infAccepted) <- Candidates.inferHandler - unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous + infNameConflicts <- case nameBtnResult of + FormSuccess BtnNameCandidatesInfer -> do + (infConflicts, infAmbiguous, infRedundantNames, infAccepted) <- Candidates.inferNamesHandler + unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousNameCandidatesRemoved $ length infAmbiguous unless (null infRedundantNames) . addMessageI Info . MsgRedundantNameCandidatesRemoved $ length infRedundantNames - unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents - unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone + -- unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone unless (null infConflicts) $ do let badKeys = map entityKey infConflicts setSessionJson SessionConflictingStudyTerms badKeys @@ -62,27 +74,49 @@ postAdminFeaturesR = do setSessionJson SessionNewStudyTerms newKeys if | null infAccepted - -> addMessageI Info MsgNoCandidatesInferred + -> addMessageI Info MsgNoNameCandidatesInferred | otherwise - -> addMessageI Success . MsgCandidatesInferred $ length infAccepted + -> addMessageI Success . MsgNameCandidatesInferred $ length infAccepted redirect AdminFeaturesR - FormSuccess BtnCandidatesDeleteConflicts -> do + FormSuccess BtnNameCandidatesDeleteConflicts -> do runDB $ do - confs <- Candidates.conflicts - incis <- Candidates.getIncidencesFor $ map entityKey confs + confs <- Candidates.nameConflicts + incis <- Candidates.getNameIncidencesFor $ map entityKey confs deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)] - deleteWhere [StudySubTermParentCandidateIncidence <-. (E.unValue <$> incis)] - deleteWhere [StudyTermStandaloneCandidateIncidence <-. (E.unValue <$> incis)] addMessageI Success $ MsgIncidencesDeleted $ length incis redirect AdminFeaturesR - FormSuccess BtnCandidatesDeleteAll -> do + FormSuccess BtnNameCandidatesDeleteAll -> do runDB $ do deleteWhere ([] :: [Filter StudyTermNameCandidate]) - deleteWhere ([] :: [Filter StudySubTermParentCandidate]) - deleteWhere ([] :: [Filter StudyTermStandaloneCandidate]) - addMessageI Success MsgAllIncidencesDeleted + addMessageI Success MsgAllNameIncidencesDeleted redirect AdminFeaturesR - _other -> runDB Candidates.conflicts + _other -> runDB Candidates.nameConflicts + + ((parentsBtnResult, parentsBtnWdgt), parentsBtnEnctype) <- runFormPost $ identifyForm ("infer-parents-button" :: Text) buttonForm + let parentsBtnForm = wrapForm parentsBtnWdgt def + { formAction = Just $ SomeRoute AdminFeaturesR + , formEncoding = parentsBtnEnctype + , formSubmit = FormNoSubmit + } + formResult parentsBtnResult $ \case + BtnParentCandidatesInfer -> do + (infRedundantParents, infAccepted) <- Candidates.inferParentsHandler + unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents + + let newKeys = map (studySubTermsChild . entityVal) infAccepted + setSessionJson SessionNewStudyTerms newKeys + + if | null infAccepted + -> addMessageI Info MsgNoParentCandidatesInferred + | otherwise + -> addMessageI Success . MsgParentCandidatesInferred $ length infAccepted + redirect AdminFeaturesR + BtnParentCandidatesDeleteAll -> do + runDB $ do + deleteWhere ([] :: [Filter StudySubTermParentCandidate]) + addMessageI Success MsgAllParentIncidencesDeleted + redirect AdminFeaturesR + newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms @@ -100,7 +134,7 @@ postAdminFeaturesR = do (,,,,) <$> mkDegreeTable <*> mkStudytermsTable (Set.fromList newStudyTermKeys) - (Set.fromList $ fromMaybe (map entityKey infConflicts) badStudyTermKeys) + (Set.fromList $ fromMaybe (map entityKey infNameConflicts) badStudyTermKeys) (Set.fromList schools) <*> mkCandidateTable <*> pure schools diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs index 2726ee0e6..4f61eb195 100644 --- a/src/Handler/Utils/TermCandidates.hs +++ b/src/Handler/Utils/TermCandidates.hs @@ -25,6 +25,7 @@ import qualified Data.Map as Map import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Internal.Sql as E {-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-} @@ -45,28 +46,44 @@ instance Exception FailedCandidateInference -- * list of problems, ie. StudyTerms that contradict observed incidences -- * list of redundants, i.e. redundant observed incidences -- * list of accepted, i.e. newly accepted key/name pairs -inferHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],_,[(StudyTermsId,Text)]) -inferHandler = runDB $ inferAcc mempty +inferNamesHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermNameCandidate],[(StudyTermsId,Text)]) +inferNamesHandler = runDB $ inferAcc mempty where inferAcc (accAmbiguous, accRedundants, accAccepted) = handle (\(FailedCandidateInference fails) -> (fails, accAmbiguous, accRedundants, accAccepted') <$ E.transactionUndo) $ do (infAmbis, infReds, infAccs) <- inferStep - if null infAccs - then return ([], accAmbiguous, infReds <> accRedundants, accAccepted') - else do + if + | null infAccs -> + return ([], accAmbiguous, infReds <> accRedundants, accAccepted') + | otherwise -> do E.transactionSave -- commit transaction if there are no problems inferAcc (infAmbis <> accAmbiguous, infReds <> accRedundants, infAccs <> accAccepted) where accAccepted' = over (traversed . _1) StudyTermsKey' accAccepted inferStep = do - ambiguous <- removeAmbiguous - redundants <- removeRedundant - accepted <- acceptSingletons - problems <- conflicts + ambiguous <- removeAmbiguousNames + redundants <- removeRedundantNames + accepted <- acceptSingletonNames + problems <- nameConflicts unless (null problems) $ throwM $ FailedCandidateInference problems return (ambiguous, redundants, accepted) +inferParentsHandler :: Handler ([Entity StudySubTermParentCandidate], [Entity StudySubTerms]) +inferParentsHandler = runDB $ inferAcc mempty + where + inferAcc (infReds', infAccs') = do + (infReds, infAccs) <- inferStep + if + | null infAccs -> + return (infReds' <> infReds, infAccs') + | otherwise -> + inferAcc (infReds' <> infReds, infAccs' <> infAccs) + inferStep = do + redundants <- removeRedundantParents + accepted <- acceptSingletonParents + return (redundants, accepted) + {- Candidate 1 11 "A" Candidate 1 11 "B" @@ -88,8 +105,8 @@ as a fix we simply eliminate all observations that have the same name twice, see -- | remove candidates with ambiguous observations, -- ie. candidates that have duplicated term names with differing keys -- which may happen in rare cases -removeAmbiguous :: DB [TermCandidateIncidence] -removeAmbiguous = do +removeAmbiguousNames :: DB [TermCandidateIncidence] +removeAmbiguousNames = do ambiList <- E.select $ E.from $ \candidate -> do E.groupBy ( candidate E.^. StudyTermNameCandidateIncidence , candidate E.^. StudyTermNameCandidateKey @@ -103,38 +120,60 @@ removeAmbiguous = do return ambiSet -removeRedundant :: DB ([Entity StudyTermNameCandidate], [Entity StudySubTermParentCandidate], [Entity StudyTermStandaloneCandidate]) -removeRedundant = (,,) <$> removeRedundantNames <*> removeRedundantParents <*> removeRedundantStandalone - where - -- | remove known StudyTerm from candidates that have the _exact_ name, - -- ie. if a candidate contains a known key, we remove it and its associated fullname - -- only save if ambiguous candidates haven been removed - removeRedundantNames :: DB [Entity StudyTermNameCandidate] - removeRedundantNames = do - redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do - E.on $ E.just (candidate E.^. StudyTermNameCandidateKey) E.==. sterm E.?. StudyTermsKey - E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (sterm E.?. StudyTermsName) - return candidate - -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps. - forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} -> - deleteWhere $ ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence ) - : ([ StudyTermNameCandidateKey ==. studyTermNameCandidateKey ] - ||. [ StudyTermNameCandidateName ==. studyTermNameCandidateName ]) - return redundants +-- | remove known StudyTerm from candidates that have the _exact_ name, +-- ie. if a candidate contains a known key, we remove it and its associated fullname +-- only save if ambiguous candidates haven been removed +removeRedundantNames :: DB [Entity StudyTermNameCandidate] +removeRedundantNames = do + redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do + E.on $ candidate E.^. StudyTermNameCandidateKey E.==. sterm E.^. StudyTermsKey + E.&&. ( E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm E.^. StudyTermsName + E.||. E.exists (E.from $ \(subTerm `E.InnerJoin` sterm2) -> do + E.on $ subTerm E.^. StudySubTermsParent E.==. sterm E.^. StudyTermsId + E.&&. subTerm E.^. StudySubTermsChild E.==. sterm2 E.^. StudyTermsId + E.where_ $ E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm2 E.^. StudyTermsName + ) + ) + return candidate + -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps. + forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} -> + deleteWhere $ ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence ) + : ([ StudyTermNameCandidateKey ==. studyTermNameCandidateKey ] + ||. [ StudyTermNameCandidateName ==. studyTermNameCandidateName ]) + return redundants - removeRedundantParents :: DB [Entity StudySubTermParentCandidate] - removeRedundantParents = return [] +removeRedundantParents :: DB [Entity StudySubTermParentCandidate] +removeRedundantParents = do + redundants <- E.select . E.distinct . E.from $ \(candidate `E.InnerJoin` subTerm) -> do + E.on $ candidate E.^. StudySubTermParentCandidateKey E.==. E.veryUnsafeCoerceSqlExprValue (subTerm E.^. StudySubTermsChild) + E.&&. candidate E.^. StudySubTermParentCandidateParent E.==. E.veryUnsafeCoerceSqlExprValue (subTerm E.^. StudySubTermsParent) + return candidate + forM_ redundants $ \(Entity _ StudySubTermParentCandidate{..}) -> + E.delete . E.from $ \candidate -> + E.where_ $ candidate E.^. StudySubTermParentCandidateIncidence E.==. E.val studySubTermParentCandidateIncidence + E.&&. ( candidate E.^. StudySubTermParentCandidateParent `E.in_` E.valList [studySubTermParentCandidateParent, studySubTermParentCandidateKey] + E.||. candidate E.^. StudySubTermParentCandidateKey `E.in_` E.valList [studySubTermParentCandidateParent, studySubTermParentCandidateKey] + ) + return redundants + +removeRedundantStandalone :: DB [Entity StudyTermStandaloneCandidate] +removeRedundantStandalone = do + redundants <- E.select . E.distinct . E.from $ \(candidate `E.InnerJoin` sterm) -> do + E.on $ candidate E.^. StudyTermStandaloneCandidateKey E.==. sterm E.^. StudyTermsKey + E.&&. E.not_ (E.isNothing $ sterm E.^. StudyTermsDefaultDegree) + E.&&. E.not_ (E.isNothing $ sterm E.^. StudyTermsDefaultType) + return candidate + deleteWhere [ StudyTermStandaloneCandidateId <-. map entityKey redundants ] + return redundants - removeRedundantStandalone :: DB [Entity StudyTermStandaloneCandidate] - removeRedundantStandalone = return [] -- | Search for single candidates and memorize them as StudyTerms. -- Should be called after @removeRedundant@ to increase success chances and reduce cost; otherwise memory heavy! -- Does not delete the used candidates, user @removeRedundant@ for this later on. -- Esqueleto does not provide the INTERESECT operator, thus -- we load the table into Haskell and operate there. Memory usage problem? StudyTermsCandidate may become huge. -acceptSingletons :: DB [(STKey,Text)] -acceptSingletons = do +acceptSingletonNames :: DB [(STKey,Text)] +acceptSingletonNames = do knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey] -- let knownKeysSet = Set.fromAscList knownKeys -- In case of memory problems, change next lines to conduit proper: @@ -161,13 +200,17 @@ acceptSingletons = do -- filter candidates having a unique possibility left fixedKeys :: [(STKey,Text)] - fixedKeys = Map.foldlWithKey' combFixed [] keyCandidates - - combFixed :: [(STKey,Text)] -> STKey -> Set Text -> [(STKey,Text)] - combFixed acc k s | Set.size s == 1 -- possibly redundant - , [n] <- Set.elems s = (k,n):acc - -- empty sets should not occur here , if LDAP is consistent. Maybe raise a warning?! - | otherwise = acc + fixedKeys = fst $ Map.foldlWithKey' combFixed mempty keyCandidates + where + combFixed :: ([(STKey,Text)], Set STKey) -> STKey -> Set Text -> ([(STKey,Text)], Set STKey) + combFixed (acc, bad) k s + | Set.member k bad + = (acc, bad) + | maybe False (`Set.notMember` s) (lookup k acc) + = (filter (\(k', _) -> k /= k') acc, Set.insert k bad) + | [n] <- Set.elems s + = ((k,n) : acc, bad) + | otherwise = (acc, bad) -- registerFixed :: (STKey, Text) -> DB (Key StudyTerms) registerFixed :: (STKey, Text) -> DB () @@ -178,10 +221,49 @@ acceptSingletons = do forM_ fixedKeys registerFixed return fixedKeys +acceptSingletonParents :: DB [Entity StudySubTerms] +acceptSingletonParents = do + candidates <- map entityVal <$> selectList [] [] + + let + groupedCandidates :: Map STKey (Map UUID (Set STKey)) + groupedCandidates = foldl' groupFun mempty candidates + where + groupFun :: Map STKey (Map UUID (Set STKey)) -> StudySubTermParentCandidate -> Map STKey (Map UUID (Set STKey)) + groupFun m StudySubTermParentCandidate{..} = + Map.insertWith (Map.unionWith Set.union) + studySubTermParentCandidateKey + (Map.singleton studySubTermParentCandidateIncidence $ Set.singleton studySubTermParentCandidateParent) + m + + parentCandidates :: Map STKey (Set STKey) + parentCandidates = Map.map (setIntersections . Map.elems) groupedCandidates + + fixedParents :: [(STKey, STKey)] + fixedParents = fst $ Map.foldlWithKey' combFixed mempty parentCandidates + where + combFixed :: ([(STKey, STKey)], Set STKey) -> STKey -> Set STKey -> ([(STKey, STKey)], Set STKey) + combFixed (acc, bad) k s + | Set.member k bad + = (acc, bad) + | maybe False (`Set.notMember` s) (lookup k acc) + = (filter (\(k', _) -> k /= k') acc, Set.insert k bad) + | [p] <- Set.elems s + = ((k, p) : acc, bad) + | otherwise = (acc, bad) + + inserted <- forM fixedParents $ \(key, parent) -> + insertUnique $ StudySubTerms + { studySubTermsChild = StudyTermsKey' key + , studySubTermsParent = StudyTermsKey' parent + } + + mapM getJustEntity $ catMaybes inserted + -- | all existing StudyTerms that are contradiced by current observations -conflicts :: DB [Entity StudyTerms] -conflicts = E.select $ E.from $ \studyTerms -> do +nameConflicts :: DB [Entity StudyTerms] +nameConflicts = E.select $ E.from $ \studyTerms -> do E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName E.where_ $ E.exists $ E.from $ \candidateOne -> do E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey @@ -194,12 +276,18 @@ conflicts = E.select $ E.from $ \studyTerms -> do E.where_ $ E.joinV (termsTwo E.?. StudyTermsName) E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName) E.||. E.isNothing (E.joinV $ termsTwo E.?. StudyTermsName) ) + E.||. E.exists ( E.from $ \(subTerms `E.InnerJoin` termsTwo) -> do + E.on $ subTerms E.^. StudySubTermsParent E.==. studyTerms E.^. StudyTermsId + E.&&. subTerms E.^. StudySubTermsChild E.==. termsTwo E.^. StudyTermsId + E.where_ $ termsTwo E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName) + E.||. E.isNothing (termsTwo E.^. StudyTermsName) + ) return studyTerms -- | retrieve all incidence keys having containing a certain @StudyTermKey @ -getIncidencesFor :: [StudyTermsId] -> DB [E.Value TermCandidateIncidence] -getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do +getNameIncidencesFor :: [StudyTermsId] -> DB [E.Value TermCandidateIncidence] +getNameIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do E.where_ $ candidate E.^. StudyTermNameCandidateKey `E.in_` E.valList stks' return $ candidate E.^. StudyTermNameCandidateIncidence where diff --git a/templates/adminFeatures.hamlet b/templates/adminFeatures.hamlet index 7a81e3a55..49b28758a 100644 --- a/templates/adminFeatures.hamlet +++ b/templates/adminFeatures.hamlet @@ -8,23 +8,27 @@ $newline never _{MsgStudyFeaturesTerms} ^{studytermsTable}
+

+ _{MsgStudyFeatureNameInference} +

+ $if null infNameConflicts + _{MsgStudyFeatureInferenceNoNameConflicts} + $else +

_{MsgStudyFeatureInferenceNameConflictsHeading} +