990 lines
47 KiB
Haskell
990 lines
47 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Utils.Table.Columns where
|
|
|
|
import Import hiding (link)
|
|
|
|
-- 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 hiding ((->.))
|
|
import qualified Database.Esqueleto.PostgreSQL.JSON as E (JSONBExpr, (->.))
|
|
import qualified Database.Esqueleto.Internal.Internal as IE
|
|
import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter)
|
|
|
|
import Handler.Utils.Table.Cells
|
|
import Handler.Utils.Table.Pagination
|
|
import Handler.Utils.Form
|
|
import Handler.Utils.Widgets
|
|
import Handler.Utils.DateTime
|
|
import Handler.Utils.StudyFeatures
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Colonnade
|
|
import Colonnade.Encode (Colonnade(..), OneColonnade(..))
|
|
|
|
import Text.Blaze (toMarkup)
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
|
|
--------------------------------
|
|
-- 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 r' sortingMap.
|
|
( IsMap sortingMap
|
|
, ContainerKey sortingMap ~ SortingKey
|
|
, MapValue sortingMap ~ SortColumn t r'
|
|
)
|
|
=> (forall focus'. Getting focus' t focus)
|
|
-> sortingMap
|
|
|
|
type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val))
|
|
|
|
type OpticFilterColumn' t inp focus
|
|
= forall r' filterMap.
|
|
( IsMap filterMap
|
|
, ContainerKey filterMap ~ FilterKey
|
|
, MapValue filterMap ~ FilterColumn t r'
|
|
, 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))
|
|
|
|
-----------
|
|
-- Terms --
|
|
-----------
|
|
|
|
colTermShort :: OpticColonnade TermId
|
|
colTermShort resultTid = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "term") (i18nCell MsgTableTerm)
|
|
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 MsgTableTerm)
|
|
|
|
-------------
|
|
-- Schools --
|
|
-------------
|
|
|
|
colSchool :: OpticColonnade SchoolId
|
|
colSchool resultSsh = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "school") (i18nCell MsgTableSchool)
|
|
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 MsgTableSchool)
|
|
|
|
-----------------
|
|
-- 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 . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAllocationActive)
|
|
|
|
|
|
-----------
|
|
-- Exams --
|
|
-----------
|
|
|
|
colExamName :: OpticColonnade ExamName
|
|
colExamName resultName = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "exam-name") (i18nCell MsgTableExamName)
|
|
body = views resultName i18nCell
|
|
|
|
sortExamName :: OpticSortColumn ExamName
|
|
sortExamName queryName = singletonMap "exam-name" . SortColumn $ view queryName
|
|
|
|
colExamTime :: OpticColonnade (Maybe UTCTime, Maybe UTCTime)
|
|
colExamTime resultTimes = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "exam-time") (i18nCell MsgTableExamTime)
|
|
body = views resultTimes $ \(eStart, eEnd)
|
|
-> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) eEnd) eStart
|
|
|
|
sortExamTime :: OpticSortColumn' (E.SqlExpr (E.Value (Maybe UTCTime)), E.SqlExpr (E.Value (Maybe UTCTime)))
|
|
sortExamTime queryTimes = singletonMap "exam-time" . SortColumns . toListOf $ queryTimes . _1 . to SomeExprValue <> queryTimes . _2 . to SomeExprValue
|
|
|
|
colExamClosed :: OpticColonnade (Maybe UTCTime)
|
|
colExamClosed resultClosed = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "exam-closed") (i18nCell MsgUtilExamClosed)
|
|
body = views resultClosed $ maybe mempty (cell . formatTimeW SelFormatDateTime)
|
|
|
|
sortExamClosed :: OpticSortColumn (Maybe UTCTime)
|
|
sortExamClosed queryClosed = singletonMap "exam-closed" . SortColumn $ view queryClosed
|
|
|
|
colExamFinished :: OpticColonnade (Maybe UTCTime)
|
|
colExamFinished resultFinished = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "exam-finished") (i18nCell MsgExamFinished)
|
|
body = views resultFinished $ maybe mempty (cell . formatTimeW SelFormatDateTime)
|
|
|
|
colExamFinishedOffice :: OpticColonnade (Maybe UTCTime)
|
|
colExamFinishedOffice resultFinished = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "exam-finished") (i18nCell MsgExamFinishedOffice)
|
|
body = views resultFinished $ maybe mempty (cell . formatTimeW SelFormatDateTime)
|
|
|
|
sortExamFinished :: OpticSortColumn (Maybe UTCTime)
|
|
sortExamFinished queryFinished = singletonMap "exam-finished" . SortColumn $ view queryFinished
|
|
|
|
---------------------
|
|
-- Exam occurences --
|
|
---------------------
|
|
|
|
colOccurrenceStart :: OpticColonnade UTCTime
|
|
colOccurrenceStart resultStart = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "occurrence-start") (i18nCell MsgExamOccurrenceStart)
|
|
body = views resultStart dateTimeCell
|
|
|
|
sortOccurrenceStart :: PersistField utctime => OpticSortColumn utctime
|
|
sortOccurrenceStart queryStart = singletonMap "occurrence-start" . SortColumn $ view queryStart
|
|
|
|
------------------
|
|
-- Exam results --
|
|
------------------
|
|
|
|
colExamResult :: OpticColonnade ExamResultPassedGrade
|
|
colExamResult resultResult = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "exam-result") (i18nCell MsgTableExamResult)
|
|
body = views resultResult i18nCell
|
|
|
|
sortExamResult :: OpticSortColumn (Maybe ExamResultPassedGrade)
|
|
sortExamResult queryResult = singletonMap "exam-result" $ SortColumn $ view queryResult
|
|
|
|
fltrExamResultPoints :: OpticFilterColumn' t (Set ExamResultPassedGrade) (E.SqlExpr (E.Value (Maybe ExamResultPassedGrade)))
|
|
fltrExamResultPoints queryExamResult = singletonMap "exam-result" . FilterColumn $ \row criteria -> if
|
|
| Set.null criteria -> E.true
|
|
| otherwise -> view queryExamResult row `E.in_` E.valList (Just <$> Set.toList criteria)
|
|
|
|
|
|
fltrExamResultPointsUI :: DBFilterUI
|
|
fltrExamResultPointsUI mPrev = prismAForm (singletonFilter "exam-result" . maybePrism _PathPiece) mPrev $ aopt (examResultPassedGradeField . Just $ SomeMessage MsgNoFilter) (fslI MsgTableExamResult)
|
|
|
|
-------------
|
|
-- Courses --
|
|
-------------
|
|
|
|
colCourseName :: OpticColonnade CourseName
|
|
colCourseName resultName = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "course-name") (i18nCell MsgTableCourse)
|
|
body = views resultName i18nCell
|
|
|
|
sortCourseName :: OpticSortColumn CourseName
|
|
sortCourseName queryName = singletonMap "course-name" . SortColumn $ view queryName
|
|
|
|
-------------------------
|
|
-- Course Applications --
|
|
-------------------------
|
|
|
|
colApplicationId :: OpticColonnade CourseApplicationId
|
|
colApplicationId resultId = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable Nothing $ i18nCell MsgCourseApplicationId
|
|
body = views resultId $ \aId -> cell $ toWidget . toMarkup =<< (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication) aId
|
|
|
|
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 . Just $ SomeMessage MsgBoolIrrelevant) (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 . Just $ SomeMessage MsgBoolIrrelevant) (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 :: (IsFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r')
|
|
sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. fileReferenceTitleField))
|
|
|
|
sortFileModification :: (IsFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r')
|
|
sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. fileReferenceModifiedField))
|
|
|
|
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)
|
|
|
|
|
|
colUserSex :: OpticColonnade (Maybe Sex)
|
|
colUserSex resultSex = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "user-sex") (i18nCell MsgTableSex)
|
|
body = views resultSex $ maybe mempty i18nCell
|
|
|
|
sortUserSex :: OpticSortColumn (Maybe Sex)
|
|
sortUserSex querySex = singletonMap "user-sex" . SortColumn $ view querySex
|
|
|
|
fltrUserSex :: OpticFilterColumn' t (Set Sex) (E.SqlExpr (E.Value (Maybe Sex)))
|
|
fltrUserSex querySex = singletonMap "user-sex" . FilterColumn $ mkExactFilterWith Just (view querySex)
|
|
|
|
fltrUserSexUI :: DBFilterUI
|
|
fltrUserSexUI mPrev = prismAForm (singletonFilter "user-sex" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler $ selectField optionsFinite :: Field _ Sex) (fslI MsgTableSex)
|
|
|
|
|
|
colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
|
colUserName = sortable (Just "user-name") (i18nCell MsgTableCourseMembers) cellHasUser
|
|
|
|
colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
|
|
colUserNameLink userLink = sortable (Just "user-name") (i18nCell MsgTableCourseMembers) (cellHasUserLink userLink)
|
|
|
|
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
|
|
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
|
|
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 r')
|
|
sortUserNameLink = sortUserName
|
|
|
|
sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
|
|
sortUserSurname queryUser = ("user-surname", SortColumn $ queryUser >>> (E.^. UserSurname))
|
|
|
|
sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
|
|
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 r')
|
|
fltrUserNameLink = fltrUserName
|
|
|
|
fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
|
=> (a -> E.SqlExpr (Entity User))
|
|
-> (d, FilterColumn t r')
|
|
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 r')
|
|
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 r')
|
|
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 r')
|
|
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 r')
|
|
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 MsgTableCourseMembers)
|
|
|
|
fltrUserNameEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
|
fltrUserNameEmailUI mPrev =
|
|
prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgTableCourseMembers)
|
|
|
|
-------------------
|
|
-- 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 MsgTableMatrikelNr) cellHasMatrikelnummer
|
|
|
|
sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
|
|
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 r')
|
|
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 MsgTableMatrikelNr)
|
|
|
|
|
|
----------------
|
|
-- User E-Mail
|
|
colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
|
colUserEmail = sortable (Just "user-email") (i18nCell MsgTableEmail) cellHasEMail
|
|
|
|
sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
|
|
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 r')
|
|
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 MsgTableEmail)
|
|
|
|
|
|
--------------------
|
|
-- Study features --
|
|
--------------------
|
|
|
|
colStudyDegree :: OpticColonnade StudyDegree
|
|
colStudyDegree resultDegree = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "features-degree") (i18nCell MsgTableStudyFeatureDegree)
|
|
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 MsgTableStudyFeatureDegree)
|
|
|
|
|
|
colStudyTerms :: OpticColonnade StudyTerms
|
|
colStudyTerms resultTerms = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "features-terms") (i18nCell MsgTableStudyTerm)
|
|
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 MsgTableStudyTerm)
|
|
|
|
|
|
colStudyFeaturesSemester :: OpticColonnade Int
|
|
colStudyFeaturesSemester resultSemester = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "features-semester") (i18nCell MsgTableStudyFeatureAge)
|
|
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 MsgTableStudyFeatureAge)
|
|
|
|
|
|
colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
|
|
colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgTableStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature
|
|
|
|
sortFeaturesSemester :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (d, SortColumn t r')
|
|
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 r')
|
|
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 MsgTableStudyFeatureAge)
|
|
|
|
|
|
colField :: (IsDBTable m c, HasStudyTerms x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
|
|
colField terms = sortable (Just "terms") (i18nCell MsgTableStudyTerm) $ maybe mempty cellHasField . firstOf terms
|
|
|
|
sortField :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (d, SortColumn t r')
|
|
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 r')
|
|
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 MsgTableStudyTerm)
|
|
|
|
|
|
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 r')
|
|
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 r')
|
|
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)
|
|
|
|
|
|
colStudyFeatures :: OpticColonnade UserTableStudyFeatures
|
|
colStudyFeatures resultFeatures = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable Nothing (i18nCell MsgColumnStudyFeatures)
|
|
body = views (resultFeatures . _UserTableStudyFeatures) . flip listCell $ \UserTableStudyFeature{..} -> cell $(widgetFile "table/cell/user-study-feature")
|
|
|
|
fltrRelevantStudyFeaturesTerms :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
|
|
fltrRelevantStudyFeaturesTerms queryTermUser = singletonMap "features-terms" . FilterColumn $ \t criterias ->
|
|
E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do
|
|
E.on $ isTermStudyFeature term studyFeatures
|
|
|
|
let (tid, uid) = t ^. queryTermUser
|
|
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid
|
|
E.&&. term E.^. TermId E.==. tid
|
|
|
|
return $ anyFilter
|
|
[ mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesField (E.^. StudyTermsName)
|
|
, mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesField (E.^. StudyTermsShorthand)
|
|
, mkExactFilterWith readMay $ \t' -> E.subSelectForeign t' StudyFeaturesField $ E.just . (E.^. StudyTermsKey)
|
|
] studyFeatures criterias
|
|
|
|
fltrRelevantStudyFeaturesTermsUI :: DBFilterUI
|
|
fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI
|
|
|
|
fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
|
|
fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias ->
|
|
E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do
|
|
E.on $ isTermStudyFeature term studyFeatures
|
|
|
|
let (tid, uid) = t ^. queryTermUser
|
|
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid
|
|
E.&&. term E.^. TermId E.==. tid
|
|
|
|
return $ anyFilter
|
|
[ mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesDegree (E.^. StudyDegreeName)
|
|
, mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesDegree (E.^. StudyDegreeShorthand)
|
|
, mkExactFilterWith readMay $ \t' -> E.subSelectForeign t' StudyFeaturesDegree $ E.just . (E.^. StudyDegreeKey)
|
|
] studyFeatures criterias
|
|
|
|
fltrRelevantStudyFeaturesDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
|
fltrRelevantStudyFeaturesDegreeUI mPrev =
|
|
prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgDegreeName)
|
|
|
|
fltrRelevantStudyFeaturesSemester :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
|
|
fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias ->
|
|
E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do
|
|
E.on $ isTermStudyFeature term studyFeatures
|
|
|
|
let (tid, uid) = t ^. queryTermUser
|
|
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid
|
|
E.&&. term E.^. TermId E.==. tid
|
|
|
|
return $ mkExactFilterWith (readMay :: Text -> Maybe Int) (E.just . (E.^. StudyFeaturesSemester)) studyFeatures criterias
|
|
|
|
fltrRelevantStudyFeaturesSemesterUI :: DBFilterUI
|
|
fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI
|
|
|
|
-----------------
|
|
-- Allocations --
|
|
-----------------
|
|
|
|
colAllocationApplied :: OpticColonnade Int
|
|
colAllocationApplied resultApplied = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "applied") (i18nCell MsgAllocationUsersApplied)
|
|
body = views resultApplied $ cell . toWidget . toMarkup
|
|
|
|
sortAllocationApplied :: forall applied. PersistField applied => OpticSortColumn applied
|
|
sortAllocationApplied queryApplied = singletonMap "applied" . SortColumn $ view queryApplied
|
|
|
|
colAllocationAssigned :: OpticColonnade Int
|
|
colAllocationAssigned resultAssigned = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "assigned") (i18nCell MsgAllocationUsersAssigned)
|
|
body = views resultAssigned $ cell . toWidget . toMarkup
|
|
|
|
sortAllocationAssigned :: forall assigned. PersistField assigned => OpticSortColumn assigned
|
|
sortAllocationAssigned queryAssigned = singletonMap "assigned" . SortColumn $ view queryAssigned
|
|
|
|
colAllocationVetoed :: OpticColonnade Int
|
|
colAllocationVetoed resultVetoed = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "vetoed") (i18nCell MsgAllocationUsersVetoed)
|
|
body = views resultVetoed $ cell . toWidget . toMarkup
|
|
|
|
sortAllocationVetoed :: forall vetoed. PersistField vetoed => OpticSortColumn vetoed
|
|
sortAllocationVetoed queryVetoed = singletonMap "vetoed" . SortColumn $ view queryVetoed
|
|
|
|
colAllocationRequested :: OpticColonnade Natural
|
|
colAllocationRequested resultRequested = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "requested") (i18nCell MsgAllocationUsersRequested)
|
|
body = views resultRequested $ cell . toWidget . toMarkup
|
|
|
|
sortAllocationRequested :: forall requested. PersistField requested => OpticSortColumn requested
|
|
sortAllocationRequested queryRequested = singletonMap "requested" . SortColumn $ view queryRequested
|
|
|
|
colAllocationPriority :: OpticColonnade AllocationPriority
|
|
colAllocationPriority resultPriority = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "priority") (i18nCell MsgAllocationUsersPriority)
|
|
body = views resultPriority $ \priority -> cell $(widgetFile "table/cell/allocation-priority")
|
|
|
|
sortAllocationPriority :: OpticSortColumn (Maybe AllocationPriority)
|
|
sortAllocationPriority queryPriority = singletonMap "priority" . SortColumns . views queryPriority . (. IE.veryUnsafeCoerceSqlExprValue) $ \prio ->
|
|
[ SomeExprValue (prio E.->. "priorities" :: E.JSONBExpr Void)
|
|
, SomeExprValue (prio E.->. "ordinal" :: E.JSONBExpr Void)
|
|
]
|
|
|
|
----------------------------
|
|
-- 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' -> WidgetFor UniWorX 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
|
|
|
|
maybeAnchorColonnade :: forall h r' m a url.
|
|
( HasRoute UniWorX url
|
|
, IsDBTable m a
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> (r' -> Maybe url)
|
|
-> Colonnade h r' (DBCell m a)
|
|
-> Colonnade h r' (DBCell m a)
|
|
maybeAnchorColonnade = maybeAnchorColonnadeM . (hoistMaybe .)
|
|
|
|
maybeAnchorColonnadeM :: forall h r' m a url.
|
|
( HasRoute UniWorX url
|
|
, IsDBTable m a
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> (r' -> MaybeT (WidgetFor UniWorX) url)
|
|
-> Colonnade h r' (DBCell m a)
|
|
-> Colonnade h r' (DBCell m a)
|
|
maybeAnchorColonnadeM mkUrl = imapColonnade anchorColonnade'
|
|
where
|
|
anchorColonnade' :: r' -> DBCell m a -> DBCell m a
|
|
anchorColonnade' inp (view dbCell -> (attrs, act)) = review dbCell . (attrs,) $
|
|
view (dbCell . _2) . maybeAnchorCellM (mkUrl inp) =<< act
|
|
|
|
emptyOpticColonnade :: forall h r' focus c.
|
|
Monoid c
|
|
=> Getting (Endo [focus]) 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 values to `mempty`
|
|
emptyOpticColonnade = emptyOpticColonnade' mempty
|
|
|
|
|
|
emptyOpticColonnade' :: forall h r' focus c.
|
|
c
|
|
-> Getting (Endo [focus]) 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 values
|
|
emptyOpticColonnade' defC l' c
|
|
= Colonnade $ oldColonnade <&> \column -> column { oneColonnadeEncode = \s -> defaultColumn s $ oneColonnadeEncode column }
|
|
where
|
|
l :: Fold r' focus
|
|
l = folding (toListOf l')
|
|
|
|
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
|
|
| has l x = f x
|
|
| otherwise = defC
|
|
|
|
maybeOpticSortColumn :: OpticSortColumn (Maybe val) -> OpticSortColumn val
|
|
maybeOpticSortColumn sortColumn = \queryFocus -> sortColumn $ queryFocus . to E.just
|