Term candidate inference handler added, not connected

src/Handler/Admin.hs

@@ -1,12 +1,12 @@
 module Handler.Admin where
 
 import Import
-import Handler.Utils
 import Jobs
-
+import Handler.Utils
 import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
 
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Writer (mapWriterT)
 
 import Utils.Lens
 
@@ -17,17 +17,20 @@ import Utils.Lens
 
 -- import qualified Data.Set as Set
 import qualified Data.Map as Map
-import Handler.Utils.Table.Cells
+
 import Database.Persist.Sql (fromSqlKey)
 import qualified Database.Esqueleto as E
 import Database.Esqueleto.Utils as E
 
+import Handler.Utils.Table.Cells
+import qualified Handler.Utils.TermCandidates as Candidates
+
 -- import Colonnade hiding (fromMaybe)
 -- import Yesod.Colonnade
 
 -- import qualified Data.UUID.Cryptographic as UUID
 
-import Control.Monad.Trans.Writer (mapWriterT)
+
 
 
 getAdminR :: Handler Html
@@ -179,11 +182,11 @@ getAdminFeaturesR = postAdminFeaturesR
 postAdminFeaturesR = do
     (   (degreeResult,degreeTable)
       , (studyTermsResult,studytermsTable)
-      , conflicts
+      , conflicted
       , ((),candidateTable)) <- runDB $ (,,,)
       <$> mkDegreeTable
       <*> mkStudytermsTable
-      <*> conflictedStudyTerms
+      <*> Candidates.conflicts
       <*> mkCandidateTable
 
     let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
@@ -217,12 +220,12 @@ postAdminFeaturesR = do
             ^{studytermsTable}
         <div .container>
           <section>
-            $if null conflicts
+            $if null conflicted
               Kein Konflikte beobachtet.
             $else
               <h3>Studiengangseingträge mit beobachteten Konflikten:
               <ul>
-                $forall (Entity _ (StudyTerms ky _ nm)) <- conflicts
+                $forall (Entity _ (StudyTerms ky _ nm)) <- conflicted
                   <li> #{show ky} - #{foldMap id nm}
             <div .container>
               ^{candidateTable}
@@ -314,12 +317,3 @@ postAdminFeaturesR = do
           psValidator   = def & defaultSorting [SortAscBy "termcandidate-key", SortAscBy "termcandidate-name"]
       in dbTable psValidator DBTable{..}
 
-    conflictedStudyTerms :: DB [Entity StudyTerms]
-    conflictedStudyTerms = 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.^. StudyTermCandidateKey E.==. studyTerms E.^. StudyTermsKey
-        E.where_ $ E.notExists . E.from $ \candidateTwo ->  do
-            E.where_ $ candidateTwo E.^. StudyTermCandidateIncidence E.==. candidateOne E.^. StudyTermCandidateIncidence
-            E.where_ $ studyTerms E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermCandidateName)
-      return studyTerms

src/Handler/Course.hs

@@ -307,7 +307,7 @@ getCShowR tid ssh csh = do
 -- , maybe a course secret
 registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
 -- unfinished WIP: must take study features if registred and show as mforced field
-registerForm loggedin participant defSFid msecret = identForm FIDcourseRegister $ \extra -> do
+registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do
     -- secret fields
     (msecretRes', msecretView) <- case msecret of
       (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing

src/Handler/Utils/TermCandidates.hs

@@ -30,10 +30,46 @@ import qualified Database.Esqueleto as E
 
 type STKey = Int -- Key StudyTerms -- for convenience, assmued identical to field StudyTermCandidateKey
 
+data FailedCandidateInference = FailedCandidateInference [Entity StudyTerms]
+  deriving (Typeable)
+
+instance Show FailedCandidateInference where
+  show (FailedCandidateInference _) = "Failed Candidate Inference" -- TODO
+
+instance Exception FailedCandidateInference
+  -- Default Instance
+
 -- | Just an heuristik to fill in defaults
 shortenStudyTerm :: Text -> Text
 shortenStudyTerm = concatMap (take 4) . splitCamel
 
+-- | Attempt to identify new StudyTerms based on observations
+inferHandler :: Handler ([UUID],([Entity StudyTerms],[Entity StudyTermCandidate],[(STKey,Text)]))
+inferHandler = do
+    (ambiguous, problems) <- runDB $ (,) <$> removeAmbiguous <*> conflicts
+    if (null problems)
+      then do
+        infRes <- inferAcc ([],[])
+        return (ambiguous, infRes)
+      else
+        return (ambiguous,(problems,[],[]))
+
+  where
+    inferAcc (accRedundants, accAccepted) =
+      handle (\(FailedCandidateInference fails) -> return (fails,accRedundants,accAccepted)) $ do
+        (infReds,infAccs) <- runDB inferStep
+        if null infAccs
+          then return ([], infReds ++ accRedundants,            accAccepted)
+          else inferAcc   (infReds ++ accRedundants, infAccs ++ accAccepted)
+
+    inferStep = do
+      redundants <- removeRedundant
+      accepted <- acceptSingletons
+      problems <- conflicts
+      when (not $ null problems) $ throw $ FailedCandidateInference problems
+      return (redundants, accepted)
+
+
 -- | Attempt to identify new StudyTerms based on observations
 -- infer :: MonadHandler m => m ([Entity StudyTerms],[Entity StudyTerms])
 infer :: DB ([Entity StudyTerms],[(STKey, Text)])