{-# 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 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 . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAllocationActive)


-----------
-- Exams --
-----------

colExamName :: OpticColonnade ExamName
colExamName resultName = Colonnade.singleton (fromSortable header) body
  where
    header = Sortable (Just "exam-name") (i18nCell MsgExamName)
    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 MsgExamTime)
    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 MsgExamClosed)
    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 MsgExamResult)
    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 MsgExamResult)

-------------
-- Courses --
-------------

colCourseName :: OpticColonnade CourseName
colCourseName resultName = Colonnade.singleton (fromSortable header) body
  where
    header = Sortable (Just "course-name") (i18nCell MsgCourse)
    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 MsgSex)
    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 MsgSex)


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 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 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 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 MsgMatrikelNr)


----------------
-- User E-Mail
colUserEmail ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserEmail = sortable (Just "user-email") (i18nCell MsgEmailTable) 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 MsgEmailTable)


--------------------
-- Study features --
--------------------

colStudyDegree :: OpticColonnade StudyDegree
colStudyDegree resultDegree = Colonnade.singleton (fromSortable header) body
  where
    header = Sortable (Just "features-degree") (i18nCell MsgStudyFeatureDegreeTable)
    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 MsgStudyFeatureDegreeTable)


colStudyTerms :: OpticColonnade StudyTerms
colStudyTerms resultTerms = Colonnade.singleton (fromSortable header) body
  where
    header = Sortable (Just "features-terms") (i18nCell MsgStudyTermTable)
    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 MsgStudyTermTable)


colStudyFeaturesSemester :: OpticColonnade Int
colStudyFeaturesSemester resultSemester = Colonnade.singleton (fromSortable header) body
  where
    header = Sortable (Just "features-semester") (i18nCell MsgStudyFeatureAgeTable)
    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 MsgStudyFeatureAgeTable)


colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgStudyFeatureAgeTable) $ 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 MsgStudyFeatureAgeTable)


colField :: (IsDBTable m c, HasStudyTerms x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
colField terms = sortable (Just "terms") (i18nCell MsgStudyTermTable) $ 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 MsgStudyTermTable)


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