{-# LANGUAGE UndecidableInstances #-}

module Handler.Utils.Table.Pagination
  ( module Handler.Utils.Table.Pagination.Types
  , dbFilterKey
  , SomeExprValue(..)
  , SortColumn(..), SortDirection(..)
  , SortingSetting(..)
  , pattern SortAscBy, pattern SortDescBy
  , FilterColumn(..), IsFilterColumn
  , DBRow(..), _dbrOutput, _dbrCount
  , DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
  , module Handler.Utils.Table.Pagination.CsvColumnExplanations
  , DBCsvActionMode(..)
  , DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
  , DBTCsvEncode(..), DBTCsvDecode(..)
  , DBTable(..), DBFilterUI, IsDBTable(..), DBCell(..)
  , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM
  , singletonFilter
  , 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, textCell, stringCell, i18nCell
  , anchorCell, anchorCell', anchorCellM, anchorCellM'
  , linkEitherCell, linkEitherCellM, linkEitherCellM'
  , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
  , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
  , cellTooltip
  , listCell, listCell'
  , formCell, DBFormResult(..), getDBFormResult
  , dbSelect
  , (&)
  , 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.ContentDisposition
import Handler.Utils.I18n
import Handler.Utils.Widgets
import Utils
import Utils.Lens

import Import hiding (pi)

import qualified Data.Foldable as Foldable

import qualified Yesod.Form.Functions as Yesod
  
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)

import qualified Network.Wai as Wai

import Control.Monad.RWS (RWST(..), execRWS)
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 Control.Monad.Trans.Writer.Lazy (censor)

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


#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) }
                     | 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 (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


data FilterColumn t r' = forall a. IsFilterColumn t a => FilterColumn a
                       | forall a. IsFilterProjected r' a => FilterProjected a

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

filterProjected :: FilterColumn t r' -> r' -> [Text] -> DB Bool
filterProjected (FilterProjected f) = flip $ filterProjected' f
filterProjected  _                  = \_ _ -> return True

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 IsFilterProjected r' a where
  filterProjected' :: a -> [Text] -> r' -> DB Bool

instance IsFilterProjected r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where
  filterProjected' fin _ _ = fin

instance IsFilterProjected r' Bool where
  filterProjected' fin _ _ = return fin

instance IsFilterProjected r' cont => IsFilterProjected r' (r' -> cont) where
  filterProjected' cont is' r = filterProjected' (cont r) is' r

instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected r' cont, MonoPointed l, Monoid l) => IsFilterProjected r' (l -> cont) where
  filterProjected' cont is' = filterProjected' (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, Typeable)
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, Typeable)
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
    }
  deriving (Show, Typeable)

makeLenses_ ''DBCsvException

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


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 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 :: UniWorXMessage
  , 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
                           (Lens' r [Entity User])             -- lecturers
                           (Lens' r Bool)                      -- isRegistered
                           (Lens' r (Entity School))           -- school
                           (Traversal' r (Entity Allocation))  -- allocation
                           (Lens' r Bool)                      -- mayEditCourse

instance Default (DBStyle r) where
  def = DBStyle
    { dbsEmptyStyle = def
    , dbsEmptyMessage = 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


data DBTCsvEncode r' k' csv = forall exportData.
  ( ToNamedRecord csv, CsvColumnsExplained csv
  , DBTableKey k'
  , Typeable exportData
  ) => 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         :: FilePath
  , dbtCsvNoExportData :: Maybe (AnIso' exportData ())
  }
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 ()
  , 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).
  ( 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
  ) => 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 :: DBRow r -> DB r'
  , dbtColonnade :: colonnade
  , dbtSorting :: Map SortingKey (SortColumn t r')
  , dbtFilter :: Map FilterKey (FilterColumn t r')
  , dbtFilterUI :: DBFilterUI
  , dbtStyle :: DBStyle r'
  , dbtParams :: DBParams m x
  , dbtCsvEncode :: Maybe (DBTCsvEncode r' k' csv)
  , dbtCsvDecode :: Maybe (DBTCsvDecode r' k' csv)
  , dbtIdent :: i
  }

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

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

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

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


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

  data DBCell m x :: *
  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
    , 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 <- 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
  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 True) (wIdent "pagination")
  piPreviousGet  <- lift . runInputGet  $ iopt (jsonField True) (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
    ((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)))
    filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter'

    selectPagesize = primarySortSql
                  && all (is _Just) filterSql

    psLimit' = bool PagesizeAll psLimit selectPagesize
     

  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
              -> do
                unless (has (_FormSuccess . _DBCsvExport) csvMode) $
                  E.limit l
                E.offset (psPage * l)
          Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
          _other  -> return ()
        Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql
    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

      allFilterProjected r' = lift $ getAll <$> foldMapM (\(f, args) -> All <$> filterProjected f r' args) psFilter'

      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' (assertMM allFilterProjected . lift . dbtProj) . 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
        sendResponse <=< liftHandler . respondCsv hdr $ C.sourceList exData
    DBCsvExport{..}
      | Just DBTCsvEncode{..} <- dbtCsvEncode
      , Just exportData <- fromDynamic dbCsvExportData -> do
        hdr <- dbtCsvHeader $ Just exportData
        let ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName
        dbtCsvName' <- timestampCsv <*> pure dbtCsvName
        setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName'
        sendResponse <=< liftHandler . respondCsvDB 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
                  (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}
                       |]
          , 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
    rowCount
      | 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{..} = execWriterT . go mempty $ annotate cornice
          where
            go :: forall (p' :: Pillar) r'.
                  [(Int, Int, Int)]
               -> AnnotatedCornice (Maybe Int) h p' r' (DBCell m x)
               -> WriterT Widget (WriterT x m) ()
            go rowspanAcc (AnnotatedCorniceBase _ (Colonnade (toList -> v))) = censor wrap . forM_ (zip (inits v) v) $ \(before, OneColonnade Sized{..} _) -> do
              let (_, cellSize') = compCellSize rowspanAcc (map oneColonnadeHead before) Sized{..}
              whenIsJust cellSize' $ \cellSize -> tellM $ fromContent Sized { sizedSize = cellSize, sizedContent }
            go rowspanAcc (AnnotatedCorniceCap _ v@(toList -> oneCornices)) = do
              rowspanAcc' <- (execStateT ?? rowspanAcc) . hoist (censor wrap) . 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 $ 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 :: Widget -> Widget
            wrap row = case dbsTemplate of
              DBSTCourse{} -> row
              DBSTDefault{} -> $(widgetFile "table/header")
            fromContent :: Sized Int h (DBCell m x) -> WriterT x m Widget
            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 ]
              case dbsTemplate of
                DBSTCourse{}  -> return $(widgetFile "table/course/header")
                DBSTDefault{} -> return $(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 a 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
              courseAllocation = row' ^? a
              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} :: DBTCsvDecode r' k' csv) -> do
      lift . runFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \_csrf -> do
        acts <- globalPostParamFields PostDBCsvImportAction secretJsonField
        return . (, mempty) $ if
          | null acts -> FormSuccess $ do
              addMessageI Info MsgCsvImportAborted
              redirect $ tblLink id
          | otherwise -> FormSuccess $ 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

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

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)

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

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 msg = cellContents.mapped %~ (<> tipWdgt)
  where
    tipWdgt = [whamlet|
        <div .tooltip>
          <div .tooltip__handle>
          <div .tooltip__content>_{msg}
      |]

      
-- | 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, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
listCell = listCell' . return
  
listCell' :: (IsDBTable m a, Traversable f) => WriterT a m (f r') -> (r' -> DBCell m a) -> DBCell m a
listCell' mkXS mkCell = review dbCell . ([], ) $ do
  xs <- mkXS
  cells <- forM xs $
    \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
  return $(widgetFile "table/cell/list")

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}|])


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 = prism' (\() -> "rowspan") $ flip guardOn () . ((==) `on` CI.mk) "rowspan"