Generic Columns module allowing generic sorting and filtering.
Done for an initial part of course participant table.
This commit is contained in:
SJost
parent
4253390e93
commit
2ddda4578e
1
build.sh
1
build.sh
@ -1,3 +1,4 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev
|
||||
echo Build task completed.
|
||||
|
||||
@ -5,9 +5,11 @@ module Database.Esqueleto.Utils
|
||||
, isInfixOf, hasInfix
|
||||
, any, all
|
||||
, SqlIn(..)
|
||||
, mkInFilter
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (isInfixOf, any, all)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Foldable as F
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
@ -51,3 +53,22 @@ all :: Foldable f =>
|
||||
all test = F.foldr (\needle acc -> acc E.&&. test needle) true
|
||||
|
||||
$(sqlInTuples [2..16])
|
||||
|
||||
|
||||
-- | generic filter creation for dbTable
|
||||
-- Given a lens-like function, make filter
|
||||
-- What I thought:
|
||||
-- mkFilter :: (Foldable f, E.From query expr backend a)
|
||||
-- => (a -> E.SqlExpr (E.Value b))
|
||||
-- -> a
|
||||
-- -> f b
|
||||
-- -> E.SqlExpr (E.Value Bool)
|
||||
-- What is inferred:
|
||||
mkInFilter :: (PersistField a)
|
||||
=> (t -> E.SqlExpr (E.Value a))
|
||||
-> t
|
||||
-> Set.Set a
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
mkInFilter lenslike row criterias
|
||||
| Set.null criterias = true
|
||||
| otherwise = (lenslike row) `E.in_` E.valList (Set.toList criterias)
|
||||
@ -8,10 +8,12 @@ import Utils.Lens
|
||||
import Utils.Form
|
||||
-- import Utils.DB
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Course
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Database
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Table.Columns
|
||||
import Database.Esqueleto.Utils
|
||||
|
||||
-- import Data.Time
|
||||
-- import qualified Data.Text as T
|
||||
@ -691,6 +693,32 @@ _userTableNote = _dbrOutput . _3
|
||||
_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
|
||||
_userTableFeatures = _dbrOutput . _4
|
||||
|
||||
_rowUserSemester :: Traversal' UserTableData Int
|
||||
_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
|
||||
|
||||
|
||||
-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
|
||||
queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
|
||||
queryUser ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user
|
||||
|
||||
-- queryUserName :: UserTableExpr -> E.SqlExpr (E.Value Text)
|
||||
-- queryUserName ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserDisplayName
|
||||
|
||||
-- queryUserDisplayName :: UserTableExpr -> E.SqlExpr (E.Value Text)
|
||||
-- queryUserDisplayName ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserDisplayName
|
||||
|
||||
queryUserFeatures :: UserTableExpr -> (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))
|
||||
queryUserFeatures ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` studyFeatures) = studyFeatures
|
||||
|
||||
queryUserSemester :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int))
|
||||
queryUserSemester = aux . queryUserFeatures
|
||||
where aux (features `E.InnerJoin` _degree `E.InnerJoin` _terms)
|
||||
= features E.?. StudyFeaturesSemester
|
||||
|
||||
-- Deprecated in favour of newer implementation
|
||||
queryUserSemester' :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int))
|
||||
queryUserSemester' ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` (features `E.InnerJoin` _degree `E.InnerJoin` _terms) )
|
||||
= features E.?. StudyFeaturesSemester
|
||||
|
||||
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserComment tid ssh csh =
|
||||
@ -703,19 +731,26 @@ colUserComment tid ssh csh =
|
||||
|
||||
colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserSemester = sortable (Just "course-user-semesternr") (i18nCell MsgStudyFeatureAge) $
|
||||
foldMap numCell . preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester)
|
||||
foldMap numCell . preview _rowUserSemester
|
||||
|
||||
colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserField = sortable (Just "course-user-field") (i18nCell MsgCourseStudyFeature) $
|
||||
foldMap htmlCell . view (_userTableFeatures . _3)
|
||||
|
||||
colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserFieldShort = sortable (Just "course-user-field") (i18nCell MsgCourseStudyFeature) $
|
||||
foldMap (htmlCell . shortStudyTerms) . view (_userTableFeatures . _3)
|
||||
|
||||
colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserDegree = sortable (Just "course-user-degree") (i18nCell MsgStudyFeatureDegree) $
|
||||
foldMap htmlCell . preview (_userTableFeatures . _2 . _Just)
|
||||
|
||||
colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserDegreeShort = sortable (Just "course-user-degree") (i18nCell MsgStudyFeatureDegree) $
|
||||
foldMap (htmlCell . shortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
|
||||
|
||||
makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
|
||||
makeCourseUserTable cid colChoices psValidator =
|
||||
-- return [whamlet|TODO|] -- TODO
|
||||
-- -- psValidator has default sorting and filtering
|
||||
let dbtIdent = "courseUsers" :: Text
|
||||
dbtStyle = def
|
||||
@ -723,8 +758,18 @@ makeCourseUserTable cid colChoices psValidator =
|
||||
dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserId
|
||||
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
|
||||
dbtColonnade = colChoices
|
||||
dbtSorting = Map.fromList [] -- TODO
|
||||
dbtFilter = Map.fromList [] -- TODO
|
||||
dbtSorting = Map.fromList
|
||||
[ sortUserName queryUser
|
||||
, sortUserDisplayName queryUser
|
||||
, sortUserMatriclenr queryUser
|
||||
, ( "course-user-semesternr", SortColumn queryUserSemester) -- $ -- preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester))
|
||||
-- TODO
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ filterUserName queryUser
|
||||
, ( "course-user-semesternr", FilterColumn $ mkInFilter queryUserSemester)
|
||||
-- TODO
|
||||
]
|
||||
dbtFilterUI = mempty -- TODO
|
||||
dbtParams = def
|
||||
in dbTableWidget' psValidator DBTable{..}
|
||||
@ -735,20 +780,20 @@ getCUsersR tid ssh csh = do
|
||||
Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
|
||||
colChoices = mconcat
|
||||
[ colUserParticipantLink tid ssh csh
|
||||
[ colUserNameLink (CourseR tid ssh csh . CUserR)
|
||||
, colUserEmail
|
||||
, colUserMatriclenr
|
||||
, colUserDegree
|
||||
, colUserField
|
||||
, colUserDegreeShort
|
||||
, colUserFieldShort
|
||||
, colUserSemester
|
||||
, sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration)
|
||||
, colUserComment tid ssh csh
|
||||
]
|
||||
psValidator = def
|
||||
psValidator = def & defaultSortingByName
|
||||
tableWidget <- runDB $ makeCourseUserTable cid colChoices psValidator
|
||||
siteLayout heading $ do
|
||||
setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
|
||||
-- TODO: creat hamlet wrapper
|
||||
-- TODO: create hamlet wrapper
|
||||
tableWidget
|
||||
|
||||
|
||||
|
||||
@ -173,30 +173,3 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
|
||||
correctorLoadCell sc =
|
||||
i18nCell $ sheetCorrectorLoad sc
|
||||
|
||||
|
||||
--------------------------------
|
||||
-- Generic Columns
|
||||
-- reuse encourages consistency
|
||||
--
|
||||
-- if it works out, turn into its own module
|
||||
-- together with filters and sorters
|
||||
|
||||
|
||||
-- | Does not work, since we have now show Instance for RenderMesage UniWorX msg
|
||||
colUser :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a (DBCell m c)
|
||||
colUser msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
|
||||
|
||||
colUserParticipant :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||
colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMembers) cellHasUser
|
||||
|
||||
colUserParticipantLink :: (IsDBTable m c, HasEntity a User) => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable a (DBCell m c)
|
||||
colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMembers) (cellHasUserLink courseLink)
|
||||
where
|
||||
-- courseLink :: CryptoUUIDUser -> Route UniWorX
|
||||
courseLink = CourseR tid ssh csh . CUserR
|
||||
|
||||
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||
colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
|
||||
|
||||
colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||
colUserEmail = sortable (Just "email") (i18nCell MsgEMail) cellHasEMail
|
||||
|
||||
87
src/Handler/Utils/Table/Columns.hs
Normal file
87
src/Handler/Utils/Table/Columns.hs
Normal file
@ -0,0 +1,87 @@
|
||||
module Handler.Utils.Table.Columns where
|
||||
|
||||
import Import
|
||||
|
||||
-- import Data.CaseInsensitive (CI)
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
|
||||
-- import Data.Monoid (Any(..))
|
||||
-- import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
-- import Control.Monad.Trans.Writer (WriterT)
|
||||
|
||||
-- import Text.Blaze (ToMarkup(..))
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
|
||||
--------------------------------
|
||||
-- Generic Columns
|
||||
-- reuse encourages consistency
|
||||
--
|
||||
-- The constant string for sort/filter keys
|
||||
-- should never be mentioned outside of this module
|
||||
-- to ensure consistency!
|
||||
--
|
||||
-- Each section should have the following parts:
|
||||
-- * colXYZ : column definitions plus variants
|
||||
-- * sortXYZ : sorting definitions for these columns
|
||||
-- * fltrXYZ : filter definitions for these columns
|
||||
-- * additional helper, such as default sorting
|
||||
|
||||
|
||||
---------------
|
||||
-- User names
|
||||
|
||||
-- | Generic sort key from msg does not work, since we have no show Instance for RenderMesage UniWorX msg. Dangerous anyway!
|
||||
colUserName' :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a (DBCell m c)
|
||||
colUserName' msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
|
||||
|
||||
colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||
colUserName = sortable (Just "user-surname") (i18nCell MsgCourseMembers) cellHasUser
|
||||
|
||||
colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
|
||||
colUserNameLink userLink = sortable (Just "user-surname") (i18nCell MsgCourseMembers) (cellHasUserLink userLink)
|
||||
|
||||
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
|
||||
-- TOOD: We want to sort first by UserSurname and then by UserDisplayName, not supportet by dbTable
|
||||
-- see also @defaultSortingName@
|
||||
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
||||
sortUserName = sortUserSurname
|
||||
|
||||
sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
||||
sortUserSurname queryUser = ( "user-surname", SortColumn $ compose queryUser (E.^. UserSurname))
|
||||
|
||||
sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
||||
sortUserDisplayName queryUser = ( "user-display-name", SortColumn $ compose queryUser (E.^. UserDisplayName))
|
||||
|
||||
defaultSortingByName :: PSValidator m x -> PSValidator m x
|
||||
defaultSortingByName = defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"]
|
||||
|
||||
filterUserName :: (IsFilterColumn t (a2 -> Set Text -> E.SqlExpr (E.Value Bool)), IsString a1)
|
||||
=> (a2 -> E.SqlExpr (Entity User))
|
||||
-> (a1, FilterColumn t)
|
||||
filterUserName queryUser = ( "user-surname", FilterColumn $ mkInFilter queryName )
|
||||
where
|
||||
queryName = compose queryUser (E.^. UserSurname)
|
||||
|
||||
|
||||
-------------------
|
||||
-- Matriclenumber
|
||||
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
|
||||
|
||||
sortUserMatriclenr :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
||||
sortUserMatriclenr queryUser = ( "user-matriclenumber", SortColumn $ compose queryUser (E.^. UserMatrikelnummer))
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
-- User E-Mail
|
||||
colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||
colUserEmail = sortable (Just "email") (i18nCell MsgEMail) cellHasEMail
|
||||
|
||||
10
src/Utils.hs
10
src/Utils.hs
@ -340,6 +340,14 @@ invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
|
||||
invertMap = groupMap . map swap . Map.toList
|
||||
|
||||
|
||||
---------------
|
||||
-- Functions --
|
||||
---------------
|
||||
|
||||
-- | Just @flip (.)@ for convenient formatting in some rare cases
|
||||
compose :: (a -> b) -> (b -> c) -> (a -> c)
|
||||
compose = flip (.)
|
||||
|
||||
|
||||
-----------
|
||||
-- Maybe --
|
||||
@ -473,8 +481,6 @@ throwExceptT :: ( Exception e, MonadThrow m )
|
||||
=> ExceptT e m a -> m a
|
||||
throwExceptT = exceptT throwM return
|
||||
|
||||
|
||||
|
||||
------------
|
||||
-- Monads --
|
||||
------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user