feat: reduce number of study features for courses

messages/uniworx/de-de-formal.msg

@@ -879,6 +879,8 @@ SubmissionReplace: Abgabe ersetzen
 SubmissionCreated: Abgabe erfolgreich angelegt
 SubmissionUpdated: Abgabe erfolgreich ersetzt
 
+ColumnStudyFeatures: Studiendaten
+
 AdminFeaturesHeading: Studiengänge
 StudyTerms: Studiengänge
 StudyTerm: Studiengang

src/Database/Esqueleto/Utils.hs

@@ -21,17 +21,18 @@ module Database.Esqueleto.Utils
   , maybe, maybeEq, unsafeCoalesce
   , bool
   , max, min
+  , abs
   , SqlProject(..)
   , (->.)
   , fromSqlKey
   , selectCountRows
   , selectMaybe
-  , day
+  , day, diffDays
   , module Database.Esqueleto.Utils.TH
   ) where
 
 
-import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe, bool, max, min)
+import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe, bool, max, min, abs)
 import Data.Universe
 import qualified Data.Set as Set
 import qualified Data.List as List
@@ -290,6 +291,11 @@ max, min :: PersistField a
 max a b = bool a b $ b E.>. a
 min a b = bool a b $ b E.<. a
 
+abs :: (PersistField a, Num a)
+    => E.SqlExpr (E.Value a)
+    -> E.SqlExpr (E.Value a)
+abs x = bool (E.val 0 E.-. x) x $ x E.>. E.val 0
+
 unsafeCoalesce :: E.PersistField a => [E.SqlExpr (E.Value (Maybe a))] -> E.SqlExpr (E.Value a)
 unsafeCoalesce = E.veryUnsafeCoerceSqlExprValue . E.coalesce
 
@@ -330,3 +336,9 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
 
 day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
 day = E.unsafeSqlCastAs "date"
+
+infixl 6 `diffDays`
+  
+diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)
+-- ^ PostgreSQL is weird.
+diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b

src/Handler/Course/User.hs

@@ -95,10 +95,10 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
 
   (mRegistration, studies) <- lift . runDB $ do
     registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
-    studies <- E.select $ E.from $ \(course `E.InnerJoin` studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
-      E.on $ isCourseStudyFeature course studyfeat
+    studies <- E.select $ E.from $ \(course `E.InnerJoin` studyfeat `E.InnerJoin` studydegree `E.InnerJoin` studyterms) -> do
       E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
       E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
+      E.on $ isCourseStudyFeature course studyfeat
       E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
       E.where_ $ course E.^. CourseId E.==. E.val cid
       return  (studyfeat, studydegree, studyterms)

src/Handler/Course/Users.hs

@@ -524,6 +524,7 @@ postCUsersR tid ssh csh = do
           , guardOn showSex . cap' $ colUserSex'
           , pure . cap' $ colUserEmail
           , pure . cap' $ colUserMatriclenr
+          , pure . cap' $ colStudyFeatures _userStudyFeatures
           , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
           , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
           , guardOn hasExams . cap' $ colUserExams tid ssh csh

src/Handler/Utils/StudyFeatures.hs

@@ -3,6 +3,7 @@ module Handler.Utils.StudyFeatures
   , UserTableStudyFeature(..)
   , _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType
   , UserTableStudyFeatures(..)
+  , _UserTableStudyFeatures
   , isCourseStudyFeature, courseUserStudyFeatures
   , isExternalExamStudyFeature, externalExamUserStudyFeatures
   ) where
@@ -42,6 +43,9 @@ newtype UserTableStudyFeatures = UserTableStudyFeatures (Set UserTableStudyFeatu
   deriving newtype (ToJSON, FromJSON)
 makeWrapped ''UserTableStudyFeatures
 
+_UserTableStudyFeatures :: Iso' UserTableStudyFeatures [UserTableStudyFeature]
+_UserTableStudyFeatures = iso (sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped) (UserTableStudyFeatures . Set.fromList)
+
 instance Csv.ToField UserTableStudyFeature where
   toField UserTableStudyFeature{..} = encodeUtf8
     [st|#{userTableField} #{userTableDegree} (#{userTableFieldType'} #{tshow userTableSemester})|]
@@ -50,7 +54,7 @@ instance Csv.ToField UserTableStudyFeature where
             [] $ ShortStudyFieldType userTableFieldType
 
 instance Csv.ToField UserTableStudyFeatures where
-  toField = ByteString.intercalate "; " . map Csv.toField . sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped
+  toField = ByteString.intercalate "; " . map Csv.toField . view _UserTableStudyFeatures
 
 userTableStudyFeatureSort :: UserTableStudyFeature
                           -> UserTableStudyFeature
@@ -61,14 +65,35 @@ userTableStudyFeatureSort = mconcat
   , comparing userTableFieldType
   , compareUnicode `on` userTableField
   ]
-  
+
+
+isRelevantStudyFeature :: PersistEntity record
+                       => EntityField record TermId
+                       -> E.SqlExpr (Entity record)
+                       -> E.SqlExpr (Entity StudyFeatures)
+                       -> E.SqlExpr (E.Value Bool)
+isRelevantStudyFeature termField record studyFeatures
+      = overlap studyFeatures E.>. E.val 0
+  E.&&. E.not_ (E.exists betterOverlap)
+  where termEnd = E.subSelectForeign record termField (E.^. TermEnd)
+        termStart = E.subSelectForeign record termField (E.^. TermStart)
+
+        overlap :: E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Int)
+        overlap studyFeatures'
+                     = E.min (E.day $ studyFeatures' E.^. StudyFeaturesLastObserved) termEnd
+          `E.diffDays` E.maybe termStart (E.max termStart . E.day) (studyFeatures' E.^. StudyFeaturesFirstObserved)
+
+        betterOverlap = E.from $ \studyFeatures' -> do  
+          E.where_ $ studyFeatures' E.^. StudyFeaturesUser E.==. studyFeatures E.^. StudyFeaturesUser
+               E.&&. studyFeatures' E.^. StudyFeaturesDegree E.==. studyFeatures E.^. StudyFeaturesDegree
+               E.&&. studyFeatures' E.^. StudyFeaturesField E.==. studyFeatures E.^. StudyFeaturesField
+               E.&&. studyFeatures' E.^. StudyFeaturesSuperField `E.maybeEq` studyFeatures E.^. StudyFeaturesSuperField
+               E.&&. studyFeatures' E.^. StudyFeaturesType E.==. studyFeatures E.^. StudyFeaturesType
+          E.where_ $ E.abs (studyFeatures' E.^. StudyFeaturesSemester E.-. studyFeatures E.^. StudyFeaturesSemester) E.==. E.val 1
+               E.&&. overlap studyFeatures' E.>. overlap studyFeatures
 
 isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
-isCourseStudyFeature course studyFeatures
-      = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved)
-  E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart
-  where termEnd = E.subSelectForeign course CourseTerm (E.^. TermEnd)
-        termStart = E.subSelectForeign course CourseTerm (E.^. TermStart)
+isCourseStudyFeature = isRelevantStudyFeature CourseTerm
 
 courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures
 courseUserStudyFeatures cId uid = do
@@ -88,11 +113,7 @@ courseUserStudyFeatures cId uid = do
       }
 
 isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
-isExternalExamStudyFeature externalExam studyFeatures
-      = E.maybe E.true ((E.<=. termEnd) . E.day) (studyFeatures E.^. StudyFeaturesFirstObserved)
-  E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.>=. termStart
-  where termEnd = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermEnd)
-        termStart = E.subSelectForeign externalExam ExternalExamTerm (E.^. TermStart)
+isExternalExamStudyFeature = isRelevantStudyFeature ExternalExamTerm
 
 externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures
 externalExamUserStudyFeatures eeId uid = do

src/Handler/Utils/Table/Columns.hs

@@ -24,6 +24,7 @@ import Handler.Utils.Table.Pagination
 import Handler.Utils.Form
 import Handler.Utils.Widgets
 import Handler.Utils.DateTime
+import Handler.Utils.StudyFeatures
 
 import qualified Data.CaseInsensitive as CI
 
@@ -778,6 +779,13 @@ fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map Fil
 fltrDegreeUI mPrev =
   prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName)
 
+
+colStudyFeatures :: OpticColonnade UserTableStudyFeatures
+colStudyFeatures resultFeatures = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable Nothing (i18nCell MsgColumnStudyFeatures)
+    body = views (resultFeatures . _UserTableStudyFeatures) . flip listCell $ \UserTableStudyFeature{..} -> cell $(widgetFile "table/cell/user-study-feature")
+
 -----------------
 -- Allocations --
 -----------------

templates/table/cell/user-study-feature.hamlet

@@ -0,0 +1,2 @@
+$newline never
+#{userTableField} #{userTableDegree} (_{userTableFieldType} #{userTableSemester})