-- SPDX-FileCopyrightText: 2022-24 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}


{- FOP - Frequently occurring problems using dbTable:

  - When changing a dbTable to a form, eg. using `dbSelect` then change the colonnade defnition from `dbColonnade` to `formColonnade`!
    Both functions are equal to id, but the types are quite different.

  - Don't mix up the row type alias traditionally ending with ...Data and the Action-Result-Type also ending with ...Data

-}

module Handler.Utils.Table.Pagination
  ( module Handler.Utils.Table.Pagination.Types
  , dbFilterKey
  , SomeExprValue(..)
  , SortColumn(..), SortDirection(..)
  , SortingSetting(..)
  , pattern SortAscBy, pattern SortDescBy
  , FilterColumn(..), IsFilterColumn, IsFilterColumnHandler, IsFilterProjected
  , mkFilterProjectedPost
  , DBTProjFilterPost(..)
  , DBRow(..), _dbrOutput, _dbrCount
  , DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
  , module Handler.Utils.Table.Pagination.CsvColumnExplanations
  , DBCsvActionMode(..)
  , DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
  , DBTCsvEncode(..), DBTCsvDecode(..), DBTExtraRep(..)
  , DBTProjCtx(..), _dbtProjFilter, _dbtProjRow, _dbtProjRow'
  , DBTable(..), DBFilterUI, IsDBTable(..), DBCell(..)
  , dbtProjId, dbtProjSimple
  , dbtProjFilteredPostId, dbtProjFilteredPostSimple
  , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM
  , withCsvExtraRep
  , singletonFilter, multiFilter
  , DBParams(..)
  , cellAttrs, cellContents
  , addCellClass
  , PagesizeLimit(..)
  , PaginationSettings(..), PaginationInput(..), piIsUnset
  , PSValidator(..)
  , defaultPagesize
  , defaultFilter, defaultSorting
  , restrictFilter, restrictSorting
  , forceFilter
  , ToSortable(..), Sortable(..)
  , dbTable
  , dbTableWidget, dbTableWidget'
  , dbTableDB, dbTableDB'
  , widgetColonnade, formColonnade, dbColonnade
  , cell, wgtCell, textCell, stringCell, i18nCell
  , anchorCell, anchorCell', anchorCellM, anchorCellM'
  , linkEitherCell, linkEitherCellM, linkEitherCellM'
  , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
  , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
  , cellTooltip, cellTooltips, cellTooltipIcon, cellTooltipWgt
  , listCell, listCell', listCellOf, listCellOf'
  , ilistCell, ilistCell', ilistCellOf, ilistCellOf'
  , formCell, DBFormResult(..), getDBFormResult
  , dbSelect, dbSelectIf
  , (&)
  , cap'
  , module Control.Monad.Trans.Maybe
  , module Colonnade
  , DBSTemplateMode(..)
  ) where

import Handler.Utils.Table.Pagination.Types
import Handler.Utils.Table.Pagination.CsvColumnExplanations
import Handler.Utils.Form
import Handler.Utils.Csv
import Handler.Utils.I18n
import Utils
import Utils.Lens

import Import hiding (pi)

import Data.Ratio ((%))
import qualified Data.Foldable as Foldable

import qualified Yesod.Form.Functions as Yesod

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect,unsafeSqlValue)

import qualified Network.Wai as Wai

import Control.Monad.RWS (RWST(..), execRWS, execRWST)
import Control.Monad.State (evalStateT, execStateT)
import Control.Monad.Trans.Maybe
import Control.Monad.State.Class (modify)
import qualified Control.Monad.State.Class as State

import Data.Map ((!))
import qualified Data.Map as Map

import qualified Data.Set as Set

import qualified Data.CaseInsensitive as CI

import Data.Csv (NamedRecord)

import Colonnade hiding (bool, fromMaybe, singleton)
import qualified Colonnade (singleton)
import Colonnade.Encode hiding (row)

import Text.Hamlet (hamletFile)

import Data.List (inits)

import Data.Maybe (fromJust)

import Data.Aeson.Text

import qualified Data.Text as Text

import qualified Data.Binary as B
import qualified Data.ByteArray as BA (convert)
import Crypto.MAC.HMAC (hmac, HMAC)
import Crypto.Hash.Algorithms (SHAKE256)

import qualified Data.ByteString.Base64.URL as Base64 (encode)
import qualified Data.ByteString.Lazy as LBS

import Data.Semigroup as Sem (Semigroup(..))

import qualified Data.Conduit.List as C (sourceList)
import qualified Data.Conduit.Combinators as C

import Handler.Utils.DateTime (formatTimeRangeW)
import qualified Control.Monad.Catch as Catch

import Data.Dynamic

import qualified Data.Csv as Csv

import Jobs.Queue

import Data.Typeable (eqT)


#if MIN_VERSION_base(4,11,0)
type Monoid' = Monoid
#else
type Monoid' x = (Sem.Semigroup x, Monoid x)
#endif


data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x }

instance PathPiece x => PathPiece (WithIdent x) where
  toPathPiece (WithIdent ident x)
    | not . null $ toPathPiece ident = toPathPiece ident <> "-" <> toPathPiece x
    | otherwise = toPathPiece x
  fromPathPiece txt = do
    let sep :: Text
        sep = "-"
    (ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt
    WithIdent <$> pure ident <*> fromPathPiece rest


dbFilterKey :: PathPiece dbtIdent => dbtIdent -> FilterKey -> Text
dbFilterKey ident = toPathPiece . WithIdent ident


data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }

data SortColumn t r' = forall a. PersistField a => SortColumn           { getSortColumn :: t -> E.SqlExpr (E.Value a) }
                     | forall a. PersistField a => SortColumnNullsInv   { getSortColumn :: t -> E.SqlExpr (E.Value a) }
                     | forall a. PersistField a => SortColumnNeverNull  { getSortColumn :: t -> E.SqlExpr (E.Value a) }
                     | SortColumns { getSortColumns :: t -> [SomeExprValue] }
                     | SortProjected { sortProjected :: r' -> r' -> Ordering }

data SortDirection = SortAsc | SortDesc
  deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)

instance Universe SortDirection
instance Finite SortDirection

nullaryPathPiece ''SortDirection $ camelToPathPiece' 1
pathPieceJSON ''SortDirection

sqlSortDirection :: SortColumn t r' -> Maybe (SortDirection -> t -> [E.SqlExpr E.OrderBy])
sqlSortDirection (SortColumn  e ) = Just $ \case
  SortAsc  -> pure . E.asc  . e
  SortDesc -> pure . E.desc . e
sqlSortDirection (SortColumnNullsInv e ) = Just $ \case
  SortAsc  -> pure . E.ascNullsFirst  . e
  SortDesc -> pure . E.descNullsLast . e
sqlSortDirection (SortColumnNeverNull e ) = Just $ \case
  SortAsc  -> pure . E.asc . e
  SortDesc -> pure . E.descNullsLast . e
sqlSortDirection (SortColumns es) = Just $ \case
  SortAsc  -> fmap (\(SomeExprValue v) -> E.asc  v) . es
  SortDesc -> fmap (\(SomeExprValue v) -> E.desc v) . es
sqlSortDirection _ = Nothing

sortDirectionProjected :: SortColumn t r' -> r' -> r' -> Ordering
sortDirectionProjected SortProjected{..} = sortProjected
sortDirectionProjected _                 = \_ _ -> EQ


data SortingSetting = SortingSetting
  { sortKey :: SortingKey
  , sortDir :: SortDirection
  } deriving (Eq, Ord, Show, Read, Generic)

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''SortingSetting

instance PathPiece SortingSetting where
  toPathPiece SortingSetting{..} = toPathPiece sortKey <> "-" <> toPathPiece sortDir
  fromPathPiece str = do
    let sep :: Text
        sep = "-"
    let (Text.dropEnd (Text.length sep) -> key, dir) = Text.breakOnEnd sep str
    SortingSetting <$> fromPathPiece key <*> fromPathPiece dir

pattern SortAscBy :: SortingKey -> SortingSetting
pattern SortAscBy key = SortingSetting key SortAsc

pattern SortDescBy :: SortingKey -> SortingSetting
pattern SortDescBy key = SortingSetting key SortDesc


type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeable k')
data DBRow r = forall k'. DBTableKey k' => DBRow
  { dbrKey :: k'
  , dbrOutput :: r
  , dbrCount :: Int64
  }

makeLenses_ ''DBRow

instance Functor DBRow where
  fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }

instance Foldable DBRow where
  foldMap f DBRow{..} = f dbrOutput

instance Traversable DBRow where
  traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrCount


newtype DBTProjFilterPost r' = DBTProjFilterPost { unDBTProjFilterPost :: r' -> DB Bool }

instance Default (DBTProjFilterPost r') where
  def = mempty

instance Semigroup (DBTProjFilterPost r') where
  DBTProjFilterPost f <> DBTProjFilterPost g = DBTProjFilterPost $ \r' -> f r' `and2M` g r'

instance Monoid (DBTProjFilterPost r') where
  mempty = DBTProjFilterPost . const $ return True


data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a
                       | forall a. IsFilterColumnHandler t a => FilterColumnHandler a
                       | forall a. IsFilterProjected fs a => FilterProjected a


filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
filterColumn (FilterColumn f) = Just $ filterColumn' f
filterColumn  _               = Nothing

filterColumnHandler :: FilterColumn t fs -> Maybe ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool)))
filterColumnHandler (FilterColumnHandler f) = Just $ filterColumnHandler' f
filterColumnHandler  _                 = Nothing

filterProjected :: FilterColumn t fs -> [Text] -> (fs -> fs)
filterProjected (FilterProjected f) = filterProjected' f
filterProjected  _                  = const id

mkFilterProjectedPost :: forall r' a t. IsFilterProjectedPost r' a => a -> FilterColumn t (DBTProjFilterPost r')
mkFilterProjectedPost fin = FilterProjected $ \(ts :: [Text]) -> (<> filterProjectedPost' @r' fin ts)

class IsFilterColumn t a where
  filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)

instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where
  filterColumn' fin _ _ = fin

instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
  filterColumn' cont is' t = filterColumn' (cont t) is' t

instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
  filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'

class IsFilterColumnHandler t a where
  filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool))

instance IsFilterColumnHandler t ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool))) where
  filterColumnHandler' fin args = fin args

class IsFilterProjected fs a where
  filterProjected' :: a -> [Text] -> (fs -> fs)

instance IsFilterProjected fs (fs -> fs) where
  filterProjected' fin _ = fin

instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected fs cont, MonoPointed l, Monoid l) => IsFilterProjected fs (l -> cont) where
  filterProjected' cont is' = filterProjected' (cont $ is' ^. mono' _PathPiece) is'

class IsFilterProjectedPost r' a where
  filterProjectedPost' :: a -> [Text] -> DBTProjFilterPost r'

instance IsFilterProjectedPost r' Bool where
  filterProjectedPost' fin _ = DBTProjFilterPost . const $ return fin

instance IsFilterProjectedPost r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where
  filterProjectedPost' fin _ = DBTProjFilterPost $ const fin

instance IsFilterProjectedPost r' (DBTProjFilterPost r') where
  filterProjectedPost' fin _ = fin

instance IsFilterProjectedPost r' cont => IsFilterProjectedPost r' (r' -> cont) where
  filterProjectedPost' cont is' = DBTProjFilterPost $ \r' -> let DBTProjFilterPost cont' = filterProjectedPost' (cont r') is' in cont' r'

instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjectedPost r' cont, MonoPointed l, Monoid l) => IsFilterProjectedPost r' (l -> cont) where
  filterProjectedPost' cont is' = filterProjectedPost' (cont $ is' ^. mono' _PathPiece) is'


data PagesizeLimit = PagesizeLimit !Int64 | PagesizeAll
  deriving (Eq, Ord, Read, Show, Generic)

instance Bounded PagesizeLimit where
  minBound = PagesizeLimit minBound
  maxBound = PagesizeAll

instance Enum PagesizeLimit where
  toEnum i
    | toInteger i >= fromIntegral (minBound :: Int64)
    , toInteger i <= fromIntegral (maxBound :: Int64)
    = PagesizeLimit $ fromIntegral i
    | toInteger i > fromIntegral (maxBound :: Int64)
    = PagesizeAll
    | otherwise
    = error "toEnum PagesizeLimit: out of bounds"
  fromEnum (PagesizeLimit i)
    | toInteger i >= fromIntegral (minBound :: Int)
    , toInteger i <= fromIntegral (maxBound :: Int)
    = fromIntegral i
    | otherwise
    = error "fromEnum PagesizeLimit: out of bounds"
  fromEnum PagesizeAll
    = error "fromEnum PagesizeLimit: infinite"

  succ (PagesizeLimit i)
    | i == maxBound = PagesizeAll
    | otherwise = PagesizeLimit $ succ i
  succ PagesizeAll = error "succ PagesizeLimit: out of bounds"
  pred (PagesizeLimit i)
    | i == minBound = error "pred PagesizeLimit: out of bounds"
    | otherwise = PagesizeLimit $ pred i
  pred PagesizeAll = PagesizeLimit maxBound

instance PathPiece PagesizeLimit where
  toPathPiece PagesizeAll = "all"
  toPathPiece (PagesizeLimit n) = toPathPiece n
  fromPathPiece str
    | CI.mk str == "all" = Just PagesizeAll
    | otherwise = PagesizeLimit <$> fromPathPiece str

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  , sumEncoding = UntaggedValue
  } ''PagesizeLimit


data PaginationSettings = PaginationSettings
  { psSorting      :: [SortingSetting]
  , psFilter       :: Map FilterKey [Text]
  , psLimit        :: PagesizeLimit
  , psPage         :: Int64
  }

makeLenses_ ''PaginationSettings

instance Default PaginationSettings where
  def = PaginationSettings
    { psSorting      = []
    , psFilter       = Map.empty
    , psLimit        = PagesizeLimit 50
    , psPage         = 0
    }

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''PaginationSettings

data PaginationInput = PaginationInput
  { piSorting      :: Maybe [SortingSetting]
  , piFilter       :: Maybe (Map FilterKey [Text])
  , piLimit        :: Maybe PagesizeLimit
  , piPage         :: Maybe Int64
  } deriving (Eq, Ord, Show, Read, Generic)

instance Default PaginationInput where
  def = PaginationInput
    { piSorting      = Nothing
    , piFilter       = Nothing
    , piLimit        = Nothing
    , piPage         = Nothing
    }

makeLenses_ ''PaginationInput
deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  , omitNothingFields = True
  } ''PaginationInput

piIsUnset :: PaginationInput -> Bool
piIsUnset PaginationInput{..} = and
  [ isNothing piSorting
  , isNothing piFilter
  , isNothing piLimit
  , isNothing piPage
  ]

psToPi :: PaginationSettings -> PaginationInput
psToPi PaginationSettings{..} = PaginationInput
  { piSorting = Just psSorting
  , piFilter = Just psFilter
  , piLimit = Just psLimit
  , piPage = Just psPage
  }


data DBCsvActionMode = DBCsvActionNew | DBCsvActionExisting | DBCsvActionMissing
  deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic)
instance Universe DBCsvActionMode
instance Finite DBCsvActionMode

nullaryPathPiece ''DBCsvActionMode $ camelToPathPiece' 3
deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 3
  } ''DBCsvActionMode


data ButtonCsvMode = BtnCsvExport | BtnCsvImport | BtnCsvImportConfirm | BtnCsvImportAbort
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe ButtonCsvMode
instance Finite ButtonCsvMode

embedRenderMessage ''UniWorX ''ButtonCsvMode id

nullaryPathPiece ''ButtonCsvMode $ camelToPathPiece' 1

instance Button UniWorX ButtonCsvMode where
  btnLabel BtnCsvExport
    = [whamlet|
        $newline never
        #{iconFileCSV}
        \ _{BtnCsvExport}
      |]
  btnLabel x = [whamlet|_{x}|]

  btnClasses BtnCsvImportAbort   = [BCIsButton, BCDanger]
  btnClasses BtnCsvImportConfirm = [BCIsButton, BCPrimary]
  btnClasses _                   = [BCIsButton]

  btnValidate _ BtnCsvImportAbort = False
  btnValidate _ _                 = True


data DBCsvMode
  = DBCsvNormal
  | DBCsvExport
    { dbCsvExportData :: Dynamic
    }
  | DBCsvImport
    { dbCsvFiles :: FileUploads
    }
  | DBCsvExportExample
  | DBCsvAbort

makePrisms ''DBCsvMode

data DBCsvDiff r' csv k'
  = DBCsvDiffNew
    { dbCsvNewKey :: Maybe k'
    , dbCsvNew :: csv
    }
  | DBCsvDiffExisting
    { dbCsvOldKey :: k'
    , dbCsvOld :: r'
    , dbCsvNew :: csv
    }
  | DBCsvDiffMissing
    { dbCsvOldKey :: k'
    , dbCsvOld :: r'
    }

makeLenses_ ''DBCsvDiff
makePrisms ''DBCsvDiff

data DBCsvException k'
  = DBCsvDuplicateKey
    { dbCsvDuplicateKey :: k'
    , dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB :: NamedRecord
    }
  | DBCsvException
    { dbCsvExceptionRow :: NamedRecord
    , dbCsvException :: Text
    }
  | DBCsvUnavailableActionRequested
    { dbCsvActions :: Set Value
    }
  deriving (Show)

makeLenses_ ''DBCsvException

instance (Typeable k', Show k') => Exception (DBCsvException k')


data DBTProjCtx fs r = DBTProjCtx
  { dbtProjFilter :: fs
  , dbtProjRow :: DBRow r
  }

makeLenses_ ''DBTProjCtx

_dbtProjRow' :: Lens' (DBTProjCtx () r) (DBRow r)
_dbtProjRow' = _dbtProjRow


newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }

instance Default (PSValidator m x) where
  def = PSValidator $ \DBTable{} -> \case
    Nothing -> def
    Just pi -> swap . (\act -> execRWS act pi def) $ do
      asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
      asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })

      l <- asks piLimit
      case l of
        Just (PagesizeLimit l')
          | l' <= 0   -> tell . pure $ SomeMessage MsgPSLimitNonPositive
          | otherwise -> modify $ \ps -> ps { psLimit = PagesizeLimit l' }
        Just PagesizeAll
          -> modify $ \ps -> ps { psLimit = PagesizeAll }
        Nothing -> return ()

      asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })

defaultFilter :: Map FilterKey [Text] -> PSValidator m x -> PSValidator m x
defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
  where
    injectDefault x = case x >>= piFilter of
      Just _  -> id
      Nothing -> set (_2._psFilter) psFilter

defaultSorting :: [SortingSetting] -> PSValidator m x -> PSValidator m x
defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
  where
    injectDefault x = case x >>= piSorting of
      Just prev -> _2 . _psSorting <>~ filter (\ss -> none (((==) `on` sortKey) ss) prev) psSorting
      Nothing   -> set (_2 . _psSorting) psSorting

defaultPagesize :: PagesizeLimit -> PSValidator m x -> PSValidator m x
defaultPagesize psLimit (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
  where
    injectDefault x = case x >>= piLimit of
      Just _  -> id
      Nothing -> set (_2._psLimit) psLimit

restrictFilter :: (FilterKey -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
  where
    restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }

forceFilter :: ( MonoFoldable mono
               , MonoPointed mono
               , Monoid mono
               , PathPiece (Element mono)
               )
            => FilterKey -> mono -> PSValidator m x -> PSValidator m x
forceFilter key args (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 inject $ f dbTable' ps
  where
    inject p = p { psFilter = psFilter p <> Map.singleton key (review monoPathPieces args) }

restrictSorting :: (SortingKey -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
  where
    restrict' p = p { psSorting = filter (\SortingSetting{..} -> restrict sortKey sortDir) $ psSorting p }


data DBEmptyStyle = DBESNoHeading | DBESHeading
  deriving (Enum, Bounded, Ord, Eq, Show, Read)

instance Default DBEmptyStyle where
  def = DBESHeading

data DBStyle r = DBStyle
  { dbsEmptyStyle :: DBEmptyStyle
  , dbsEmptyMessage :: (SomeMessage UniWorX)
  , dbsAttrs :: [(Text, Text)]
  , dbsFilterLayout :: Widget
                    -> Enctype
                    -> SomeRoute UniWorX
                    -> Widget
                    -> Widget
    -- ^ Filter UI, Filter Encoding, Filter action, table
  , dbsTemplate :: DBSTemplateMode r
  }

data DBSTemplateMode r = DBSTDefault { dbstmNumber :: Int64 -> Bool, dbstmShowNumber :: Int64 -> Bool }
                       | DBSTCourse
                           (Lens' r (Entity Course))           -- course
                           (Traversal' r (Entity User))        -- lecturers
                           (Lens' r Bool)                      -- isRegistered
                           (Lens' r (Entity School))           -- school
                           (Lens' r Bool)                      -- mayEditCourse

instance Default (DBStyle r) where
  def = DBStyle
    { dbsEmptyStyle = def
    , dbsEmptyMessage = (SomeMessage MsgNoTableContent)
    , dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
    , dbsFilterLayout = \_filterWgdt _filterEnctype _filterAction scrolltable ->
        [whamlet|
          $newline never
          <!-- No Filter UI -->
          ^{scrolltable}
        |]
    , dbsTemplate = DBSTDefault (>= 10) (\n -> n `mod` 5 == 0)
    }

defaultDBSFilterLayout :: Widget -- ^ Filter UI
                       -> Enctype
                       -> SomeRoute UniWorX -- ^ Filter action (target uri)
                       -> Widget -- ^ Table
                       -> Widget
defaultDBSFilterLayout filterWdgt filterEnctype filterAction scrolltable
  = $(widgetFile "table/layout-filter-default")
  where
    filterForm = wrapForm filterWdgt FormSettings
      { formMethod   = GET
      , formAction   = Just filterAction
      , formEncoding = filterEnctype
      , formAttrs    = [("class", "table-filter-form"), ("autocomplete", "off")]
      , formSubmit   = FormAutoSubmit
      , formAnchor   = Nothing :: Maybe Text
      }


singletonFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe v)
-- ^ for use with @prismAForm@
singletonFilter key = prism' fromInner (fmap Just . fromOuter)
    where
      fromInner = maybe Map.empty $ Map.singleton key . pure
      fromOuter = Map.lookup key >=> listToMaybe

multiFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe [v])
-- ^ for use with @prismAForm@
multiFilter key = prism' fromInner fromOuter
    where
      -- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v])
      fromInner = maybe Map.empty (Map.singleton key)
      fromOuter = Just . Map.lookup key

data DBTCsvEncode r' k' csv = forall exportData filename sheetName.
  ( ToNamedRecord csv, CsvColumnsExplained csv
  , DBTableKey k'
  , Typeable exportData
  , RenderMessage UniWorX filename, RenderMessage UniWorX sheetName
  ) => DBTCsvEncode
  { dbtCsvExportForm   :: AForm DB exportData
  , dbtCsvHeader       :: Maybe exportData -> DB Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error or exporting example data
  , dbtCsvExampleData  :: Maybe [csv]
  , dbtCsvDoEncode     :: exportData -> ConduitT (k', r') csv DB ()
  , dbtCsvName         :: filename
  , dbtCsvSheetName    :: sheetName
  , dbtCsvNoExportData :: Maybe (AnIso' exportData ())
  }
data DBTExtraRep r' k'
  = forall rep.
    ( HasContentType rep
    , DBTableKey k'
    ) => DBTExtraRep
    { dbtERepDoEncode :: ConduitT (k', r') Void DB rep
    }
  | forall rep.
    ( ToContent rep
    , DBTableKey k'
    ) => DBTExtraRepFor
    { dbtERepContentType :: ContentType
    , dbtERepDoEncode :: ConduitT (k', r') Void DB rep
    }
data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
  ( FromNamedRecord csv, ToNamedRecord csv
  , DBTableKey k'
  , RedirectUrl UniWorX route
  , Typeable csv
  , Ord csvAction, FromJSON csvAction, ToJSON csvAction
  , Ord csvActionClass
  , Exception csvException
  ) => DBTCsvDecode
  { dbtCsvRowKey :: csv -> MaybeT DB k'
  , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction DB ()
  , dbtCsvValidateActions :: RWST (Set csvAction) [Message] [csvAction] DB ()
  , dbtCsvClassifyAction :: csvAction -> csvActionClass
  , dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
  , dbtCsvExecuteActions :: ConduitT csvAction Void (YesodJobDB UniWorX) route
  , dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
  , dbtCsvRenderActionClass :: csvActionClass -> Widget
  , dbtCsvRenderException :: csvException -> DB Text
  }

data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar) fs.
  ( ToSortable h, Functor h
  , E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
  , PathPiece i, Eq i
  , E.From t
  , AsCornice h p r' (DBCell m x) colonnade
  , Default fs
  ) => DBTable
  { dbtSQLQuery :: t -> E.SqlQuery a
  , dbtRowKey :: t -> k                 -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
  , dbtProj :: ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
  , dbtColonnade :: colonnade
  , dbtSorting :: Map SortingKey (SortColumn t r')
  , dbtFilter :: Map FilterKey (FilterColumn t fs)
  , dbtFilterUI :: DBFilterUI
  , dbtStyle :: DBStyle r'
  , dbtParams :: DBParams m x
  , dbtCsvEncode :: Maybe (DBTCsvEncode r' k' csv)
  , dbtCsvDecode :: Maybe (DBTCsvDecode r' k' csv)
  , dbtExtraReps :: [DBTExtraRep r' k']
  , dbtIdent :: i
  }

type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text])

dbtProjId' :: forall fs r r'.
              DBRow r ~ r'
           => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjId' = view _dbtProjRow

-- | Reicht das Ergebnis der SQL-Abfrage direkt durch an colonnade und csv
dbtProjId :: forall fs r r'.
             ( fs ~ (), DBRow r ~ r' )
          => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjId = dbtProjId'

dbtProjSimple' :: forall fs r r' r''.
                  DBRow r'' ~ r'
               => (r -> DB r'')
               -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjSimple' cont = (views _dbtProjRow . set _dbrOutput) <=< (hoist lift . magnify (_dbtProjRow . _dbrOutput)) $ lift . cont =<< ask

-- | Transformation des SQL Ergbnistyp vor dem Weiterreichen an colonnade oder csv durch eine einfache monadische Funktion
dbtProjSimple :: forall fs r r' r''.
                 ( fs ~ (), DBRow r'' ~ r' )
              => (r -> DB r'')
              -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjSimple = dbtProjSimple'

withFilteredPost :: forall fs r r'.
                    fs ~ DBTProjFilterPost r'
                 => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
                 -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
withFilteredPost proj = do
  r' <- proj
  p <- views _dbtProjFilter unDBTProjFilterPost
  guardM . lift . lift $ p r'
  return r'

-- | Wie `dbtProjId` plus zusätzliches Filtern der SQL-Abfrage in Haskell
--   Nur zu Verwenden, wenn Filter mit mkFilterProjectedPost verwendet werden; ein Typfehler weist daraufhin, wenn dies nötig ist!
dbtProjFilteredPostId :: forall fs r r'.
                         ( fs ~ DBTProjFilterPost r', DBRow r ~ r' )
                      => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjFilteredPostId = withFilteredPost dbtProjId'

-- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergebniszeilen in Haskell transformieren und filtern
dbtProjFilteredPostSimple :: forall fs r r' r''.
                             ( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' )
                          => (r -> DB r'')
                          -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjFilteredPostSimple = withFilteredPost . dbtProjSimple'


noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
noCsvEncode = Nothing

simpleCsvEncode :: forall filename sheetName r' k' csv.
                   ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
                   , DBTableKey k'
                   , RenderMessage UniWorX filename, RenderMessage UniWorX sheetName
                   )
                => filename -> sheetName -> (r' -> csv) -> Maybe (DBTCsvEncode r' k' csv)
simpleCsvEncode fName sName f = Just DBTCsvEncode
  { dbtCsvExportForm   = pure ()
  , dbtCsvDoEncode     = \() -> C.map (f . view _2)
  , dbtCsvName         = fName
  , dbtCsvSheetName    = sName
  , dbtCsvNoExportData = Just id
  , dbtCsvHeader       = const . return $ headerOrder (error "headerOrder" :: csv)
  , dbtCsvExampleData  = Nothing
  }

simpleCsvEncodeM :: forall filename sheetName r' k' csv.
                    ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
                    , DBTableKey k'
                    , RenderMessage UniWorX filename, RenderMessage UniWorX sheetName
                    )
                 => filename -> sheetName -> ReaderT r' DB csv -> Maybe (DBTCsvEncode r' k' csv)
simpleCsvEncodeM fName sName f = Just DBTCsvEncode
  { dbtCsvExportForm   = pure ()
  , dbtCsvDoEncode     = \() -> C.mapM (runReaderT f . view _2)
  , dbtCsvName         = fName
  , dbtCsvSheetName    = sName
  , dbtCsvNoExportData = Just id
  , dbtCsvHeader       = const . return $ headerOrder (error "headerOrder" :: csv)
  , dbtCsvExampleData  = Nothing
  }

withCsvExtraRep :: forall exportData csv sheetName r' k'.
                   ( Typeable exportData
                   , RenderMessage UniWorX sheetName
                   )
                => sheetName
                -> exportData
                -> Maybe (DBTCsvEncode r' k' csv)
                -> [DBTExtraRep r' k'] -> [DBTExtraRep r' k']
withCsvExtraRep sheetName exportData mEncode = maybe id (flip snoc) (csvExtraRep FormatCsv)
                                             . maybe id (flip snoc) (csvExtraRep FormatXlsx)
  where
    csvExtraRep fmt = do
      DBTCsvEncode{ dbtCsvNoExportData = (_ :: Maybe (AnIso' exportData' ())), .. } <- mEncode
      Refl <- eqT @exportData @exportData'
      return DBTExtraRepFor
        { dbtERepContentType = case fmt of
            FormatCsv -> typeCsv'
            FormatXlsx -> typeXlsx
        , dbtERepDoEncode = do
            csvRendered <- toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[]))
            encOpts <- csvOptionsForFormat fmt
            csvRenderedToTypedContentWith encOpts sheetName csvRendered
        }


class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: Type -> Type) (x :: Type) where
  data DBParams m x :: Type
  type DBResult m x :: Type
  -- type DBResult' m x :: Type

  data DBCell m x :: Type
  dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)

  -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
  -- | Format @DBTable@ when sort-circuiting
  dbWidget   :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> DBResult m x -> m' Widget
  -- | Format @DBTable@ when not short-circuiting
  dbHandler  :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
  runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable m x -> PaginationInput -> [k'] -> m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)

  dbInvalidateResult :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBParams m x -> DBTableInvalid -> DBResult m x -> m' (DBResult m x)
  dbInvalidateResult _ _ = return

cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
cellAttrs = dbCell . _1

cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
cellContents = dbCell . _2

addCellClass :: (IsDBTable m x, PathPiece t) => t -> DBCell m x -> DBCell m x
addCellClass = over cellAttrs . Yesod.addClass . toPathPiece

instance Monoid' x => IsDBTable (HandlerFor UniWorX) x where
  data DBParams (HandlerFor UniWorX) x = DBParamsWidget
  type DBResult (HandlerFor UniWorX) x = (x, Widget)
  -- type DBResult' (WidgetFor UniWorX) () = ()

  data DBCell (HandlerFor UniWorX) x = WidgetCell
    { wgtCellAttrs :: [(Text, Text)]
    , wgtCellContents :: WriterT x (HandlerFor UniWorX) Widget
    }

  dbCell = iso
    (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
    (uncurry WidgetCell)

  -- dbWidget Proxy Proxy = iso (, ()) $ view _1
  dbWidget _ _ = return . snd
  dbHandler _ _ f = return . over _2 f
  runDBTable _ _ _ = liftHandler

instance Monoid' x => Sem.Semigroup (DBCell (HandlerFor UniWorX) x) where
  (WidgetCell a c) <> (WidgetCell a' c') = WidgetCell (a <> a') ((<>) <$> c <*> c')

instance Monoid' x => Monoid (DBCell (HandlerFor UniWorX) x) where
  mempty = WidgetCell mempty $ return mempty
  mappend = (<>)

instance Default (DBParams (HandlerFor UniWorX) x) where
  def = DBParamsWidget

instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerFor UniWorX)) x where
  data DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBParamsDB
  type DBResult (ReaderT SqlBackend (HandlerFor UniWorX)) x = (x, Widget)

  data DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x = DBCell
    { dbCellAttrs :: [(Text, Text)]
    , dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerFor UniWorX)) Widget
    }

  dbCell = iso
    (\DBCell{..} -> (dbCellAttrs, dbCellContents))
    (uncurry DBCell)

  dbWidget _ _ = return . snd
  dbHandler _ _ f = return . over _2 f
  -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerFor UniWorX) ((), Widget) -> m (Widget)
  runDBTable _ _ _ = mapReaderT liftHandler

instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
  (DBCell a c) <> (DBCell a' c') = DBCell (a <> a') ((<>) <$> c <*> c')

instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
  mempty = DBCell mempty $ return mempty
  mappend = (<>)

instance Default (DBParams (ReaderT SqlBackend (HandlerFor UniWorX)) x) where
  def = DBParamsDB

data DBParamsFormIdent where
  DBParamsFormTableIdent :: DBParamsFormIdent
  DBParamsFormOverrideIdent :: forall t. PathPiece t => t -> DBParamsFormIdent
  DBParamsFormNoIdent :: DBParamsFormIdent

instance Default DBParamsFormIdent where
  def = DBParamsFormTableIdent

unDBParamsFormIdent :: DBTable m x -> DBParamsFormIdent -> Maybe Text
unDBParamsFormIdent DBTable{dbtIdent}  DBParamsFormTableIdent       = Just $ toPathPiece dbtIdent
unDBParamsFormIdent _                 (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
unDBParamsFormIdent _                  DBParamsFormNoIdent          = Nothing

instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x where
  data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = forall a. DBParamsForm
    { dbParamsFormMethod     :: StdMethod
    , dbParamsFormAction     :: Maybe (SomeRoute UniWorX)
    , dbParamsFormAttrs      :: [(Text, Text)]
    , dbParamsFormSubmit     :: FormSubmitType
    , dbParamsFormAdditional :: Form a
    , dbParamsFormEvaluate   :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerFor UniWorX) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
    , dbParamsFormResult     :: Lens' x (FormResult a)
    , dbParamsFormIdent      :: DBParamsFormIdent
    }
  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = (x, Widget)
  -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a) = (FormResult a, Enctype)

  data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x = forall a. FormCell
    { formCellAttrs :: [(Text, Text)]
    , formCellContents :: WriterT x (MForm (HandlerFor UniWorX)) (FormResult a, Widget)
    , formCellLens :: Lens' x (FormResult a)
    }

  -- dbCell :: Iso'
  --             (DBCell (RWST ... ... ... (HandlerFor UniWorX)) x)
  --             ([(Text, Text)], WriterT x (RWST ... ... ... (HandlerFor UniWorX)) Widget)
  dbCell = iso
    (\FormCell{..} -> (formCellAttrs, formCellContents >>= uncurry ($>) . over _1 (tell . (flip $ set formCellLens) mempty)))
    (\(attrs, mkWidget) -> FormCell attrs ((pure (), ) <$> mkWidget) $ lens (\_ -> pure ()) (\s _ -> s))

  -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
  --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
  dbWidget _ _ = return . snd
  dbHandler _ _ f = return . over _2 f
  -- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerFor UniWorX)) x -> PaginationInput -> [k'] -> (MForm (HandlerFor UniWorX)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
  runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys
    = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1)
    . dbParamsFormEvaluate
    . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x)))
    . maybe id (identifyForm' dbParamsFormResult) (unDBParamsFormIdent dbtable dbParamsFormIdent)
    . dbParamsFormWrap dbtable dbtParams
    . addPIHiddenField dbtable pi
    . addPreviousHiddenField dbtable pKeys
    . withFragment

  dbInvalidateResult DBParamsForm{..} reason result = do
    reasonTxt <- getMessageRender <*> pure reason
    let
      adjResult (FormFailure errs) = FormFailure $ reasonTxt : errs
      adjResult _                  = FormFailure $ pure reasonTxt
    return $ over (_1 . dbParamsFormResult) adjResult result

instance Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
  def = DBParamsForm
    { dbParamsFormMethod     = POST
    , dbParamsFormAction     = Nothing -- Recall: Nothing preserves GET Parameters
    , dbParamsFormAttrs      = []
    , dbParamsFormSubmit     = FormSubmit
    , dbParamsFormAdditional = \_ -> return (pure (), mempty)
    , dbParamsFormEvaluate   = liftHandler . runFormPost
    , dbParamsFormResult     = lens (\_ -> pure ()) (\s _ -> s)
    , dbParamsFormIdent      = def
    }

dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerFor UniWorX)) x -> DBParams (MForm (HandlerFor UniWorX)) x -> (Html -> MForm (HandlerFor UniWorX) (x, Widget)) -> (Html -> MForm (HandlerFor UniWorX) (x, Widget))
dbParamsFormWrap DBTable{ dbtIdent } DBParamsForm{..} tableForm frag = do
  let form = mappend <$> tableForm frag <*> (fmap (over _1 $ (flip $ set dbParamsFormResult) mempty) $ dbParamsFormAdditional mempty)
  ((res, fWidget), enctype) <- listen form
  return . (res,) $ wrapForm fWidget FormSettings
    { formMethod   = dbParamsFormMethod
    , formAction   = dbParamsFormAction
    , formEncoding = enctype
    , formAttrs    = dbParamsFormAttrs
    , formSubmit   = dbParamsFormSubmit
    , formAnchor   = Just $ WithIdent dbtIdent ("form" :: Text)
    }


addPIHiddenField :: DBTable m' x -> PaginationInput -> (Html -> MForm m a) -> (Html -> MForm m a)
addPIHiddenField DBTable{ dbtIdent } pi form fragment
  = form $ fragment <> [shamlet|
      $newline never
      <input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
    |]
  where
    wIdent :: Text -> Text
    wIdent = toPathPiece . WithIdent dbtIdent

addPreviousHiddenField :: (ToJSON k', MonadHandler m, HandlerSite m ~ UniWorX) => DBTable m' x -> [k'] -> (Html -> MForm m a) -> (Html -> MForm m a)
addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
  encrypted <- liftHandler $ encodedSecretBox SecretBoxShort pKeys
  form $ fragment <> [shamlet|
    $newline never
    <input type=hidden name=#{wIdent "previous"} value=#{encrypted}>
  |]
  where
    wIdent :: Text -> Text
    wIdent = toPathPiece . WithIdent dbtIdent

instance Monoid' x => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
  (FormCell attrs c l) <> (FormCell attrs' c' l') = FormCell (attrs <> attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', w <> w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))

instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) x) where
  mempty = FormCell mempty (return mempty) $ lens (\_ -> pure ()) (\s _ -> s)
  mappend = (<>)

instance IsDBTable m a => IsString (DBCell m a) where
  fromString = cell . fromString


-- | DB-backed tables with pagination, may short-circuit a handler if the frontend only asks for the table content, i.e. handler actions after calls to dbTable may not happen at all.
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
  doSorting <- or2M
    (getsYesod . views _appBotMitigations $ Set.notMember SettingBotMitigationOnlyLoggedInTableSorting)
    (is _Just <$> maybeAuthId)

  let
    sortingOptions = mkOptionList
      [ Option t' (SortingSetting t d) t'
      | (t, _) <- mapToList dbtSorting
      , d <- [SortAsc, SortDesc]
      , let t' = toPathPiece $ SortingSetting t d
      ]
    wIdent :: Text -> Text
    wIdent = toPathPiece . WithIdent dbtIdent
    dbsAttrs'
      | not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
      | otherwise           = dbsAttrs
    multiTextField :: forall m'. Applicative m' => Field m' [Text]
    multiTextField = Field
      { fieldParse = \ts _ -> pure . Right $ Just ts
      , fieldView = error "multiTextField: should not be rendered"
      , fieldEnctype = UrlEncoded
      }

  piPreviousPost <- lift . runInputPost $ iopt (jsonField JsonFieldHidden) (wIdent "pagination")
  piPreviousGet  <- lift . runInputGet  $ iopt (jsonField JsonFieldHidden) (wIdent "pagination")
  let
    piPreviousRes = maybe FormMissing FormSuccess $ piPreviousPost <|> piPreviousGet
  $logDebugS "dbTable" [st|#{wIdent "pagination"}: #{tshow piPreviousRes}|]

  previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")

  piInput <- lift . runInputGetResult $ PaginationInput
    <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
    <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField $ dbFilterKey dbtIdent' k) dbtFilter)
    <*> iopt pathPieceField (wIdent "pagesize")
    <*> iopt intField (wIdent "page")

  let prevPi
        = views _2 psToPi . runPSValidator dbtable . formResultToMaybe $ piPreviousRes <|> piInput

      referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi

  (((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
    (filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm (FIDDBTableFilter dbtIdent) . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)

    (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm (FIDDBTablePagesize dbtIdent) . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
          areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addName (wIdent "pagesize") & addClass ("select--pagesize" :: Text)) (Just referencePagesize)
    return (filterRes', pagesizeRes')

  let
    piResult = (prevPi &) . (_piFilter ?~) <$> filterRes
           <|> (prevPi &) . (_piLimit ?~) <$> pagesizeRes
           <|> piPreviousRes
           <|> piInput

  psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit

  let
    -- adjustPI = over _piSorting $ guardOnM doSorting -- probably not neccessary; not displaying the links should be enough for now
    ((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
      | FormSuccess pi <- piResult
      , not $ piIsUnset pi
      = (, pi) . runPSValidator dbtable $ Just pi
      | FormFailure errs' <- piResult
      = (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
      | otherwise
      = (, def) $ runPSValidator dbtable Nothing
    psSorting' = map (\SortingSetting{..} -> (Map.findWithDefault (error $ "Invalid sorting key: " <> show sortKey) sortKey dbtSorting, sortDir)) psSorting

  forM_ errs $ \err -> do
    mr <- getMessageRender
    $logDebugS "dbTable paginationSettings" $ mr err
    addMessageI Warning err

  currentRoute <- fromMaybe (error "dbTable called from 404-handler") <$> getCurrentRoute
  getParams <- liftHandler $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
  let
    tblLink :: (QueryText -> QueryText) -> SomeRoute UniWorX
    tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing . setParam (toPathPiece PostFormIdentifier) Nothing) getParams
    substPi = foldr (.) id
      [ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
      , foldr (.) id . map (\k -> setParams (dbFilterKey dbtIdent' k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
      , setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
      , setParam (wIdent "page") $ fmap toPathPiece piPage
      , setParam (wIdent "pagination") Nothing
      ]
    tblLink' :: (QueryText -> QueryText) -> Widget
    tblLink' = toWidget <=< toTextUrl . tblLink

  let noExportData
        | Just DBTCsvEncode{..} <- dbtCsvEncode
        = is _Just dbtCsvNoExportData
        | otherwise
        = True

  ((csvExportRes, csvExportWdgt), csvExportEnctype) <- bool runFormPost runFormGet noExportData . addPIHiddenField dbtable paginationInput . identifyForm (FIDDBTableCsvExport dbtIdent) . renderAForm FormDBTableCsvExport . fmap DBCsvExport $ case dbtCsvEncode of
    Just DBTCsvEncode{..}
      | Just (cloneIso -> noExportData') <- dbtCsvNoExportData
        -> toDyn . view (noExportData' . from noExportData') <$> dbtCsvExportForm
      | otherwise
        -> toDyn <$> dbtCsvExportForm
    Nothing
        -> pure $ toDyn ()
  let importButtons prevRes = do
        isReImport <- hasGlobalPostParamForm PostDBCsvReImport
        if | is _FormSuccess prevRes || isReImport
             -> return [BtnCsvImport, BtnCsvImportAbort]
           | otherwise
             -> return [BtnCsvImport]
      handleBtnAbort _ (FormSuccess BtnCsvImportAbort) = pure DBCsvAbort
      handleBtnAbort x btn = x <* btn
  ((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . withGlobalPostParam PostDBCsvReImport () . withButtonFormCombM' handleBtnAbort importButtons . identifyForm (FIDDBTableCsvImport dbtIdent) . renderAForm FormDBTableCsvImport $ DBCsvImport
    <$> areq fileFieldMultiple (fslI MsgCsvFile) Nothing
  exportExampleRes <- guardOn <$> hasGlobalGetParam GetCsvExampleData <*> pure DBCsvExportExample

  let
    csvMode = asum
      [ maybe FormMissing FormSuccess exportExampleRes
      , csvExportRes <* guard (is _Just dbtCsvEncode)
      , csvImportRes <* guard (is _Just dbtCsvDecode)
      , FormSuccess DBCsvNormal
      ]
    csvExportWdgt' = wrapForm' BtnCsvExport csvExportWdgt FormSettings
      { formMethod = bool POST GET noExportData
      , formAction = Just $ tblLink id
      , formEncoding = csvExportEnctype
      , formAttrs = []
      , formSubmit = FormSubmit
      , formAnchor = Just $ wIdent "csv-export"
      }
    csvImportWdgt' = wrapForm csvImportWdgt FormSettings
      { formMethod = POST
      , formAction = Just $ tblLink id
      , formEncoding = csvImportEnctype
      , formAttrs = []
      , formSubmit = FormNoSubmit
      , formAnchor = Just $ wIdent "csv-import"
      }
    csvImportExplanation :: Widget
    csvImportExplanation = modal [whamlet|_{MsgCsvImportExplanationLabel}|] $ Right $(i18nWidgetFile "table/csv-import-explanation")
    csvColExplanations = case dbtCsvEncode of
      Just (DBTCsvEncode{} :: DBTCsvEncode r' k' csv) -> assertM' (not . null) . Map.toList . csvColumnsExplanations $ Proxy @csv
      Nothing -> Nothing
    csvColExplanations' = case csvColExplanations of
      Just csvColExplanations'' -> modal [whamlet|_{MsgCsvColumnsExplanationsLabel}|] $ Right $(widgetFile "table/csv-column-explanations")
      Nothing -> mempty

    psFilter' = imap (\key args -> (, args) $ Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) psFilter

    primarySortSql = flip has psSorting' $ _head . _1 . to sqlSortDirection . _Just

    sortSql :: _ -> [E.SqlExpr E.OrderBy]
    sortSql t = concatMap (\(f, d) -> f d t) $ mapMaybe (\(c, d) -> (, d) <$> sqlSortDirection c) psSorting'

    filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool)))          -- could there be any reason not to remove Nothing values from the map already here?
    filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter'

    -- selectPagesize = primarySortSql
    --               && all (is _Just) filterSql

    -- psLimit' = bool PagesizeAll psLimit selectPagesize

  filterHandler <- case csvMode of
    FormSuccess DBCsvImport{} -> return mempty -- don't execute Handler actions for unneeded filters upon csv _import_
    _other -> liftHandler $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnHandler fc

  rows' <- E.select . E.from $ \t -> do
    res <- dbtSQLQuery t
    E.orderBy $ sortSql t
    case csvMode of
      -- FormSuccess DBCsvExport{} -> return ()
      FormSuccess DBCsvImport{} -> return () -- don't apply filter and sorting for csv _import_; we expect all rows to be available for matching with provided csv
      _other -> do
        case previousKeys of
          Nothing
            | PagesizeLimit l <- psLimit
            -- , selectPagesize
            , hasn't (_FormSuccess . _DBCsvExport) csvMode
              -> do
                   E.limit l
                   E.offset $ psPage * l
          Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps              -- Note that multiple where_ are indeed concatenated
          _other  -> return ()
        let filterAppT = Map.foldr (\fc expr -> maybe expr ((: expr) . ($ t)) fc) []
            sqlFilters = filterAppT filterHandler <> filterAppT filterSql  -- Note that <> on the maps won't work as intended, since keys are present in both
        unless (null sqlFilters) $ E.where_ $ E.and sqlFilters
    return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)

  let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v
      firstRow :: Int64
      firstRow
        | PagesizeLimit l <- psLimit
        = succ (psPage * l)
        | otherwise
        = 1
      reproduceSorting
        | Just ps <- previousKeys
        = sortOn $ \(_, dbrKey, _) -> elemIndex dbrKey ps
        | otherwise
        = id

      dbtProjFilter = ala Endo foldMap (psFilter' <&> \(f, args) -> filterProjected f args) def

      sortProjected
        | is _Just previousKeys
        = id
        | primarySortSql
        = id
        | otherwise
        = sortBy $ concatMap (\(c, d) (_, r) (_, r') -> adjustOrder d $ sortDirectionProjected c r r') psSorting'
        where
          adjustOrder SortAsc  x  = x
          adjustOrder SortDesc LT = GT
          adjustOrder SortDesc EQ = EQ
          adjustOrder SortDesc GT = LT

  (currentKeys, rows) <- fmap (unzip . sortProjected) . mapMaybeM' (\dbtProjRow -> runReaderT dbtProj DBTProjCtx{..}) . map (\(E.Value dbrCount, dbrKey, dbrOutput) -> (dbrKey, DBRow{..})) $ reproduceSorting rows'

  csvExample <- runMaybeT $ do
    DBTCsvEncode{..} <- hoistMaybe dbtCsvEncode
    exData <- hoistMaybe dbtCsvExampleData
    hdr <- lift $ dbtCsvHeader Nothing
    exportUrl <- toTextUrl (currentRoute, [(toPathPiece GetCsvExampleData, "")])
    return $(widgetFile "table/csv-example")

  formResult csvMode $ \case
    DBCsvAbort{} -> do
      addMessageI Info MsgCsvImportAborted
      redirect $ tblLink id
    DBCsvExportExample{}
      | Just DBTCsvEncode{..} <- dbtCsvEncode
      , Just exData <- dbtCsvExampleData -> do
        hdr <- dbtCsvHeader Nothing
        setContentDispositionCsv dbtCsvName
        sendResponse <=< liftHandler . respondCsv dbtCsvSheetName hdr $ C.sourceList exData
    DBCsvExport{..}
      | Just DBTCsvEncode{..} <- dbtCsvEncode
      , Just exportData <- fromDynamic dbCsvExportData -> do
        hdr <- dbtCsvHeader $ Just exportData
        setContentDispositionCsv dbtCsvName
        sendResponse <=< liftHandler . respondCsvDB dbtCsvSheetName hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
    DBCsvImport{..}
      | Just DBTCsvEncode{..} <- dbtCsvEncode
      , Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
                          , ..
                          } :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do
        let existing = Map.fromList $ zip currentKeys rows
            sourceDiff :: ConduitT () (DBCsvDiff r' csv k') (StateT (Map k' csv) DB) ()
            sourceDiff = do
              let
                toDiff :: csv -> StateT (Map k' csv) DB (DBCsvDiff r' csv k')
                toDiff row = do
                  rowKey <- lift $
                    handle (throwM . (DBCsvException (toNamedRecord row) :: Text -> DBCsvException k') <=< dbtCsvRenderException) . runMaybeT $ dbtCsvRowKey row
                  seenKeys <- State.get
                  (<* modify (maybe id (flip Map.insert row) rowKey)) $ if
                    | Just rowKey' <- rowKey
                    , Just oldRow <- Map.lookup rowKey' seenKeys
                      -> throwM $ DBCsvDuplicateKey rowKey' (toNamedRecord oldRow) (toNamedRecord row)
                    | Just rowKey' <- rowKey
                    , Just oldRow <- Map.lookup rowKey' existing
                      -> return $ DBCsvDiffExisting rowKey' oldRow row
                    | otherwise
                      -> return $ DBCsvDiffNew rowKey row
              transPipe liftHandler dbCsvFiles .| fileSourceCsv .| C.mapM toDiff

              seen <- State.get
              forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if
                | Map.member rowKey seen -> return ()
                | otherwise -> yield $ DBCsvDiffMissing rowKey oldRow

            accActionMap :: Map csvActionClass (Set csvAction) -> csvAction -> Map csvActionClass (Set csvAction)
            accActionMap acc csvAct = Map.insertWith Set.union (dbtCsvClassifyAction csvAct) (Set.singleton csvAct) acc

            importCsv = do
              let
                dbtCsvComputeActions' :: ConduitT (DBCsvDiff r' csv k') Void DB (Map csvActionClass (Set csvAction))
                dbtCsvComputeActions' = do
                  let innerAct = awaitForever $ \x
                        -> let doHandle
                                 | Just inpCsv <- x ^? _dbCsvNew
                                 = handle $ throwM . (DBCsvException (toNamedRecord inpCsv) :: Text -> DBCsvException k') <=< dbtCsvRenderException
                                 | otherwise
                                 = id
                            in C.sourceList <=< lift . doHandle . runConduit $ dbtCsvComputeActions x .| C.foldMap pure
                  innerAct .| C.foldl accActionMap Map.empty
              actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift dbtCsvComputeActions'

              when (Map.null actionMap) $ do
                addMessageI Info MsgCsvImportUnnecessary
                redirect $ tblLink id

              E.transactionSave -- If dbtCsvComputeActions has side-effects, commit those

              liftHandler . (>>= sendResponse) $
                siteLayoutMsg MsgCsvImportConfirmationHeading $ do
                  setTitleI MsgCsvImportConfirmationHeading

                  let
                    precomputeIdents :: forall f m'. (Eq (Element f), MonoFoldable f, MonadHandler m') => f -> m' (Element f -> Text)
                    precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed")
                  actionClassIdent <- precomputeIdents $ Map.keys actionMap
                  actionIdent <- precomputeIdents . Set.unions $ Map.elems actionMap

                  let defaultChecked actClass = case dbtCsvCoarsenActionClass actClass of
                        DBCsvActionMissing -> False
                        _other             -> True
                      csvActionCheckBox :: [(Text, Text)] -> csvAction -> Widget
                      csvActionCheckBox vAttrs act = do
                        let
                          sJsonField :: Field (HandlerFor UniWorX) csvAction
                          sJsonField = secretJsonField' $ \theId name attrs val _isReq ->
                            [whamlet|
                              $newline never
                              <input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} :defaultChecked (dbtCsvClassifyAction act):checked>
                            |]
                        fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False
                      availableActs :: Widget
                      availableActs = fieldView (secretJsonField :: Field Handler (Set csvAction)) "" (toPathPiece PostDBCsvImportAvailableActions) [] (Right . Set.unions $ Map.elems actionMap) False
                  (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
                  let csvImportConfirmForm = wrapForm csvImportConfirmForm' FormSettings
                        { formMethod = POST
                        , formAction = Just $ tblLink id
                        , formEncoding = csvImportConfirmEnctype
                        , formAttrs = []
                        , formSubmit = FormNoSubmit
                        , formAnchor = Nothing :: Maybe Text
                        }

                  $(widgetFile "csv-import-confirmation-wrapper")

            csvReImport = $(widgetFile "table/csv-reimport")

        hdr <- dbtCsvHeader Nothing
        catches importCsv
          [ Catch.Handler $ \case
              (DBCsvDuplicateKey{..} :: DBCsvException k')
                -> liftHandler $ sendResponseStatus badRequest400 =<< do
                     mr <- getMessageRender

                     let offendingCsv = CsvRendered hdr [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ]
                         heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvDuplicateKey]

                     siteLayoutMsg heading $ do
                       setTitleI heading
                       [whamlet|
                         $newline never
                         <section>
                           <p>_{MsgDBCsvDuplicateKey}
                           <p>_{MsgDBCsvDuplicateKeyTip}
                           ^{offendingCsv}
                         <section>
                           ^{csvReImport}
                       |]
              (DBCsvException{..} :: DBCsvException k')
                -> liftHandler $ sendResponseStatus badRequest400 =<< do
                     mr <- getMessageRender

                     let offendingCsv = CsvRendered hdr [ dbCsvExceptionRow ]
                         heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvException]

                     siteLayoutMsg heading $ do
                       setTitleI heading
                       [whamlet|
                         $newline never
                         <section>
                           <p>_{MsgDBCsvException}
                           $if not (Text.null dbCsvException)
                             <p>#{dbCsvException}
                           ^{offendingCsv}
                         <section>
                           ^{csvReImport}
                       |]
              other -> throwM other
          , Catch.Handler $ \(csvParseError :: CsvParseError)
              -> liftHandler $ sendResponseStatus badRequest400 =<< do
                   mr <- getMessageRender

                   let heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvParseError]

                   siteLayoutMsg heading $ do
                     setTitleI heading
                     [whamlet|
                       $newline never
                       <section>
                         <p>_{MsgDBCsvParseErrorTip}
                         <pre .csv-parse-error>
                           $case csvParseError
                             $of CsvParseError _ errMsg
                               #{errMsg}
                             $of IncrementalError errMsg
                               #{errMsg}
                       <section>
                         ^{csvReImport}
                     |]
          ]
    _other      -> return ()

  let extraReps = maybe id ($) addCSVReps dbtExtraReps
        where addCSVReps = do
                DBTCsvEncode{..} <- dbtCsvEncode
                noExportData' <- cloneIso <$> dbtCsvNoExportData
                let exportData = noExportData' # ()
                return $ withCsvExtraRep dbtCsvSheetName exportData dbtCsvEncode
      extraRepContentType = \case
        DBTExtraRep{..} -> getContentType dbtERepDoEncode
        DBTExtraRepFor{..} -> dbtERepContentType
      extraReps' = (typeHtml, Nothing) : map ((,) <$> extraRepContentType <*> Just) extraReps
      doAltRep = maybe True (== dbtIdent) <$> lookupGlobalGetParam GetSelectTable

  maybeT (return ()) $ do
    guardM doAltRep

    cts <- reqAccept <$> getRequest

    altRep <- hoistMaybe <=< asum $ do
      mRep <- hoistMaybe . selectRep' extraReps' =<< cts
      return . return $ mRep <&> \case
        DBTExtraRep{..} -> fmap toTypedContent . runConduit $ C.sourceList (zip currentKeys rows) .| dbtERepDoEncode
        DBTExtraRepFor{..} -> fmap (TypedContent dbtERepContentType . toContent) . runConduit $ C.sourceList (zip currentKeys rows) .| dbtERepDoEncode

    lift $ sendResponse =<< altRep

  let
    rowCount = fromMaybe 0 $ rows' ^? _head . _1 . _Value
      --    | selectPagesize = fromMaybe 0 $ rows' ^? _head . _1 . _Value
      --    | otherwise = olength64 rows

    rawAction = tblLink
      $ setParam (wIdent "sorting") Nothing
      . setParam (wIdent "pagesize") Nothing
      . setParam (wIdent "page") Nothing
      . setParam (wIdent "pagination") Nothing

    table' :: WriterT x m Widget
    table' = let
        columnCount :: Int64
        columnCount = olength64 . getColonnade . discard $ dbtColonnade ^. _Cornice

        numberColumn = case dbsTemplate of
          DBSTDefault{..} -> dbstmNumber rowCount
          _other -> False

        genHeaders :: forall h. Cornice h _ _ (DBCell m x) -> SortableP h -> WriterT x m Widget
        genHeaders cornice SortableP{..} = fmap wrap' . execWriterT . go mempty $ annotate cornice
          where
            go :: forall (p' :: Pillar) r'.
                  [(Int, Int, Int)]
               -> AnnotatedCornice (Maybe Int) h p' r' (DBCell m x)
               -> WriterT (Seq (Seq (Widget, Int))) (WriterT x m) ()
            go rowspanAcc (AnnotatedCorniceBase _ (Colonnade (toList -> v))) = mapWriterT (over (mapped . _2) pure) . forM_ (zip (inits v) v) $ \(before, OneColonnade Sized{..} _) -> do
              let (_, cellSize') = compCellSize rowspanAcc (map oneColonnadeHead before) Sized{..}
              whenIsJust cellSize' $ \cellSize -> tellM . fmap pure $ fromContent Sized { sizedSize = cellSize, sizedContent }
            go rowspanAcc (AnnotatedCorniceCap _ v@(toList -> oneCornices)) = do
              rowspanAcc' <- (execStateT ?? rowspanAcc) . hoist (mapWriterT $ over (mapped . _2) pure) . forM_ (zip (inits oneCornices) oneCornices) $ \(before, OneCornice h (size -> sz')) -> do
                let sz = Sized sz' h
                let (beforeSize, cellSize') = compCellSize rowspanAcc (concatMap (map oneColonnadeHead . toList . getColonnade . uncapAnnotated . oneCorniceBody) before) sz
                whenIsJust cellSize' $ \cellSize -> do
                  let Sized{..} = sz
                  lift . tellM . fmap pure $ fromContent Sized { sizedSize = cellSize, sizedContent }
                  if | [n] <- mapMaybe (\(key, val) -> guardOnM (is _Rowspan key) $ readMay val) (toSortable sizedContent ^. _sortableContent . cellAttrs)
                       -> State.modify $ (:) (n, beforeSize, cellSize)
                     | otherwise -> return ()
              let rowspanAcc'' = rowspanAcc'
                    & traverse . _1 %~ pred
              whenIsJust (flattenAnnotated v) $ go rowspanAcc''

            compCellSize :: forall h' c. [(Int, Int, Int)] -> [Sized (Maybe Int) h' c] -> Sized (Maybe Int) h' c -> (Int, Maybe Int)
            compCellSize rowspanAcc before Sized{..} = (beforeSize,) . assertM' (> 0) $ fromMaybe 1 sizedSize - shadowed
              where Sum beforeSize = foldMap (\(Sized sz _) -> Sum $ fromMaybe 1 sz) before
                    Sum shadowed = flip foldMap rowspanAcc $ \(rowsRem, firstCol, sz) -> fromMaybe mempty $ do
                      guard $ rowsRem > 0
                      guard $ firstCol <= beforeSize
                      guard $ beforeSize < firstCol + sz
                      return . Sum $ sz - (beforeSize - firstCol)

            wrap' :: Seq (Seq (Widget, Int)) -> Widget
            wrap' wRows = view _2 $ Foldable.foldl (\(stackHeight', acc) row -> (Nothing, (acc <>) . wrap stackHeight' $ foldOf (folded . _1) row)) (stackHeight, mempty) wRows
              where stackHeight = Just $ length wRows
            wrap :: Maybe Int -> Widget -> Widget
            wrap stackHeight row = case dbsTemplate of
              DBSTCourse{} -> row
              DBSTDefault{} -> $(widgetFile "table/header")
            fromContent :: Sized Int h (DBCell m x) -> WriterT x m (Widget, Int)
            fromContent Sized{ sizedSize = cellSize, sizedContent = toSortable -> Sortable{..} } = do
              widget <- sortableContent ^. cellContents
              let
                directions = [dir | SortingSetting k dir <- psSorting, Just k == sortableKey ]
                isSortable = isJust sortableKey
                isSorted dir = fromMaybe False $ (==) <$> (SortingSetting <$> sortableKey <*> pure dir) <*> listToMaybe psSorting
                attrs = sortableContent ^. cellAttrs
                piSorting' = [ sSet | sSet <- fromMaybe [] piSorting, Just (sortKey sSet) /= sortableKey ]
                rowspan = preview _head $ do
                  (key, val) <- attrs
                  guard $ is _Rowspan key
                  hoistMaybe $ readMay val
              return . (, fromMaybe 1 rowspan) $ case dbsTemplate of
                DBSTCourse{}  -> $(widgetFile "table/course/header")
                DBSTDefault{} -> $(widgetFile "table/cell/header")
      in do
        wHeaders <- maybe (return Nothing) (fmap Just . genHeaders (dbtColonnade ^. _Cornice)) pSortable
        now <- liftIO getCurrentTime
        case dbsTemplate of
          DBSTCourse c l r s e -> do
            wRows <- forM rows $ \row' -> let
              Course{..}       = row' ^. c . _entityVal
              lecturerUsers    = row' ^.. l
              courseLecturers  = userSurname . entityVal <$> lecturerUsers
              isRegistered     = row' ^. r
              mayEdit          = row' ^. e
              nmnow            = NTop $ Just now
              courseIsVisible  = NTop courseVisibleFrom <= nmnow && nmnow <= NTop courseVisibleTo
              courseSchoolName = schoolName $ row' ^. s . _entityVal
              courseSemester   = (termToText . unTermKey) courseTerm
              in return $(widgetFile "table/course/course-teaser")
            return $(widgetFile "table/course/colonnade")
          DBSTDefault{..} -> do
            let colonnade = discard $ dbtColonnade ^. _Cornice
            wRows' <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade colonnade) $ \(($ row') -> cell') -> do
              widget <- cell' ^. cellContents
              let attrs = cell' ^. cellAttrs
              return $(widgetFile "table/cell/body")
            let wRows = zip [firstRow..] wRows'
            return $(widgetFile "table/colonnade")

    pageCount
      | PagesizeLimit l <- psLimit
      = max 1 . ceiling $ rowCount % l
      | otherwise
      = 1
    pageNumbers = [0..pred pageCount]

    pagesizeWdgt' = wrapForm pagesizeWdgt FormSettings
      { formMethod = GET
      , formAction = Just . SomeRoute $ rawAction :#: wIdent "table-wrapper"
      , formEncoding = pagesizeEnc
      , formAttrs = [("class", "pagesize"), ("autocomplete", "off")]
      , formSubmit = FormAutoSubmit
      , formAnchor = Just $ wIdent "pagesize-form"
      }
    showPagesizeWdgt = toEnum (fromIntegral rowCount) > minimum (pagesizeOptions referencePagesize)
                    -- && selectPagesize

    csvWdgt = $(widgetFile "table/csv-transcode")

    uiLayout :: Widget -> Widget
    uiLayout table = dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout")

    dbInvalidateResult' = foldr (<=<) return . catMaybes $
      [ do
          pKeys <- previousKeys
          guard $ pKeys /= currentKeys
          return . dbInvalidateResult dbtParams . DBTIRowsMissing $ length previousKeys - length currentKeys
      ]

  ((csvImportConfirmRes, _confirmView), _enctype) <- case dbtCsvDecode of
    Just (DBTCsvDecode{dbtCsvExecuteActions, dbtCsvValidateActions} :: DBTCsvDecode r' k' csv) -> do
      lift . runFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \_csrf -> do
        availableActs <- fromMaybe Set.empty <$> globalPostParamField PostDBCsvImportAvailableActions secretJsonField
        acts <- globalPostParamFields PostDBCsvImportAction secretJsonField
        return . (, mempty) . FormSuccess $ if
          | unavailableActs <- filter (`Set.notMember` availableActs) acts
          , not $ null unavailableActs -> do
              throwM . DBCsvUnavailableActionRequested @k' . Set.fromList $ map toJSON unavailableActs
          | otherwise -> do
              (acts', validationMsgs) <- execRWST dbtCsvValidateActions availableActs acts
              if | not $ null validationMsgs -> do
                     mapM_ addMessage' validationMsgs
                     E.transactionUndo
                     redirect $ tblLink id
                 | null acts' -> do
                     addMessageI Info MsgCsvImportAborted
                     redirect $ tblLink id
                 | otherwise -> do
                     finalDest <- runDBJobs' . runConduit $ C.sourceList acts' .| dbtCsvExecuteActions
                     addMessageI Success . MsgCsvImportSuccessful $ length acts'
                     E.transactionSave
                     redirect finalDest

    _other -> return ((FormMissing, mempty), mempty)
  formResult csvImportConfirmRes $ \case
    (_, BtnCsvImportAbort) -> do
      addMessageI Info MsgCsvImportAborted
      redirect $ tblLink id
    (act, _) -> act

  let
    wrapLayout :: DBResult m x -> DB (DBResult m x)
    wrapLayout = dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout
    shortcircuit :: forall void. DBResult m x -> DB void
    shortcircuit res = do
      addCustomHeader HeaderDBTableCanonicalURL =<< toTextUrl (tblLink substPi)
      sendResponse =<< tblLayout . uiLayout =<< dbWidget (Proxy @m) (Proxy @x) res
  dbInvalidateResult' <=< bool wrapLayout shortcircuit psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table'
  where
    tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
    tblLayout tbl' = do
      tbl <- liftHandler $ widgetToPageContent tbl'
      withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")

    setParams :: Text -> [Text] -> QueryText -> QueryText
    setParams key vs qt = map ((key, ) .  Just) vs ++ [ i | i@(key', _) <- qt, key' /= key ]

    setParam :: Text -> Maybe Text -> QueryText -> QueryText
    setParam key = setParams key . maybeToList


dbTableWidget :: Monoid x
              => PSValidator (HandlerFor UniWorX) x
              -> DBTable (HandlerFor UniWorX) x
              -> DB (DBResult (HandlerFor UniWorX) x)
dbTableWidget = dbTable

dbTableWidget' :: PSValidator (HandlerFor UniWorX) ()
               -> DBTable (HandlerFor UniWorX) ()
               -> DB Widget
dbTableWidget' = fmap (fmap snd) . dbTable

dbTableDB :: Monoid x
          => PSValidator DB x
          -> DBTable DB x
          -> DB (DBResult DB x)
dbTableDB = dbTable

dbTableDB' :: PSValidator DB ()
           -> DBTable DB ()
           -> DB Widget
dbTableDB' = fmap (fmap snd) . dbTable

widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
                -> Colonnade h r (DBCell (HandlerFor UniWorX) x)
widgetColonnade = id

-- | force the column list type for tables that contain forms, especially those constructed with dbSelect, avoids explicit type signatures
formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
              -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
formColonnade = id

-- | force the column list type for simple tables that do not contain forms, and especially no dbSelect, avoids explicit type signatures
dbColonnade :: Colonnade h r (DBCell DB x)
            -> Colonnade h r (DBCell DB x)
dbColonnade = id

pagesizeOptions :: PagesizeLimit -- ^ Current/previous value
                -> NonNull [PagesizeLimit]
pagesizeOptions psLim = impureNonNull . Set.toAscList . Set.fromList $ psLim : PagesizeAll : map PagesizeLimit opts
  where
    opts :: [Int64]
    opts = filter (> 0) $ opts' <> map (`div` 2) opts'

    opts' :: [Int64]
    opts' = [ 10^n | n <- [1..3]]

pagesizeField :: PagesizeLimit -> Field Handler PagesizeLimit
pagesizeField psLim = selectField $ do
  MsgRenderer mr <- getMsgRenderer
  let
    optText (PagesizeLimit l) = tshow l
    optText PagesizeAll = mr MsgDBTablePagesizeAll

    toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o)
  return . toOptionList . toNullable $ pagesizeOptions psLim


---------------------------------------------------------------
--- DBCell utility functions, more in Handler.Utils.Table.Cells

cell :: IsDBTable m a => Widget -> DBCell m a
cell wgt = dbCell # ([], return wgt)

wgtCell :: (IsDBTable m a, ToWidget UniWorX wgt) => wgt -> DBCell m a
wgtCell = cell . toWidget

textCell :: (IsDBTable m a) => Text -> DBCell m a
textCell = wgtCell

stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
stringCell = wgtCell . (pack :: String -> Text) . otoList

i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
i18nCell msg = cell $ do
  mr <- getMessageRender
  toWidget $ mr msg

cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
cellTooltip = cellTooltipIcon Nothing

-- note that you can also use `cellTooltip` with `SomeMessages`, which uses ' ' for separation only
cellTooltips :: (RenderMessage UniWorX msg, IsDBTable m a) => [msg] -> DBCell m a -> DBCell m a
cellTooltips msgs = cellTooltipWgt Nothing [whamlet|
  $forall msg <- msgs
    <p>
      _{msg}
|]

cellTooltipIcon :: (RenderMessage UniWorX msg, IsDBTable m a) => Maybe Icon -> msg -> DBCell m a -> DBCell m a
cellTooltipIcon icn = cellTooltipWgt icn . msg2widget

cellTooltipWgt :: (IsDBTable m a) => Maybe Icon -> Widget-> DBCell m a -> DBCell m a
cellTooltipWgt icn wgt = cellContents.mapped %~ (<> tipWdgt)
  where
    tipWdgt = iconTooltip wgt icn True

-- | Always display widget; maybe a link if user is Authorized.
--   Also see variant `linkEmptyCell`
anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a
anchorCell = anchorCellM . return

anchorCellC :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> url -> wgt -> DBCell m a
anchorCellC cache = anchorCellCM cache . return

anchorCell' :: ( IsDBTable m a
               , ToWidget UniWorX wgt
               , HasRoute UniWorX url
               )
           => (r -> url)
           -> (r -> wgt)
           -> (r -> DBCell m a)
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)

anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX url -> wgt -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget)

anchorCellCM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX url -> wgt -> DBCell m a
anchorCellCM cache routeM widget = anchorCellCM' cache routeM id (const widget)

anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)

anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget)

maybeAnchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) url -> wgt -> DBCell m a
maybeAnchorCellM routeM widget = maybeAnchorCellM' routeM id (const widget)

maybeAnchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (Maybe x -> wgt) -> DBCell m a
maybeAnchorCellM' xM x2route x2widget = maybeLinkEitherCellM' xM x2route (x2widget . Just, x2widget)

-- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user
linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => url -> (wgt, wgt') -> DBCell m a
linkEitherCell = linkEitherCellM . return

linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a) => WidgetFor UniWorX url -> (wgt, wgt') -> DBCell m a
linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth)

linkEitherCellM' :: forall m url wgt wgt' a x.
                    ( HasRoute UniWorX url
                    , ToWidget UniWorX wgt
                    , ToWidget UniWorX wgt'
                    , IsDBTable m a
                    )
                 => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellM' (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust)

linkEitherCellCM' :: forall m url wgt wgt' a x cache.
                    ( HasRoute UniWorX url
                    , ToWidget UniWorX wgt
                    , ToWidget UniWorX wgt'
                    , IsDBTable m a
                    , Binary cache
                    )
                 => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellCM' cache xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellCM' (Just . toStrict $ B.encode cache) (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust)

maybeLinkEitherCellM' :: forall m url wgt wgt' a x.
                         ( HasRoute UniWorX url
                         , ToWidget UniWorX wgt
                         , ToWidget UniWorX wgt'
                         , IsDBTable m a
                         )
                      => MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a
maybeLinkEitherCellM' = maybeLinkEitherCellCM' Nothing

maybeLinkEitherCellCM' :: forall m url wgt wgt' a x.
                         ( HasRoute UniWorX url
                         , ToWidget UniWorX wgt
                         , ToWidget UniWorX wgt'
                         , IsDBTable m a
                         )
                      => Maybe ByteString -> MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a
maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
  x' <- runMaybeT xM
  case x' of
    Just x -> do
      let route        = x2route        x
          widget, widgetUnauth :: Widget
          widget       = toWidget $ x2widgetAuth   x
          widgetUnauth = toWidget . x2widgetUnauth $ Just x
      authResult <- liftHandler . maybe id $cachedHereBinary mCache . hasReadAccessTo $ urlRoute route
      linkUrl <- toTextUrl route
      if
        | authResult -> $(widgetFile "table/cell/link") -- show allowed link
        | otherwise  -> widgetUnauth
    _otherwise -> do
      toWidget $ x2widgetUnauth Nothing


listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
listCell = listCell' . return

listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell

ilistCell :: (IsDBTable m a, MonoFoldableWithKey mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
ilistCell = ilistCell' . return

ilistCell' :: (IsDBTable m a, MonoFoldableWithKey mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
ilistCell' mkXS mkCell = review dbCell . ([], ) $ do
  xs <- mkXS
  cells <- forM (otoKeyedList xs) $
    \(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
  return $(widgetFile "table/cell/list")

listCellOf :: IsDBTable m a' => Getting (Endo [a]) s a -> s -> (a -> DBCell m a') -> DBCell m a'
listCellOf l x = listCell (x ^.. l)

listCellOf' :: IsDBTable m a' => Getting (Endo [a]) s a -> WriterT a' m s -> (a -> DBCell m a') -> DBCell m a'
listCellOf' l mkX = listCell' (toListOf l <$> mkX)

ilistCellOf :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> s -> (i -> a -> DBCell m a') -> DBCell m a'
ilistCellOf l x = listCell (itoListOf l x) . uncurry

ilistCellOf' :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> WriterT a' m s -> (i -> a -> DBCell m a') -> DBCell m a'
ilistCellOf' l mkX = listCell' (itoListOf l <$> mkX) . uncurry

newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a))

instance Functor (DBFormResult i a) where
  f `fmap` (DBFormResult resMap) = DBFormResult $ fmap (over _1 f) resMap

instance Ord i => Sem.Semigroup (DBFormResult i a r) where
  (DBFormResult m1) <> (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2

instance Ord i => Monoid (DBFormResult i a r) where
  mempty = DBFormResult Map.empty
  mappend = (<>)

getDBFormResult :: forall r i a. (r -> a) -> DBFormResult i a r -> Map i a
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m

formCell :: forall x r i a. Monoid x
         => Lens' x (FormResult (DBFormResult i a (DBRow r)))   -- ^ lens focussing on the form result within the larger DBResult; @id@ iff the form delivers the only result of the table
         -> (DBRow r -> MForm (HandlerFor UniWorX) i)          -- ^ generate row identfifiers for use in form result
         -> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerFor UniWorX) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
         -> (DBRow r -> DBCell (MForm (HandlerFor UniWorX)) x)
formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
  { formCellAttrs    = []
  , formCellContents = do -- MForm (HandlerFor UniWorX) (FormResult (Map i (Endo a)), Widget)
      i <- lift $ genIndex input
      hashKey <- LBS.toStrict . B.encode <$> cryptoIDKey return
      let
        mkUnique :: PathPiece p => p -> Text
        mkUnique (toPathPiece -> name) = name <> "-" <> decodeUtf8 (Base64.encode rowKeyHash)
          where
            rowKeyHash = (BA.convert :: HMAC (SHAKE256 264) -> ByteString) . hmac hashKey . LBS.toStrict $ B.encode dbrKey
      (edit, w) <- lift $ genForm input mkUnique
      return (DBFormResult . Map.singleton i . (input,) <$> edit, w)
  , formCellLens
  }


-- Predefined colonnades

dbSelect :: forall x h r i a. (Headedness h, Monoid' x)
         => Lens' x (FormResult (DBFormResult i a (DBRow r)))
         -> Setter' a Bool
         -> (DBRow r -> MForm (HandlerFor UniWorX) i)
         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
-- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ pure ("uw-hide-columns--no-hide","")) $ formCell resLens genIndex genForm
  where
    genForm _ mkUnique = do
      (selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
      return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])

-- conditional version of dbSelect producing disabled checkboxes if the condition is not met
dbSelectIf :: forall x h r i a. (Headedness h, Monoid' x)
         => Lens' x (FormResult (DBFormResult i a (DBRow r)))
         -> Setter' a Bool
         -> (DBRow r -> MForm (HandlerFor UniWorX) i)
         -> (DBRow r -> Bool)
         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ [("uw-hide-columns--no-hide", mempty)] ) fCell
  where
    fCell = formCell resLens genIndex genForm
    genForm row mkUnique = do
      (selResult, selWidget) <- mreq checkBoxField ((bool inputDisabled id $ condition row) $ fsUniq mkUnique "select") (Just False) -- produces disabled field, but still checked by master checkbox from header
      --(selResult, selWidget) <- mreq (bool noField checkBoxField $ condition row) (fsUniq mkUnique "select") (Just False) -- omits field entirely, but also removes master checkbox from header
      {- Similar to previous: omits field entirely, but also removes master checkbox from header
      (selResult, selWidget) <- if condition row
          then mreq checkBoxField (fsUniq mkUnique "select") (Just False)
          else return (FormMissing, FieldView "" Nothing "" mempty Nothing False)
      -}
      return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])


cap' :: ( AsCornice Sortable p r' (DBCell m x) colonnade
        , IsDBTable m x
        )
     => colonnade
     -> Cornice Sortable ('Cap p) r' (DBCell m x)
cap' (view _Cornice -> cornice) = case cornice of
  CorniceBase Colonnade{..}
    | [OneColonnade{..}] <- toList getColonnade
      -> recap (oneColonnadeHead & _sortableContent . cellAttrs %~ incRowspan) cornice
  CorniceCap cornices
    -> CorniceCap $ fmap (\OneCornice{..} -> OneCornice { oneCorniceHead = oneCorniceHead & _sortableContent . cellAttrs %~ incRowspan, oneCorniceBody = cap' oneCorniceBody }) cornices
  other
    -> recap (fromSortable . Sortable Nothing $ cell mempty) other
  where
    incRowspan :: [(Text, Text)] -> [(Text, Text)]
    incRowspan attrs
      | [n] <- mapMaybe (\(key, val) -> guardOnM (is _Rowspan key) $ readMay val) attrs
      = (_Rowspan # (), tshow (succ n :: Natural)) : filter (hasn't $ _1 . _Rowspan) attrs
      | otherwise = (_Rowspan # (), "2") : filter (hasn't $ _1 . _Rowspan) attrs

_Rowspan :: Prism' Text ()
_Rowspan = nearly <$> id <*> ((==) `on` CI.mk) $ "rowspan"