From 04bea764f4dcafda1a07ca3a98f290433c207bc5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 10 Jul 2019 13:51:02 +0200 Subject: [PATCH] feat(exams): show study features of registered users BREAKING CHANGE: E.isInfixOf and E.hasInfix --- src/Database/Esqueleto/Utils.hs | 41 +++++++++---- src/Handler/Corrections.hs | 8 +-- src/Handler/Course.hs | 10 +-- src/Handler/Exam.hs | 72 +++++++++++++++++----- src/Handler/Users.hs | 12 ++-- src/Handler/Utils/Table/Cells.hs | 12 ++++ src/Handler/Utils/Table/Columns.hs | 99 ++++++++++++++++++++++++++---- src/Utils/Lens.hs | 26 +++++--- src/Utils/Lens/TH.hs | 15 +++-- 9 files changed, 223 insertions(+), 72 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index bd8120ba7..cc8ffbb24 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -7,7 +7,7 @@ module Database.Esqueleto.Utils , any, all , SqlIn(..) , mkExactFilter, mkExactFilterWith - , mkContainsFilter + , mkContainsFilter, mkContainsFilterWith , mkExistsFilter , anyFilter, allFilter ) where @@ -40,12 +40,18 @@ isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (M isJust = E.not_ . E.isNothing -- | Check if the first string is contained in the text derived from the second argument -isInfixOf :: (E.Esqueleto query expr backend, E.SqlString s2) => - Text -> expr (E.Value s2) -> expr (E.Value Bool) -isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) +isInfixOf :: ( E.Esqueleto query expr backend + , E.SqlString s1 + , E.SqlString s2 + ) + => expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool) +isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%) -hasInfix :: (E.Esqueleto query expr backend, E.SqlString s2) => - expr (E.Value s2) -> Text -> expr (E.Value Bool) +hasInfix :: ( E.Esqueleto query expr backend + , E.SqlString s1 + , E.SqlString s2 + ) + => expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool) hasInfix = flip isInfixOf -- | Given a test and a set of values, check whether anyone succeeds the test @@ -101,14 +107,23 @@ mkExactFilterWith cast lenslike row criterias -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements -- (Keep Set here to ensure that there are no duplicates) -mkContainsFilter :: (E.SqlString a) - => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element - -> t -- ^ query row - -> Set.Set Text -- ^ needle collection - -> E.SqlExpr (E.Value Bool) -mkContainsFilter lenslike row criterias +mkContainsFilter :: E.SqlString a + => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set a -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkContainsFilter = mkContainsFilterWith id + +-- | like `mkContainsFiler` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter` +mkContainsFilterWith :: E.SqlString b + => (a -> b) + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set a -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkContainsFilterWith cast lenslike row criterias | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) criterias + | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) mkExistsFilter :: PathPiece a => (t -> a -> E.SqlQuery ()) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index fcdcb32e4..94508b990 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -348,9 +348,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d ) , ( "corrector-name-email" -- corrector filter does not work for text-filtering , FilterColumn $ E.anyFilter - [ E.mkContainsFilter $ queryCorrector >>> (E.?. UserSurname) - , E.mkContainsFilter $ queryCorrector >>> (E.?. UserDisplayName) - , E.mkContainsFilter $ queryCorrector >>> (E.?. UserEmail) + [ E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserSurname) + , E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserDisplayName) + , E.mkContainsFilterWith (Just . CI.mk) $ queryCorrector >>> (E.?. UserEmail) ] ) , ( "user-name-email" @@ -360,7 +360,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d E.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter [ E.mkContainsFilter (E.^. UserSurname) , E.mkContainsFilter (E.^. UserDisplayName) - , E.mkContainsFilter (E.^. UserEmail) + , E.mkContainsFilterWith CI.mk (E.^. UserEmail) ] ) , ( "user-matriclenumber" diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 3340c6894..156fc77ae 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1140,13 +1140,13 @@ makeCourseUserTable cid restrict colChoices psValidator = do , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) , ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) , ("field" , FilterColumn $ E.anyFilter - [ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName) - , E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand) + [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName) + , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand) , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) ] ) , ("degree" , FilterColumn $ E.anyFilter - [ E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeName) - , E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand) + [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName) + , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand) , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) ] ) , ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) @@ -1154,7 +1154,7 @@ makeCourseUserTable cid restrict colChoices psValidator = do E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - E.&&. E.hasInfix (tutorial E.^. TutorialName) criterion + E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId ) -- , ("course-registration", error "TODO") -- TODO diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index c93195d9b..b3f15b334 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -733,8 +733,8 @@ getEShowR tid ssh csh examn = do examBonusW bonusRule = $(widgetFile "widgets/bonusRule") $(widgetFile "exam-show") -type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) -type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence)) +type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) +type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms)) instance HasEntity ExamUserTableData User where hasEntity = _dbrOutput . _2 @@ -746,44 +746,82 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) _userTableOccurrence = _dbrOutput . _3 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) + +queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) +queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) -queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) +queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) + +queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) +queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) + +queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) +queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) + +resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures) +resultStudyFeatures = _dbrOutput . _4 . _Just + +resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree) +resultStudyDegree = _dbrOutput . _5 . _Just + +resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms) +resultStudyField = _dbrOutput . _6 . _Just getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - eid <- runDB $ fetchExamId tid ssh csh examn + Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn let examUsersDBTable = DBTable{..} where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence) = do + dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do + E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField + E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree + E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) + E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) + E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence) + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtProj = return dbtColonnade = dbColonnade $ mconcat [ colUserNameLink (CourseR tid ssh csh . CUserR) , colUserMatriclenr - -- , colUserDegreeShort - -- , colUserField - -- , colUserSemester + , colField resultStudyField + , colDegreeShort resultStudyDegree + , colFeaturesSemester resultStudyFeatures , sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence) ] dbtSorting = Map.fromList - [ sortUserNameLink queryUser - , sortUserSurname queryUser - , sortUserDisplayName queryUser - , sortUserMatriclenr queryUser + [ sortUserNameLink queryUser + , sortUserSurname queryUser + , sortUserDisplayName queryUser + , sortUserMatriclenr queryUser + , sortField queryStudyField + , sortDegreeShort queryStudyDegree + , sortFeaturesSemester queryStudyFeatures ] - dbtFilter = Map.empty - dbtFilterUI = const mempty - dbtStyle = def + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , fltrUserMatriclenr queryUser + , fltrField queryStudyField + , fltrDegree queryStudyDegree + , fltrFeaturesSemester queryStudyFeatures + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev + , fltrFieldUI mPrev + , fltrDegreeUI mPrev + , fltrFeaturesSemesterUI mPrev + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "exam-users" diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 01b0055d9..cf089cb58 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -108,14 +108,14 @@ getUsersR = do ) ] , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates - [ ( "user-search", FilterColumn $ \user criterion -> - if Set.null criterion then E.true else -- TODO: why is this condition not needed? + [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) -> + if Set.null criteria then E.true else -- TODO: why is this condition not needed? -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text) - E.any (user E.^. UserDisplayName `E.hasInfix`) criterion + E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria ) - , ( "matriculation", FilterColumn $ \user (criterion :: Set.Set Text) -> if - | Set.null criterion -> E.true -- TODO: why can this be eFalse and work still? - | otherwise -> E.any (user E.^. UserMatrikelnummer `E.hasInfix`) criterion + , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if + | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? + | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria ) , ( "school", FilterColumn $ \user criterion -> if | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index a4a9a2fb2..df62bbdbb 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -194,6 +194,18 @@ cellHasEMail :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasEMail = emailCell . view _userEmail +cellHasSemester :: (IsDBTable m c, HasStudyFeatures a) => a -> DBCell m c +cellHasSemester = numCell . view _studyFeaturesSemester + + +cellHasField :: (IsDBTable m c, HasStudyTerms a) => a -> DBCell m c +cellHasField x = maybe (numCell $ x ^. _studyTermsKey) textCell $ x ^. _studyTermsName <|> x ^. _studyTermsShorthand + + +cellHasDegreeShort :: (IsDBTable m c, HasStudyDegree a) => a -> DBCell m c +cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _studyDegreeShorthand <|> x ^. _studyDegreeName + + -- Just for documentation purposes; inline this code instead: maybeDateTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 09db6649d..c5a637efc 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -11,7 +11,6 @@ import Import -- import Text.Blaze (ToMarkup(..)) -import Data.Monoid (Any(..)) import qualified Database.Esqueleto as E import Database.Esqueleto.Utils as E @@ -19,6 +18,8 @@ import Utils.Lens import Handler.Utils import Handler.Utils.Table.Cells +import qualified Data.CaseInsensitive as CI + -------------------------------- -- Generic Columns @@ -156,9 +157,9 @@ fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t) fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter - [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName) - , mkContainsFilter $ queryUser >>> (E.^. UserSurname) - , mkContainsFilter $ queryUser >>> (E.^. UserEmail) + [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName) + , mkContainsFilter $ queryUser >>> (E.^. UserSurname) + , mkContainsFilterWith CI.mk $ queryUser >>> (E.^. UserEmail) ] ) @@ -179,12 +180,14 @@ colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t) -sortUserMatriclenr queryUser = ( "user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) +sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) -fltrUserMatriclenr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) - => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t) -fltrUserMatriclenr queryUser = ( "user-matriclenumber", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserMatrikelnummer)) +fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) + , IsString d + ) + => (a -> E.SqlExpr (Entity User)) + -> (d, FilterColumn t) +fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer)) fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserMatriclenrUI mPrev = @@ -199,13 +202,83 @@ colUserEmail = sortable (Just "user-email") (i18nCell MsgEMail) cellHasEMail sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t) sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail)) -fltrUserEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) - => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t) -fltrUserEmail queryUser = ( "user-email", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserEmail)) +fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool)) + , IsString d + ) + => (a -> E.SqlExpr (Entity User)) + -> (d, FilterColumn t) +fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail)) fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserEmailUI mPrev = prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgEMail) +-------------------- +-- Study features -- +-------------------- + +colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) +colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature + +sortFeaturesSemester :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (d, SortColumn t) +sortFeaturesSemester queryFeatures = ("features-semester", SortColumn $ queryFeatures >>> (E.?. StudyFeaturesSemester)) + +fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool)) + , IsString d + ) + => (a -> E.SqlExpr (Maybe (Entity StudyFeatures))) + -> (d, FilterColumn t) +fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester)) + +fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrFeaturesSemesterUI mPrev = + prismAForm (singletonFilter "features-semester" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field (YesodDB UniWorX) Int) (fslI MsgStudyFeatureAge) + + +colField :: (IsDBTable m c, HasStudyTerms x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) +colField terms = sortable (Just "terms") (i18nCell MsgStudyTerm) $ maybe mempty cellHasField . firstOf terms + +sortField :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (d, SortColumn t) +sortField queryTerms = ("terms", SortColumn $ queryTerms >>> (E.?. StudyTermsName)) + +fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) + , IsString d + ) + => (a -> E.SqlExpr (Maybe (Entity StudyTerms))) + -> (d, FilterColumn t) +fltrField queryFeatures = ( "terms" + , FilterColumn $ anyFilter + [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName) + , mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsShorthand) + , mkExactFilterWith readMay $ queryFeatures >>> (E.?. StudyTermsKey) + ] + ) + +fltrFieldUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrFieldUI mPrev = + prismAForm (singletonFilter "terms") mPrev $ aopt textField (fslI MsgStudyTerm) + + +colDegreeShort :: (IsDBTable m c, HasStudyDegree x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) +colDegreeShort terms = sortable (Just "degree-short") (i18nCell MsgDegreeShort) $ maybe mempty cellHasDegreeShort . firstOf terms + +sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (d, SortColumn t) +sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand)) + +fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) + , IsString d + ) + => (a -> E.SqlExpr (Maybe (Entity StudyDegree))) + -> (d, FilterColumn t) +fltrDegree queryFeatures = ( "degree" + , FilterColumn $ anyFilter + [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName) + , mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeShorthand) + , mkExactFilterWith readMay $ queryFeatures >>> (E.?. StudyDegreeKey) + ] + ) + +fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrDegreeUI mPrev = + prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 0f3deec79..8fdd73d46 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -41,13 +41,13 @@ _nullable = prism' toNullable fromNullable -- makeLenses_ ''Course -makeClassyFor_ "HasCourse" "hasCourse" ''Course +makeClassyFor_ ''Course -- class HasCourse c where -- hasCourse :: Lens' c Course -- makeLenses_ ''User -makeClassyFor_ "HasUser" "hasUser" ''User +makeClassyFor_ ''User -- > :info HasUser -- class HasUser c where -- hasUser :: Lens' c User -- MINIMAL @@ -56,8 +56,24 @@ makeClassyFor_ "HasUser" "hasUser" ''User -- _user... -- +makeClassyFor_ ''StudyFeatures + +makeClassyFor_ ''StudyDegree + +makeClassyFor_ ''StudyTerms + makeLenses_ ''Entity + +instance HasStudyFeatures a => HasStudyFeatures (Entity a) where + hasStudyFeatures = _entityVal . hasStudyFeatures + +instance HasStudyTerms a => HasStudyTerms (Entity a) where + hasStudyTerms = _entityVal . hasStudyTerms + +instance HasStudyDegree a => HasStudyDegree (Entity a) where + hasStudyDegree = _entityVal . hasStudyDegree + -- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW: -- makeClassyFor_ "HasEntity" "hasEntity" ''Entity -- class HasEntity c record | c -> record where @@ -96,12 +112,6 @@ makePrisms ''AuthResult makePrisms ''FormResult -makeLenses_ ''StudyFeatures - -makeLenses_ ''StudyDegree - -makeLenses_ ''StudyTerms - makeLenses_ ''StudyTermCandidate makeLenses_ ''FieldView diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs index b8d8857a7..701c87b76 100644 --- a/src/Utils/Lens/TH.hs +++ b/src/Utils/Lens/TH.hs @@ -1,6 +1,6 @@ module Utils.Lens.TH where -import ClassyPrelude (String, Maybe(..)) +import ClassyPrelude (Maybe(..), (<>)) import Control.Lens import Control.Lens.Internal.FieldTH import Language.Haskell.TH @@ -56,9 +56,12 @@ makeLenses_ = makeFieldOptics lensRules_ -- | like makeClassyFor but only specifies names for class and its function, -- otherwise lenses are created with underscore like `makeLenses_` -makeClassyFor_ :: String -> String -> Name -> DecsQ -makeClassyFor_ clsName funName = makeFieldOptics (classyRulesFor_ clNamer) +makeClassyFor_ :: Name -> DecsQ +makeClassyFor_ recName = makeFieldOptics (classyRulesFor_ clNamer) recName where - clNamer :: ClassyNamer - -- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17 - clNamer _ = Just (mkName clsName, mkName funName) \ No newline at end of file + clsName = "Has" <> nameBase recName + funName = "has" <> nameBase recName + + clNamer :: ClassyNamer + -- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17 + clNamer _ = Just (mkName clsName, mkName funName)