209 lines
10 KiB
Haskell
209 lines
10 KiB
Haskell
module Handler.Utils.StudyFeatures
|
|
( module Handler.Utils.StudyFeatures.Parse
|
|
, UserTableStudyFeature(..)
|
|
, _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType
|
|
, UserTableStudyFeatures(..)
|
|
, _UserTableStudyFeatures
|
|
, isRelevantStudyFeature, isRelevantStudyFeatureCached
|
|
, cacheStudyFeatureRelevance
|
|
, isCourseStudyFeature, courseUserStudyFeatures
|
|
, isExternalExamStudyFeature, externalExamUserStudyFeatures
|
|
, isTermStudyFeature
|
|
, isAllocationStudyFeature, allocationUserStudyFeatures
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Foundation.Type
|
|
import Foundation.I18n
|
|
|
|
import Handler.Utils.StudyFeatures.Parse
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
import qualified Data.ByteString as ByteString
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.RFC5051 (compareUnicode)
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
data UserTableStudyFeature = UserTableStudyFeature
|
|
{ userTableField
|
|
, userTableDegree :: Text
|
|
, userTableSemester :: Int
|
|
, userTableFieldType :: StudyFieldType
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
makeLenses_ ''UserTableStudyFeature
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 2
|
|
} ''UserTableStudyFeature
|
|
|
|
newtype UserTableStudyFeatures = UserTableStudyFeatures (Set UserTableStudyFeature)
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving newtype ( ToJSON, FromJSON
|
|
, Semigroup, Monoid
|
|
)
|
|
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})|]
|
|
where userTableFieldType' = renderMessage
|
|
(error "Foundation inspected during renderMessage" :: UniWorX)
|
|
[] $ ShortStudyFieldType userTableFieldType
|
|
|
|
instance Csv.ToField UserTableStudyFeatures where
|
|
toField = ByteString.intercalate "; " . map Csv.toField . view _UserTableStudyFeatures
|
|
|
|
userTableStudyFeatureSort :: UserTableStudyFeature
|
|
-> UserTableStudyFeature
|
|
-> Ordering
|
|
userTableStudyFeatureSort = mconcat
|
|
[ compareUnicode `on` userTableDegree
|
|
, comparing userTableSemester
|
|
, 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.just (studyFeatures E.^. StudyFeaturesLastObserved) E.==. studyFeatures E.^. StudyFeaturesFirstObserved
|
|
E.&&. termStart E.<=. E.day (studyFeatures E.^. StudyFeaturesLastObserved)
|
|
E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.<=. termEnd
|
|
)
|
|
)
|
|
E.&&. E.not_ (E.exists betterOverlap)
|
|
)
|
|
E.||. ( E.subSelectForeign record termField (E.^. TermActive)
|
|
E.&&. E.not_ (E.exists anyOverlap)
|
|
E.&&. studyFeatures E.^. StudyFeaturesValid
|
|
)
|
|
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)
|
|
|
|
anyOverlap = E.from $ \studyFeatures' -> do
|
|
E.where_ $ studyFeatures' E.^. StudyFeaturesUser E.==. studyFeatures E.^. StudyFeaturesUser
|
|
E.where_ $ overlap studyFeatures' E.>. E.val 0
|
|
|
|
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
|
|
|
|
isRelevantStudyFeatureCached :: PersistEntity record
|
|
=> EntityField record TermId
|
|
-> E.SqlExpr (Entity record)
|
|
-> E.SqlExpr (Entity StudyFeatures)
|
|
-> E.SqlExpr (E.Value Bool)
|
|
isRelevantStudyFeatureCached termField record studyFeatures
|
|
= E.bool calcNow useCache $ studyFeatures E.^. StudyFeaturesRelevanceCached
|
|
where
|
|
useCache
|
|
= E.exists . E.from $ \relevantStudyFeatures ->
|
|
E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesTerm E.==. record E.^. termField
|
|
E.&&. relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. studyFeatures E.^. StudyFeaturesId
|
|
calcNow = isRelevantStudyFeature termField record studyFeatures
|
|
|
|
cacheStudyFeatureRelevance :: MonadIO m
|
|
=> (E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool))
|
|
-> SqlPersistT m ()
|
|
cacheStudyFeatureRelevance fFilter = do
|
|
E.insertSelectWithConflict UniqueRelevantStudyFeatures
|
|
( E.from $ \(studyFeatures `E.InnerJoin` term) -> do
|
|
E.on E.true
|
|
E.where_ $ fFilter studyFeatures
|
|
E.where_ $ isRelevantStudyFeature TermId term studyFeatures
|
|
return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId)
|
|
)
|
|
( \_current _excluded -> [] )
|
|
E.update $ \studyFeatures -> do
|
|
E.set studyFeatures [ StudyFeaturesRelevanceCached E.=. E.true ]
|
|
E.where_ $ fFilter studyFeatures
|
|
|
|
isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
|
|
isCourseStudyFeature = isRelevantStudyFeatureCached CourseTerm
|
|
|
|
courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures
|
|
courseUserStudyFeatures cId uid = do
|
|
feats <- E.select . E.from $ \(course `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do
|
|
E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
|
E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
|
E.on $ isCourseStudyFeature course studyFeatures
|
|
E.where_ $ course E.^. CourseId E.==. E.val cId
|
|
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
|
return (terms, degree, studyFeatures)
|
|
return . UserTableStudyFeatures . Set.fromList . flip map feats $
|
|
\(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature
|
|
{ userTableField = fromMaybe (tshow studyTermsKey) studyTermsName
|
|
, userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
|
|
, userTableSemester = studyFeaturesSemester
|
|
, userTableFieldType = studyFeaturesType
|
|
}
|
|
|
|
isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
|
|
isExternalExamStudyFeature = isRelevantStudyFeatureCached ExternalExamTerm
|
|
|
|
externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures
|
|
externalExamUserStudyFeatures eeId uid = do
|
|
feats <- E.select . E.from $ \(externalExam `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do
|
|
E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
|
E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
|
E.on $ isExternalExamStudyFeature externalExam studyFeatures
|
|
E.where_ $ externalExam E.^. ExternalExamId E.==. E.val eeId
|
|
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
|
return (terms, degree, studyFeatures)
|
|
return . UserTableStudyFeatures . Set.fromList . flip map feats $
|
|
\(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature
|
|
{ userTableField = fromMaybe (tshow studyTermsKey) studyTermsName
|
|
, userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
|
|
, userTableSemester = studyFeaturesSemester
|
|
, userTableFieldType = studyFeaturesType
|
|
}
|
|
|
|
isTermStudyFeature :: E.SqlExpr (Entity Term) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
|
|
isTermStudyFeature = isRelevantStudyFeatureCached TermId
|
|
|
|
|
|
isAllocationStudyFeature :: E.SqlExpr (Entity Allocation) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
|
|
isAllocationStudyFeature = isRelevantStudyFeatureCached AllocationTerm
|
|
|
|
allocationUserStudyFeatures :: MonadIO m => AllocationId -> UserId -> SqlPersistT m UserTableStudyFeatures
|
|
allocationUserStudyFeatures aId uid = do
|
|
feats <- E.select . E.from $ \(allocation `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do
|
|
E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
|
E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
|
E.on $ isAllocationStudyFeature allocation studyFeatures
|
|
E.where_ $ allocation E.^. AllocationId E.==. E.val aId
|
|
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
|
return (terms, degree, studyFeatures)
|
|
return . UserTableStudyFeatures . Set.fromList . flip map feats $
|
|
\(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature
|
|
{ userTableField = fromMaybe (tshow studyTermsKey) studyTermsName
|
|
, userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
|
|
, userTableSemester = studyFeaturesSemester
|
|
, userTableFieldType = studyFeaturesType
|
|
}
|