refactor(study-features): cleanup

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
+BtnNameCandidatesInfer: Studienfach-Namens-Zuordnung automatisch lernen
-BtnCandidatesDeleteConflicts: Konflikte löschen
+BtnNameCandidatesDeleteConflicts: Namenskonflikte löschen
-BtnCandidatesDeleteAll: Alle Beobachtungen 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
+StudyFeaturesParentCandidates: Kandidaten für Unterstudiengänge
-StudyFeatureInference: Studiengangschlüssel-Inferenz
+StudyFeatureNameInference: Studiengangschlüssel-Inferenz
-StudyFeatureInferenceNoConflicts: Keine Konflikte beobachtet
+StudyFeatureParentInference: Unterstudiengang-Inferenz
-StudyFeatureInferenceConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
+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
+NameCandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
-NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
+NoNameCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
-AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht.
+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

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
+BtnNameCandidatesInfer: Infer name-mapping
-BtnCandidatesDeleteConflicts: Delete conflicts
+BtnNameCandidatesDeleteConflicts: Delete name-conflicts
-BtnCandidatesDeleteAll: Delete all observations
+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
+StudyFeatureNameInference: Infer field of study mapping
-StudyFeatureInferenceNoConflicts: No observed conflicts
+StudyFeatureParentInference: Infer field of study parent relation
-StudyFeatureInferenceConflictsHeading: Fields of study with observed conflicts
+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"}
+NameCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"}
-NoCandidatesInferred: No new mappings inferred
+NoNameCandidatesInferred: No new name-mappings inferred
-AllIncidencesDeleted: Successfully deleted all observations
+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

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

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 ButtonAdminStudyTermsNames
-data ButtonAdminStudyTerms
+  = BtnNameCandidatesInfer
-  = BtnCandidatesInfer
+  | BtnNameCandidatesDeleteConflicts
-  | BtnCandidatesDeleteConflicts
+  | BtnNameCandidatesDeleteAll
-  | BtnCandidatesDeleteAll
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonAdminStudyTerms
+instance Universe ButtonAdminStudyTermsNames
-instance Finite ButtonAdminStudyTerms
+instance Finite ButtonAdminStudyTermsNames
 
-nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece
+nullaryPathPiece ''ButtonAdminStudyTermsNames $ camelToPathPiece' 1
-embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id
+embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsNames id
+
+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]
 
-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
     uid <- requireAuthId
-    ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
+    ((nameBtnResult, nameBtnWdgt), nameBtnEnctype) <- runFormPost $ identifyForm ("infer-names-button" :: Text) buttonForm
-    let btnForm = wrapForm btnWdgt def
+    let nameBtnForm = wrapForm nameBtnWdgt def
           { formAction = Just $ SomeRoute AdminFeaturesR
-          , formEncoding = btnEnctype
+          , formEncoding = nameBtnEnctype
           , formSubmit = FormNoSubmit
           }
-    infConflicts <- case btnResult of
+    infNameConflicts <- case nameBtnResult of
-      FormSuccess BtnCandidatesInfer -> do
+      FormSuccess BtnNameCandidatesInfer -> do
-        (infConflicts, infAmbiguous, (infRedundantNames, infRedundantParents, infRedundantStandalone), infAccepted) <- Candidates.inferHandler
+        (infConflicts, infAmbiguous, infRedundantNames, infAccepted) <- Candidates.inferNamesHandler
-        unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
+        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
+          confs <- Candidates.nameConflicts
-          incis <- Candidates.getIncidencesFor $ map entityKey confs
+          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])
+          addMessageI Success MsgAllNameIncidencesDeleted
-          deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
-          addMessageI Success MsgAllIncidencesDeleted
         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

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)])
+inferNamesHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermNameCandidate],[(StudyTermsId,Text)])
-inferHandler = runDB $ inferAcc mempty
+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
+        if
-          then return ([],          accAmbiguous, infReds <> accRedundants,            accAccepted')
+          | null infAccs ->
-          else do
+            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
+      ambiguous  <- removeAmbiguousNames
-      redundants <- removeRedundant
+      redundants <- removeRedundantNames
-      accepted <- acceptSingletons
+      accepted <- acceptSingletonNames
-      problems <- conflicts
+      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]
+removeAmbiguousNames :: DB [TermCandidateIncidence]
-removeAmbiguous = do
+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])
+-- | remove known StudyTerm from candidates that have the _exact_ name,
-removeRedundant = (,,) <$> removeRedundantNames <*> removeRedundantParents <*> removeRedundantStandalone
+--   ie. if a candidate contains a known key, we remove it and its associated fullname
-  where
+--   only save if ambiguous candidates haven been removed
-    -- | remove known StudyTerm from candidates that have the _exact_ name,
+removeRedundantNames :: DB [Entity StudyTermNameCandidate]
-    --   ie. if a candidate contains a known key, we remove it and its associated fullname
+removeRedundantNames = do
-    --   only save if ambiguous candidates haven been removed
+  redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
-    removeRedundantNames :: DB [Entity StudyTermNameCandidate]
+    E.on $ candidate E.^. StudyTermNameCandidateKey E.==. sterm E.^. StudyTermsKey
-    removeRedundantNames = do
+     E.&&. (       E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm E.^. StudyTermsName
-      redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
+             E.||. E.exists (E.from $ \(subTerm `E.InnerJoin` sterm2) -> do
-        E.on $ E.just (candidate E.^. StudyTermNameCandidateKey)  E.==. sterm E.?. StudyTermsKey
+                                E.on $ subTerm E.^. StudySubTermsParent E.==. sterm  E.^. StudyTermsId
-         E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (sterm E.?. StudyTermsName)
+                                 E.&&. subTerm E.^. StudySubTermsChild  E.==. sterm2 E.^. StudyTermsId
-        return candidate
+                                E.where_ $ E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm2 E.^. StudyTermsName
-      -- 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 )
+    return candidate
-                    :  ([ StudyTermNameCandidateKey       ==. studyTermNameCandidateKey       ]
+  -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
-                    ||. [ StudyTermNameCandidateName      ==. studyTermNameCandidateName      ])
+  forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} ->
-      return redundants
+    deleteWhere $   ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence )
+                :  ([ StudyTermNameCandidateKey       ==. studyTermNameCandidateKey       ]
+                ||. [ StudyTermNameCandidateName      ==. studyTermNameCandidateName      ])
+  return redundants
 
-    removeRedundantParents :: DB [Entity StudySubTermParentCandidate]
+removeRedundantParents :: DB [Entity StudySubTermParentCandidate]
-    removeRedundantParents = return []
+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)]
+acceptSingletonNames :: DB [(STKey,Text)]
-acceptSingletons = do
+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
+      fixedKeys = fst $ Map.foldlWithKey' combFixed mempty keyCandidates
-
+        where
-      combFixed :: [(STKey,Text)] -> STKey -> Set Text ->  [(STKey,Text)]
+          combFixed :: ([(STKey,Text)], Set STKey) -> STKey -> Set Text -> ([(STKey,Text)], Set STKey)
-      combFixed acc k s | Set.size s == 1 -- possibly redundant
+          combFixed (acc, bad) k s
-                        , [n] <- Set.elems s = (k,n):acc
+            | Set.member k bad
-                        -- empty sets should not occur here , if LDAP is consistent. Maybe raise a warning?!
+            = (acc, bad)
-                        | otherwise = acc
+            | 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]
+nameConflicts :: DB [Entity StudyTerms]
-conflicts = E.select $ E.from $ \studyTerms -> do
+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]
+getNameIncidencesFor :: [StudyTermsId] -> DB [E.Value TermCandidateIncidence]
-getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
+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

templates/adminFeatures.hamlet

@@ -8,23 +8,27 @@ $newline never
     _{MsgStudyFeaturesTerms}
   ^{studytermsTable}
 <section>
+  <h2>
+    _{MsgStudyFeatureNameInference}
+  <p>
+    $if null infNameConflicts
+      _{MsgStudyFeatureInferenceNoNameConflicts}
+    $else
+      <h3>_{MsgStudyFeatureInferenceNameConflictsHeading}
+      <ul>
+        $forall Entity _ (StudyTerms ky _ nm _ _) <- infNameConflicts
+          <li>
+            #{show ky} - #{foldMap id nm}
+  ^{nameBtnForm}
+  
   <h2>
     _{MsgStudyFeaturesNameCandidates}
   ^{candidateTable}
 <section>
+  <h2>
+    _{MsgStudyFeatureParentInference}
+  ^{parentsBtnForm}
+
   <h2>
     _{MsgStudyFeaturesParentCandidates}
   ^{parentCandidateTable}
-<section>
-  <h2>
-    _{MsgStudyFeatureInference}
-  <p>
-    $if null infConflicts
-      _{MsgStudyFeatureInferenceNoConflicts}
-    $else
-      <h3>_{MsgStudyFeatureInferenceConflictsHeading}
-      <ul>
-        $forall Entity _ (StudyTerms ky _ nm _ _) <- infConflicts
-          <li>
-            #{show ky} - #{foldMap id nm}
-  ^{btnForm}