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 qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter) import Handler.Utils import Handler.Utils.Table.Cells import qualified Data.CaseInsensitive as CI import qualified Colonnade import Colonnade.Encode (Colonnade(..), OneColonnade(..)) import Text.Blaze (toMarkup) -------------------------------- -- 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 type OpticColonnade focus = forall m x r' h. ( IsDBTable m x , FromSortable h ) => (forall focus'. Getting focus' r' focus) -> Colonnade h r' (DBCell m x) type OpticSortColumn' focus = forall t sortingMap. ( IsMap sortingMap , ContainerKey sortingMap ~ SortingKey , MapValue sortingMap ~ SortColumn t ) => (forall focus'. Getting focus' t focus) -> sortingMap type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val)) type OpticFilterColumn' t inp focus = forall filterMap. ( IsMap filterMap , ContainerKey filterMap ~ FilterKey , MapValue filterMap ~ FilterColumn t , IsFilterColumn t (t -> inp -> E.SqlExpr (E.Value Bool)) ) => (forall focus'. Getting focus' t focus) -> filterMap type OpticFilterColumn t focus = OpticFilterColumn' t (Set focus) (E.SqlExpr (E.Value focus)) ----------------------- -- Numbers and Indices -- | Simple index column, also indicating whether there is a row at all -- For a version without indication, use `Handler.Utils.Pagination.dbRow` instead. dbRowIndicator :: IsDBTable m Any => Colonnade Sortable (DBRow r) (DBCell m Any) dbRowIndicator = sortable Nothing (i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> tellCell (Any True) $ textCell $ tshow dbrIndex ----------- -- Terms -- ----------- colTermShort :: OpticColonnade TermId colTermShort resultTid = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "term") (i18nCell MsgTerm) body = i18nCell . ShortTermIdentifier . unTermKey . view resultTid sortTerm :: OpticSortColumn TermId sortTerm queryTid = singletonMap "term" . SortColumn $ view queryTid fltrTerm :: OpticFilterColumn t TermId fltrTerm queryTid = singletonMap "term" . FilterColumn $ mkExactFilter (view queryTid) fltrTermUI :: DBFilterUI fltrTermUI mPrev = prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTerm) ------------- -- Schools -- ------------- colSchool :: OpticColonnade SchoolId colSchool resultSsh = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "school") (i18nCell MsgSchool) body = i18nCell . unSchoolKey . view resultSsh sortSchool :: OpticSortColumn SchoolId sortSchool querySsh = singletonMap "school" . SortColumn $ view querySsh colSchoolShort :: OpticColonnade SchoolId colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "school-short") (i18nCell MsgSchoolShort) body = i18nCell . unSchoolKey . view resultSsh sortSchoolShort :: OpticSortColumn SchoolId sortSchoolShort querySsh = singletonMap "school-short" . SortColumn $ view querySsh colSchoolName :: OpticColonnade SchoolName colSchoolName resultSn = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "school-name") (i18nCell MsgSchoolName) body = i18nCell . view resultSn sortSchoolName :: OpticSortColumn SchoolName sortSchoolName querySn = singletonMap "school-name" . SortColumn $ view querySn fltrSchool :: OpticFilterColumn t SchoolId fltrSchool querySsh = singletonMap "school" . FilterColumn $ mkExactFilter (view querySsh) fltrSchoolUI :: DBFilterUI fltrSchoolUI mPrev = prismAForm (singletonFilter "school" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift schoolField) (fslI MsgSchool) ----------------- -- Allocations -- ----------------- colAllocationName :: OpticColonnade AllocationName colAllocationName resultName = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "allocation") (i18nCell MsgAllocationName) body = i18nCell . view resultName sortAllocationName :: OpticSortColumn AllocationName sortAllocationName queryName = singletonMap "allocation" . SortColumn $ view queryName fltrAllocation :: forall allocation t shorthand name. ( E.SqlProject Allocation AllocationShorthand allocation shorthand , E.SqlProject Allocation AllocationName allocation name , E.SqlString name, E.SqlString shorthand ) => OpticFilterColumn' t (Set (CI Text)) (E.SqlExpr allocation) fltrAllocation query = singletonMap "allocation" . FilterColumn $ anyFilter [ mkContainsFilterWith unSqlProject' $ views query (`E.sqlProject` AllocationShorthand) :: t -> Set (CI Text) -> E.SqlExpr (E.Value Bool) , mkContainsFilterWith unSqlProject' $ views query (`E.sqlProject` AllocationName) ] where unSqlProject' :: E.SqlProject Allocation value allocation value' => value -> value' unSqlProject' = E.unSqlProject (Proxy @Allocation) (Proxy @allocation) fltrAllocationUI :: DBFilterUI fltrAllocationUI mPrev = prismAForm (singletonFilter "allocation" . maybePrism _PathPiece) mPrev $ aopt (ciField :: Field _ AllocationName) (fslI MsgAllocation) colAllocationShorthand :: OpticColonnade AllocationShorthand colAllocationShorthand resultShort = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "allocation-short") (i18nCell MsgAllocation) body = i18nCell . view resultShort sortAllocationShorthand :: forall shorthand. PersistField shorthand => OpticSortColumn shorthand sortAllocationShorthand queryShorthand = singletonMap "allocation-short" . SortColumn $ view queryShorthand fltrAllocationActive :: UTCTime -- ^ current time -> OpticFilterColumn' t (Last Bool) (E.SqlExpr (E.Entity Allocation)) fltrAllocationActive cTime queryAllocation = singletonMap "active" . FilterColumn $ \(view queryAllocation -> allocation) (Last criterion) -> maybe (const E.true) ((E.==.) . E.val) criterion $ E.or [ staffRegisterActive allocation , staffAllocationActive allocation , registerActive allocation ] where staffRegisterActive allocation = E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationStaffRegisterFrom) E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationStaffRegisterTo) staffAllocationActive allocation = E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationStaffAllocationFrom) E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationStaffAllocationTo) registerActive allocation = E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationRegisterFrom) E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationRegisterTo) fltrAllocationActiveUI :: DBFilterUI fltrAllocationActiveUI mPrev = prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgAllocationActive) ------------------------- -- Course Applications -- ------------------------- colApplicationId :: OpticColonnade CourseApplicationId colApplicationId resultId = Colonnade.singleton (fromSortable header) body where header = Sortable Nothing (i18nCell MsgCourseApplicationId) body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetT UniWorX IO CryptoFileNameCourseApplication) colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade) colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "points") (i18nCell MsgCourseApplicationRatingPoints) body = views resultPoints $ maybe mempty i18nCell sortApplicationRatingPoints :: OpticSortColumn (Maybe ExamGrade) sortApplicationRatingPoints queryPoints = singletonMap "points" . SortColumn $ view queryPoints fltrApplicationRatingPoints :: OpticFilterColumn t (Maybe ExamGrade) fltrApplicationRatingPoints queryPoints = singletonMap "points" . FilterColumn . mkExactFilter $ view queryPoints fltrApplicationRatingPointsUI :: DBFilterUI fltrApplicationRatingPointsUI mPrev = prismAForm (singletonFilter "points" . maybePrism _PathPiece) mPrev $ aopt examGradeField (fslI MsgCourseApplicationRatingPoints) colApplicationVeto :: OpticColonnade Bool colApplicationVeto resultVeto = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "veto") (i18nCell MsgCourseApplicationVeto) body = views resultVeto $ bool mempty (iconCell IconApplicationVeto) sortApplicationVeto :: OpticSortColumn Bool sortApplicationVeto queryVeto = singletonMap "veto" . SortColumn $ view queryVeto fltrApplicationVeto :: OpticFilterColumn t Bool fltrApplicationVeto queryVeto = singletonMap "veto" . FilterColumn . mkExactFilter $ view queryVeto fltrApplicationVetoUI :: DBFilterUI fltrApplicationVetoUI mPrev = prismAForm (singletonFilter "veto" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgCourseApplicationVeto) colApplicationRatingComment :: OpticColonnade (Maybe Text) colApplicationRatingComment resultComment = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "comment") (i18nCell MsgApplicationRatingComment) body = views resultComment . maybe mempty $ cell . modal (toWidget $ hasComment True) . Right . toWidget sortApplicationRatingComment :: OpticSortColumn (Maybe Text) sortApplicationRatingComment queryComment = singletonMap "comment" . SortColumn $ view queryComment fltrApplicationRatingComment :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe Text))) fltrApplicationRatingComment queryComment = singletonMap "comment" . FilterColumn . mkContainsFilterWith Just $ view queryComment fltrApplicationRatingCommentUI :: DBFilterUI fltrApplicationRatingCommentUI mPrev = prismAForm (singletonFilter "comment") mPrev $ aopt textField (fslI MsgApplicationRatingComment) colApplicationText :: OpticColonnade (Maybe Text) colApplicationText resultText = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "text") (i18nCell MsgCourseApplicationText) body = views resultText . maybe mempty $ cell . modal (toWidget $ hasComment True) . Right . toWidget sortApplicationText :: OpticSortColumn (Maybe Text) sortApplicationText queryText = singletonMap "text" . SortColumn $ view queryText fltrApplicationText :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe Text))) fltrApplicationText queryText = singletonMap "text" . FilterColumn . mkContainsFilterWith Just $ view queryText fltrApplicationTextUI :: DBFilterUI fltrApplicationTextUI mPrev = prismAForm (singletonFilter "text") mPrev $ aopt textField (fslI MsgCourseApplicationText) colApplicationFiles :: OpticColonnade (TermId, SchoolId, CourseShorthand, CourseApplicationId, Bool) -- ^ `Bool` controls whether link is shown, use result of determination whether files exist colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "has-files") (i18nCell MsgCourseApplicationFiles) body = views resultInfo $ \(tid, ssh, csh, appId, showLink) -> if | showLink -> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do cID <- encrypt appId return $ CApplicationR tid ssh csh cID CAFilesR | otherwise -> mempty sortApplicationFiles :: OpticSortColumn Bool sortApplicationFiles queryFiles = singletonMap "has-files" . SortColumn $ view queryFiles fltrApplicationFiles :: OpticFilterColumn t Bool fltrApplicationFiles queryFiles = singletonMap "has-files" . FilterColumn . mkExactFilter $ view queryFiles fltrApplicationFilesUI :: DBFilterUI fltrApplicationFilesUI mPrev = prismAForm (singletonFilter "has-files" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgCourseApplicationFiles) --------------- -- Files -- | Generic column for links to FilePaths, where the link depends on the entire table row colFilePath :: (IsDBTable m c) => (t -> E.Value FilePath) -> (t -> Route UniWorX) -> Colonnade Sortable t (DBCell m c) colFilePath row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) makeCell where makeCell row = let filePath = E.unValue $ row2path row link = row2link row in anchorCell link $ str2widget filePath -- | Generic column for links to FilePaths, where the link only depends on the FilePath itself colFilePathSimple :: (IsDBTable m c) => (t -> E.Value FilePath) -> (FilePath -> Route UniWorX) -> Colonnade Sortable t (DBCell m c) colFilePathSimple row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) makeCell where makeCell row = let filePath = E.unValue $ row2path row link = row2link filePath in anchorCell link $ str2widget filePath -- | Generic column for File Modification colFileModification :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) colFileModification row2time = sortable (Just "time") (i18nCell MsgFileModified) (dateTimeCell . E.unValue . row2time) colFileModificationWhen :: (IsDBTable m c) => (UTCTime -> Bool) -> (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell MsgFileModified) (conDTCell . E.unValue . row2time) where conDTCell = ifCell condition dateTimeCell $ const mempty sortFilePath :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r) sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle)) sortFileModification :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r) sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. FileModified)) defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x defaultSortingByFileTitle = defaultSorting [SortAscBy "path"] defaultSortingByFileModification :: PSValidator m x -> PSValidator m x defaultSortingByFileModification = defaultSorting [SortAscBy "time"] --------------- -- User names colUserDisplayName :: OpticColonnade (UserDisplayName, UserSurname) colUserDisplayName resultDisplayName = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "user-name") (i18nCell MsgUserDisplayName) body = views resultDisplayName $ cell . uncurry nameWidget sortUserName' :: OpticSortColumn' (E.SqlExpr (E.Value UserDisplayName), E.SqlExpr (E.Value UserSurname)) sortUserName' queryDisplayName = singletonMap "user-name" . SortColumns $ \(view queryDisplayName -> (dn, sn)) -> [ SomeExprValue sn , SomeExprValue dn ] fltrUserName' :: OpticFilterColumn t UserDisplayName fltrUserName' queryDisplayName = singletonMap "user-name" . FilterColumn . mkContainsFilter $ view queryDisplayName fltrUserNameUI' :: DBFilterUI fltrUserNameUI' mPrev = prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI MsgUserDisplayName) colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) colUserName = sortable (Just "user-name") (i18nCell MsgCourseMembers) cellHasUser colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) colUserNameLink userLink = sortable (Just "user-name") (i18nCell MsgCourseMembers) (cellHasUserLink userLink) -- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t) sortUserName queryUser = ("user-name", SortColumns $ queryUser >>> \user -> [ SomeExprValue $ user E.^. UserSurname , SomeExprValue $ user E.^. UserDisplayName ] ) -- | Alias for sortUserName for consistency, since column comes in two variants sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t) sortUserNameLink = sortUserName sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t) sortUserSurname queryUser = ("user-surname", SortColumn $ queryUser >>> (E.^. UserSurname)) sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t) sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>> (E.^. UserDisplayName)) defaultSortingByName :: PSValidator m x -> PSValidator m x defaultSortingByName = -- defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter -- | Alias for sortUserName for consistency fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t) fltrUserNameLink = fltrUserName fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t) fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName ) where queryName = queryUser >>> (E.^. UserDisplayName) fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t) fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName ) where queryName = queryUser >>> (E.^. UserDisplayName) fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t) fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname)) fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t) fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)) -- | Search all names, i.e. DisplayName, Surname, EMail fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t) fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName) , mkContainsFilter $ queryUser >>> (E.^. UserSurname) , mkContainsFilterWith CI.mk $ queryUser >>> (E.^. UserEmail) ] ) fltrUserNameLinkUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameLinkUI = fltrUserNameUI fltrUserNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameUI mPrev = prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI MsgCourseMembers) fltrUserNameEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameEmailUI mPrev = prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers) ------------------- -- Matriculation -- ------------------- colUserMatriculation :: OpticColonnade (Maybe UserMatriculation) colUserMatriculation resultMatriculation = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "user-matriculation") (i18nCell MsgUserMatriculation) body = views resultMatriculation . maybe mempty $ cell . toWidget sortUserMatriculation :: OpticSortColumn (Maybe UserMatriculation) sortUserMatriculation queryMatriculation = singletonMap "user-matriculation" . SortColumn $ view queryMatriculation fltrUserMatriculation :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe UserMatriculation))) fltrUserMatriculation queryMatriculation = singletonMap "user-matriculation" . FilterColumn . mkContainsFilterWith Just $ view queryMatriculation fltrUserMatriculationUI :: DBFilterUI fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgUserMatriculation) colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) 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)) 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 = prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr) ---------------- -- User E-Mail colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) 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 (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 -- -------------------- colStudyDegree :: OpticColonnade StudyDegree colStudyDegree resultDegree = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "features-degree") (i18nCell MsgStudyFeatureDegree) body = views resultDegree $ \StudyDegree{..} -> cell . maybe (toWidget $ toMarkup studyDegreeKey) toWidget $ studyDegreeShorthand <|> studyDegreeName sortStudyDegree :: forall studyDegree name shorthand key. ( E.SqlProject StudyDegree (Maybe StudyDegreeName) studyDegree name , E.SqlProject StudyDegree (Maybe StudyDegreeShorthand) studyDegree shorthand , E.SqlProject StudyDegree StudyDegreeKey studyDegree key , PersistField key, PersistField name, PersistField shorthand ) => OpticSortColumn' (E.SqlExpr studyDegree) sortStudyDegree queryDegree = singletonMap "features-degree" . SortColumns $ \(view queryDegree -> degree) -> [ SomeExprValue $ degree `E.sqlProject` StudyDegreeName , SomeExprValue $ degree `E.sqlProject` StudyDegreeShorthand , SomeExprValue $ degree `E.sqlProject` StudyDegreeKey ] fltrStudyDegree :: forall studyDegree t name shorthand key. ( E.SqlProject StudyDegree (Maybe StudyDegreeName) studyDegree name , E.SqlProject StudyDegree (Maybe StudyDegreeShorthand) studyDegree shorthand , E.SqlProject StudyDegree StudyDegreeKey studyDegree key , E.SqlString name, E.SqlString shorthand, PersistField key ) => OpticFilterColumn' t (Set Text) (E.SqlExpr studyDegree) fltrStudyDegree queryDegree = singletonMap "features-degree" . FilterColumn $ anyFilter [ mkContainsFilterWith (unSqlProject' . Just) $ view queryDegree >>> (`E.sqlProject` StudyDegreeName) , mkContainsFilterWith (unSqlProject' . Just) $ view queryDegree >>> (`E.sqlProject` StudyDegreeShorthand) , mkExactFilterWith (fmap unSqlProject' . (readMay :: Text -> Maybe StudyDegreeKey)) $ view queryDegree >>> (`E.sqlProject` StudyDegreeKey) >>> E.just ] where unSqlProject' :: E.SqlProject StudyDegree value studyDegree value' => value -> value' unSqlProject' = E.unSqlProject (Proxy @StudyDegree) (Proxy @studyDegree) fltrStudyDegreeUI :: DBFilterUI fltrStudyDegreeUI mPrev = prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree) colStudyTerms :: OpticColonnade StudyTerms colStudyTerms resultTerms = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "features-terms") (i18nCell MsgStudyTerm) body = views resultTerms $ \StudyTerms{..} -> cell . maybe (toWidget $ toMarkup studyTermsKey) toWidget $ studyTermsShorthand <|> studyTermsName sortStudyTerms :: forall studyTerms name shorthand key. ( E.SqlProject StudyTerms (Maybe StudyTermsName) studyTerms name , E.SqlProject StudyTerms (Maybe StudyTermsShorthand) studyTerms shorthand , E.SqlProject StudyTerms StudyTermsKey studyTerms key , PersistField key, PersistField name, PersistField shorthand ) => OpticSortColumn' (E.SqlExpr studyTerms) sortStudyTerms queryTerms = singletonMap "features-terms" . SortColumns $ \(view queryTerms -> terms) -> [ SomeExprValue $ terms `E.sqlProject` StudyTermsName , SomeExprValue $ terms `E.sqlProject` StudyTermsShorthand , SomeExprValue $ terms `E.sqlProject` StudyTermsKey ] fltrStudyTerms :: forall studyTerms t name shorthand key. ( E.SqlProject StudyTerms (Maybe StudyTermsName) studyTerms name , E.SqlProject StudyTerms (Maybe StudyTermsShorthand) studyTerms shorthand , E.SqlProject StudyTerms StudyTermsKey studyTerms key , E.SqlString name, E.SqlString shorthand, PersistField key ) => OpticFilterColumn' t (Set Text) (E.SqlExpr studyTerms) fltrStudyTerms queryTerms = singletonMap "features-terms" . FilterColumn $ anyFilter [ mkContainsFilterWith (unSqlProject' . Just) $ view queryTerms >>> (`E.sqlProject` StudyTermsName) , mkContainsFilterWith (unSqlProject' . Just) $ view queryTerms >>> (`E.sqlProject` StudyTermsShorthand) , mkExactFilterWith (fmap unSqlProject' . (readMay :: Text -> Maybe StudyTermsKey)) $ view queryTerms >>> (`E.sqlProject` StudyTermsKey) >>> E.just ] where unSqlProject' :: E.SqlProject StudyTerms value studyTerms value' => value -> value' unSqlProject' = E.unSqlProject (Proxy @StudyTerms) (Proxy @studyTerms) fltrStudyTermsUI :: DBFilterUI fltrStudyTermsUI mPrev = prismAForm (singletonFilter "features-terms") mPrev $ aopt textField (fslI MsgStudyTerm) colStudyFeaturesSemester :: OpticColonnade Int colStudyFeaturesSemester resultSemester = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge) body = views resultSemester $ cell . toWidget . toMarkup sortStudyFeaturesSemester :: forall semester. PersistField semester => OpticSortColumn semester sortStudyFeaturesSemester querySemester = singletonMap "features-semester" . SortColumn $ view querySemester fltrStudyFeaturesSemester :: forall studyFeatures t semester. ( E.SqlProject StudyFeatures Int studyFeatures semester , PersistField semester ) => OpticFilterColumn' t (Set Int) (E.SqlExpr (E.Value semester)) fltrStudyFeaturesSemester querySemester = singletonMap "features-semester" . FilterColumn . mkExactFilterWith unSqlProject' $ view querySemester where unSqlProject' :: Int -> semester unSqlProject' = E.unSqlProject (Proxy @StudyFeatures) (Proxy @studyFeatures) fltrStudyFeaturesSemesterUI :: DBFilterUI fltrStudyFeaturesSemesterUI mPrev = prismAForm (singletonFilter "features-semester" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field _ Int) (fslI MsgStudyFeatureAge) 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) ---------------------------- -- Colonnade manipulation -- ---------------------------- imapColonnade :: (a -> c -> c) -> Colonnade h a c -> Colonnade h a c -- ^ Not quite `imap` imapColonnade f (Colonnade ones) = Colonnade $ dimapColonnade' <$> ones where dimapColonnade' OneColonnade{..} = OneColonnade { oneColonnadeEncode = \x -> f x $ oneColonnadeEncode x , oneColonnadeHead } anchorColonnade :: forall h r' m a url. ( HasRoute UniWorX url , IsDBTable m a , HandlerSite m ~ UniWorX ) => (r' -> url) -> Colonnade h r' (DBCell m a) -> Colonnade h r' (DBCell m a) anchorColonnade = anchorColonnadeM . (return .) anchorColonnadeM :: forall h r' m a url. ( HasRoute UniWorX url , IsDBTable m a , HandlerSite m ~ UniWorX ) => (r' -> WidgetT UniWorX IO url) -> Colonnade h r' (DBCell m a) -> Colonnade h r' (DBCell m a) anchorColonnadeM mkUrl = imapColonnade anchorColonnade' where anchorColonnade' :: r' -> DBCell m a -> DBCell m a anchorColonnade' inp (view dbCell -> (attrs, act)) = review dbCell . (attrs,) $ view (dbCell . _2) . anchorCellM (mkUrl inp) =<< act emptyOpticColonnade :: forall h r' focus c. ( Monoid c ) => Fold r' focus -- ^ View on @focus@ within @r'@ that may produce any number of results -> ((forall focus'. Getting focus' r' focus) -> Colonnade h r' c) -- ^ `OpticColonnade focus` -> Colonnade h r' c -- ^ Generalize an `OpticColonnade` from `Getter` to `Fold` by defaulting results of zero or more than one values to `mempty` emptyOpticColonnade l c = Colonnade $ oldColonnade <&> \column -> column { oneColonnadeEncode = \s -> defaultColumn s $ oneColonnadeEncode column } where Colonnade oldColonnade = c $ singular l -- This is safe (as long as we don't evaluate the `oneColonnadeEncode`s) -- because `Getter s a` is of kind @k -> *@ and can thus only be inspected -- by @c@ through application which is precluded by the type of `Getter s a` -- and the definition of `OneColonnade` defaultColumn :: r' -> (r' -> c) -> c defaultColumn x f = case x ^.. l of [_] -> f x _ -> mempty