feat(exams): show study features of registered users
BREAKING CHANGE: E.isInfixOf and E.hasInfix
This commit is contained in:
Gregor Kleen
parent
2f34d7821a
commit
04bea764f4
@ -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 ())
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user