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

Filter-UI course participants improved

Browse Source
This commit is contained in:
Steffen Jost 2019-04-04 18:01:46 +02:00
parent 431affe6ec
commit 6da0850add
2 changed files with 48 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,8 +5,9 @@ module Database.Esqueleto.Utils
, isInfixOf, hasInfix , isInfixOf, hasInfix
, any, all , any, all
, SqlIn(..) , SqlIn(..)
, mkExactFilter, mkContainsFilter , mkExactFilter, mkExactFilterWith
, anyFilter , mkContainsFilter
, anyFilter, allFilter
) where ) where
import ClassyPrelude.Yesod hiding (isInfixOf, any, all) import ClassyPrelude.Yesod hiding (isInfixOf, any, all)
@ -74,13 +75,22 @@ _queryFeaturesDegree = $(sqlIJproj 3 2)
-- Given a lens-like function, make filter for exact matches in a collection -- Given a lens-like function, make filter for exact matches in a collection
-- (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere) -- (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere)
mkExactFilter :: (PersistField a) mkExactFilter :: (PersistField 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 a -- ^ needle collection -> Set.Set a -- ^ needle collection
-> E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool)
mkExactFilter lenslike row criterias mkExactFilter = mkExactFilterWith id
-- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@
mkExactFilterWith :: (PersistField b)
=> (a -> b) -- ^ type conversion
-> (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)
mkExactFilterWith cast lenslike row criterias
| Set.null criterias = true | Set.null criterias = true
| otherwise = lenslike row `E.in_` E.valList (Set.toList criterias) | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList 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
@ -94,9 +104,22 @@ mkContainsFilter lenslike row criterias
| Set.null criterias = true | Set.null criterias = true
| otherwise = any (hasInfix $ lenslike row) criterias | otherwise = any (hasInfix $ lenslike row) criterias
-- | Combine several filters, using logical or
anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) anyFilter :: (Foldable f)
-> t -> Set.Set Text-> E.SqlExpr (E.Value Bool) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
-> t
-> Set.Set Text
-> E.SqlExpr (E.Value Bool)
anyFilter fltrs needle criterias = F.foldr aux false fltrs anyFilter fltrs needle criterias = F.foldr aux false fltrs
where where
aux fltr acc = fltr needle criterias E.||. acc aux fltr acc = fltr needle criterias E.||. acc
-- | Combine several filters, using logical and
allFilter :: (Foldable f)
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
-> t
-> Set.Set Text
-> E.SqlExpr (E.Value Bool)
allFilter fltrs needle criterias = F.foldr aux true fltrs
where
aux fltr acc = fltr needle criterias E.&&. acc

19
src/Handler/Course.hs
View File

@ -862,15 +862,28 @@ makeCourseUserTable cid colChoices psValidator = do
, fltrUserEmail queryUser , fltrUserEmail queryUser
, fltrUserMatriclenr queryUser , fltrUserMatriclenr queryUser
, fltrUserNameEmail queryUser , fltrUserNameEmail queryUser
-- , ("course-user-degree", error "TODO") -- TODO , ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
-- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) , ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
, ("field" , FilterColumn $ E.anyFilter
[ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)
, E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
] )
, ("degree" , FilterColumn $ E.anyFilter
[ E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeName)
, E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
] )
, ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
-- , ("course-registration", error "TODO") -- TODO -- , ("course-registration", error "TODO") -- TODO
-- , ("course-user-note", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailUI mPrev [ fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev , fltrUserMatriclenrUI mPrev
, prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree)
, prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature)
] ]
dbtParams = DBParamsForm dbtParams = DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST