fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(exams): show study features of registered users

Browse Source 
BREAKING CHANGE: E.isInfixOf and E.hasInfix
This commit is contained in:
Gregor Kleen 2019-07-10 13:51:02 +02:00
parent 2f34d7821a
commit 04bea764f4
9 changed files with 223 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
src/Database/Esqueleto/Utils.hs
View File

@ -7,7 +7,7 @@ module Database.Esqueleto.Utils
, any, all , any, all
, SqlIn(..) , SqlIn(..)
, mkExactFilter, mkExactFilterWith , mkExactFilter, mkExactFilterWith
, mkContainsFilter , mkContainsFilter, mkContainsFilterWith
, mkExistsFilter , mkExistsFilter
, anyFilter, allFilter , anyFilter, allFilter
) where ) where
@ -40,12 +40,18 @@ isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (M
isJust = E.not_ . E.isNothing isJust = E.not_ . E.isNothing
-- | Check if the first string is contained in the text derived from the second argument -- | Check if the first string is contained in the text derived from the second argument
isInfixOf :: (E.Esqueleto query expr backend, E.SqlString s2) => isInfixOf :: ( E.Esqueleto query expr backend
Text -> expr (E.Value s2) -> expr (E.Value Bool) , E.SqlString s1
isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) , 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) => hasInfix :: ( E.Esqueleto query expr backend
expr (E.Value s2) -> Text -> expr (E.Value Bool) , E.SqlString s1
, E.SqlString s2
)
=> expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool)
hasInfix = flip isInfixOf hasInfix = flip isInfixOf
-- | Given a test and a set of values, check whether anyone succeeds the test -- | 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 -- | generic filter creation for dbTable
-- Given a lens-like function, make filter searching for needles in String-like elements -- Given a lens-like function, make filter searching for needles in String-like elements
-- (Keep Set here to ensure that there are no duplicates) -- (Keep Set here to ensure that there are no duplicates)
mkContainsFilter :: (E.SqlString a) mkContainsFilter :: E.SqlString a
=> (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
-> t -- ^ query row -> t -- ^ query row
-> Set.Set Text -- ^ needle collection -> Set.Set a -- ^ needle collection
-> E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool)
mkContainsFilter lenslike row criterias 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 | Set.null criterias = true
| otherwise = any (hasInfix $ lenslike row) criterias | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
mkExistsFilter :: PathPiece a mkExistsFilter :: PathPiece a
=> (t -> a -> E.SqlQuery ()) => (t -> a -> E.SqlQuery ())

8
src/Handler/Corrections.hs
View File

@ -348,9 +348,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
) )
, ( "corrector-name-email" -- corrector filter does not work for text-filtering , ( "corrector-name-email" -- corrector filter does not work for text-filtering
, FilterColumn $ E.anyFilter , FilterColumn $ E.anyFilter
[ E.mkContainsFilter $ queryCorrector >>> (E.?. UserSurname) [ E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserSurname)
, E.mkContainsFilter $ queryCorrector >>> (E.?. UserDisplayName) , E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserDisplayName)
, E.mkContainsFilter $ queryCorrector >>> (E.?. UserEmail) , E.mkContainsFilterWith (Just . CI.mk) $ queryCorrector >>> (E.?. UserEmail)
] ]
) )
, ( "user-name-email" , ( "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.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter
[ E.mkContainsFilter (E.^. UserSurname) [ E.mkContainsFilter (E.^. UserSurname)
, E.mkContainsFilter (E.^. UserDisplayName) , E.mkContainsFilter (E.^. UserDisplayName)
, E.mkContainsFilter (E.^. UserEmail) , E.mkContainsFilterWith CI.mk (E.^. UserEmail)
] ]
) )
, ( "user-matriclenumber" , ( "user-matriclenumber"

10
src/Handler/Course.hs
View File

@ -1140,13 +1140,13 @@ makeCourseUserTable cid restrict colChoices psValidator = do
, ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) , ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
, ("field" , FilterColumn $ E.anyFilter , ("field" , FilterColumn $ E.anyFilter
[ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName) [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
, E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand) , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
] ) ] )
, ("degree" , FilterColumn $ E.anyFilter , ("degree" , FilterColumn $ E.anyFilter
[ E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeName) [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
, E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand) , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
] ) ] )
, ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) , ("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.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid 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 E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
) )
-- , ("course-registration", error "TODO") -- TODO -- , ("course-registration", error "TODO") -- TODO

72
src/Handler/Exam.hs
View File

@ -733,8 +733,8 @@ getEShowR tid ssh csh examn = do
examBonusW bonusRule = $(widgetFile "widgets/bonusRule") examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
$(widgetFile "exam-show") $(widgetFile "exam-show")
type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (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)) type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms))
instance HasEntity ExamUserTableData User where instance HasEntity ExamUserTableData User where
hasEntity = _dbrOutput . _2 hasEntity = _dbrOutput . _2
@ -746,44 +746,82 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
_userTableOccurrence = _dbrOutput . _3 _userTableOccurrence = _dbrOutput . _3
queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) 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 :: 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 :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEUsersR = postEUsersR getEUsersR = postEUsersR
postEUsersR tid ssh csh examn = do postEUsersR tid ssh csh examn = do
eid <- runDB $ fetchExamId tid ssh csh examn Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn
let let
examUsersDBTable = DBTable{..} examUsersDBTable = DBTable{..}
where 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.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
return (examRegistration, user, occurrence) return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField)
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
dbtProj = return dbtProj = return
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
[ colUserNameLink (CourseR tid ssh csh . CUserR) [ colUserNameLink (CourseR tid ssh csh . CUserR)
, colUserMatriclenr , colUserMatriclenr
-- , colUserDegreeShort , colField resultStudyField
-- , colUserField , colDegreeShort resultStudyDegree
-- , colUserSemester , colFeaturesSemester resultStudyFeatures
, sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence) , sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence)
] ]
dbtSorting = Map.fromList dbtSorting = Map.fromList
[ sortUserNameLink queryUser [ sortUserNameLink queryUser
, sortUserSurname queryUser , sortUserSurname queryUser
, sortUserDisplayName queryUser , sortUserDisplayName queryUser
, sortUserMatriclenr queryUser , sortUserMatriclenr queryUser
, sortField queryStudyField
, sortDegreeShort queryStudyDegree
, sortFeaturesSemester queryStudyFeatures
] ]
dbtFilter = Map.empty dbtFilter = Map.fromList
dbtFilterUI = const mempty [ fltrUserNameEmail queryUser
dbtStyle = def , 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 dbtParams = def
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "exam-users" dbtIdent = "exam-users"

12
src/Handler/Users.hs
View File

@ -108,14 +108,14 @@ getUsersR = do
) )
] ]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates
[ ( "user-search", FilterColumn $ \user criterion -> [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
if Set.null criterion then E.true else -- TODO: why is this condition not needed? 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) -- 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 , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if
| Set.null criterion -> E.true -- TODO: why can this be eFalse and work still? | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
| otherwise -> E.any (user E.^. UserMatrikelnummer `E.hasInfix`) criterion | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria
) )
, ( "school", FilterColumn $ \user criterion -> if , ( "school", FilterColumn $ \user criterion -> if
| Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)

12
src/Handler/Utils/Table/Cells.hs
View File

@ -194,6 +194,18 @@ cellHasEMail :: (IsDBTable m a, HasUser u) => u -> DBCell m a
cellHasEMail = emailCell . view _userEmail 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: -- Just for documentation purposes; inline this code instead:
maybeDateTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a maybeDateTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a

99
src/Handler/Utils/Table/Columns.hs
View File

@ -11,7 +11,6 @@ import Import
-- import Text.Blaze (ToMarkup(..)) -- import Text.Blaze (ToMarkup(..))
import Data.Monoid (Any(..))
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils as E import Database.Esqueleto.Utils as E
@ -19,6 +18,8 @@ import Utils.Lens
import Handler.Utils import Handler.Utils
import Handler.Utils.Table.Cells import Handler.Utils.Table.Cells
import qualified Data.CaseInsensitive as CI
-------------------------------- --------------------------------
-- Generic Columns -- Generic Columns
@ -156,9 +157,9 @@ fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool
=> (a -> E.SqlExpr (Entity User)) => (a -> E.SqlExpr (Entity User))
-> (d, FilterColumn t) -> (d, FilterColumn t)
fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
[ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName) [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)
, mkContainsFilter $ queryUser >>> (E.^. UserSurname) , mkContainsFilter $ queryUser >>> (E.^. UserSurname)
, mkContainsFilter $ queryUser >>> (E.^. UserEmail) , 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 colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t) 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) fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
=> (a -> E.SqlExpr (Entity User)) , IsString d
-> (d, FilterColumn t) )
fltrUserMatriclenr queryUser = ( "user-matriclenumber", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserMatrikelnummer)) => (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 :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrUserMatriclenrUI mPrev = 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 :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail)) sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail))
fltrUserEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool))
=> (a -> E.SqlExpr (Entity User)) , IsString d
-> (d, FilterColumn t) )
fltrUserEmail queryUser = ( "user-email", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserEmail)) => (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 :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrUserEmailUI mPrev = fltrUserEmailUI mPrev =
prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgEMail) 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)

26
src/Utils/Lens.hs
View File

@ -41,13 +41,13 @@ _nullable = prism' toNullable fromNullable
-- makeLenses_ ''Course -- makeLenses_ ''Course
makeClassyFor_ "HasCourse" "hasCourse" ''Course makeClassyFor_ ''Course
-- class HasCourse c where -- class HasCourse c where
-- hasCourse :: Lens' c Course -- hasCourse :: Lens' c Course
-- makeLenses_ ''User -- makeLenses_ ''User
makeClassyFor_ "HasUser" "hasUser" ''User makeClassyFor_ ''User
-- > :info HasUser -- > :info HasUser
-- class HasUser c where -- class HasUser c where
-- hasUser :: Lens' c User -- MINIMAL -- hasUser :: Lens' c User -- MINIMAL
@ -56,8 +56,24 @@ makeClassyFor_ "HasUser" "hasUser" ''User
-- _user... -- _user...
-- --
makeClassyFor_ ''StudyFeatures
makeClassyFor_ ''StudyDegree
makeClassyFor_ ''StudyTerms
makeLenses_ ''Entity 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: -- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW:
-- makeClassyFor_ "HasEntity" "hasEntity" ''Entity -- makeClassyFor_ "HasEntity" "hasEntity" ''Entity
-- class HasEntity c record | c -> record where -- class HasEntity c record | c -> record where
@ -96,12 +112,6 @@ makePrisms ''AuthResult
makePrisms ''FormResult makePrisms ''FormResult
makeLenses_ ''StudyFeatures
makeLenses_ ''StudyDegree
makeLenses_ ''StudyTerms
makeLenses_ ''StudyTermCandidate makeLenses_ ''StudyTermCandidate
makeLenses_ ''FieldView makeLenses_ ''FieldView

15
src/Utils/Lens/TH.hs
View File

@ -1,6 +1,6 @@
module Utils.Lens.TH where module Utils.Lens.TH where
import ClassyPrelude (String, Maybe(..)) import ClassyPrelude (Maybe(..), (<>))
import Control.Lens import Control.Lens
import Control.Lens.Internal.FieldTH import Control.Lens.Internal.FieldTH
import Language.Haskell.TH import Language.Haskell.TH
@ -56,9 +56,12 @@ makeLenses_ = makeFieldOptics lensRules_
-- | like makeClassyFor but only specifies names for class and its function, -- | like makeClassyFor but only specifies names for class and its function,
-- otherwise lenses are created with underscore like `makeLenses_` -- otherwise lenses are created with underscore like `makeLenses_`
makeClassyFor_ :: String -> String -> Name -> DecsQ makeClassyFor_ :: Name -> DecsQ
makeClassyFor_ clsName funName = makeFieldOptics (classyRulesFor_ clNamer) makeClassyFor_ recName = makeFieldOptics (classyRulesFor_ clNamer) recName
where where
clNamer :: ClassyNamer clsName = "Has" <> nameBase recName
-- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17 funName = "has" <> nameBase recName
clNamer _ = Just (mkName clsName, mkName funName)
clNamer :: ClassyNamer
-- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17
clNamer _ = Just (mkName clsName, mkName funName)