From 8c221ad5e81ab743b15cfe2fd87184b039b82784 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 20 Mar 2019 09:49:06 +0100 Subject: [PATCH] Term candidate inference handler added, not connected --- src/Handler/Admin.hs | 28 +++++++++------------- src/Handler/Course.hs | 2 +- src/Handler/Utils/TermCandidates.hs | 36 +++++++++++++++++++++++++++++ 3 files changed, 48 insertions(+), 18 deletions(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 6751053b2..a9d5afa59 100644 --- a/src/Handler/Admin.hs +++ b/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}
- $if null conflicts + $if null conflicted Kein Konflikte beobachtet. $else

Studiengangseingträge mit beobachteten Konflikten:
    - $forall (Entity _ (StudyTerms ky _ nm)) <- conflicts + $forall (Entity _ (StudyTerms ky _ nm)) <- conflicted
  • #{show ky} - #{foldMap id nm}
    ^{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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index fa3c811cb..823504dcc 100644 --- a/src/Handler/Course.hs +++ b/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 diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs index 8997969c8..def3fff41 100644 --- a/src/Handler/Utils/TermCandidates.hs +++ b/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)])