module Handler.Utils.Table.Pagination
  ( module Handler.Utils.Table.Pagination.Types
  , SortColumn(..), SortDirection(..)
  , pattern SortAscBy, pattern SortDescBy
  , FilterColumn(..), IsFilterColumn
  , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
  , DBStyle(..), DBEmptyStyle(..)
  , DBTable(..), IsDBTable(..), DBCell(..)
  , DBParams(..)
  , cellAttrs, cellContents
  , PaginationSettings(..), PaginationInput(..), piIsUnset
  , PSValidator(..)
  , defaultFilter, defaultSorting
  , restrictFilter, restrictSorting
  , ToSortable(..), Sortable(..)
  , dbTable
  , dbTableWidget, dbTableWidget'
  , widgetColonnade, formColonnade, dbColonnade
  , cell, textCell, stringCell, i18nCell
  , anchorCell, anchorCell', anchorCellM, anchorCellM'
  , tickmarkCell, cellTooltip
  , listCell
  , formCell, DBFormResult, getDBFormResult
  , dbRow, dbSelect
  , (&)
  , module Control.Monad.Trans.Maybe
  , module Colonnade
  ) where

import Handler.Utils.Table.Pagination.Types
import Handler.Utils.Form
import Utils
import Utils.Lens.TH

import Import hiding (pi)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
import qualified Database.Esqueleto.Internal.Language as E (From)

import qualified Data.Binary.Builder as Builder

import qualified Network.Wai as Wai

import Control.Monad.RWS hiding ((<>), mapM_)
import Control.Monad.Writer hiding ((<>), mapM_)
import Control.Monad.Reader (ReaderT(..), mapReaderT)
import Control.Monad.Trans.Maybe

import Data.Foldable (Foldable(foldMap))

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

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

import Text.Hamlet (hamletFile)

import Data.Ratio ((%))

import Control.Lens

import Data.Aeson (Options(..), defaultOptions, decodeStrict')
import Data.Aeson.Text
import Data.Aeson.TH (deriveJSON)

import qualified Data.Text as Text


data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }

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

instance Universe SortDirection
instance Finite SortDirection

instance PathPiece SortDirection where
  toPathPiece SortAsc  = "asc"
  toPathPiece SortDesc = "desc"
  fromPathPiece = finiteFromPathPiece

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1
  } ''SortDirection

sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
sqlSortDirection t (SortColumn e, SortAsc ) = E.asc  $ e t
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t


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

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

instance PathPiece SortingSetting where
  toPathPiece SortingSetting{..} = toPathPiece sortKey <> "-" <> toPathPiece sortDir
  fromPathPiece str = do
    let 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 = forall a. IsFilterColumn t a => FilterColumn a

filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
filterColumn (FilterColumn f) = filterColumn' f

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 input) is'
    where
      (input, ($ []) -> is') = go (mempty, id) is
      go acc [] = acc
      go (acc, is3) (i:is2)
        | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2
        | otherwise = go (acc, is3 . (i:)) is2

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

makeLenses_ ''PaginationSettings

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

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

data PaginationInput = PaginationInput
  { piSorting      :: Maybe [SortingSetting]
  , piFilter       :: Maybe (Map FilterKey [Text])
  , piLimit        :: Maybe Int64
  , 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
  ]

data DBRow r = DBRow
  { dbrOutput :: r
  , dbrIndex, dbrCount :: Int64
  } deriving (Show, Read, Eq, Ord)

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 <$> f dbrOutput <*> pure dbrIndex <*> 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 l'
          | l' <= 0   -> tell . pure $ SomeMessage MsgPSLimitNonPositive
          | otherwise -> modify $ \ps -> ps { psLimit = l' }
        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 _  -> id
      Nothing -> set (_2._psSorting) psSorting

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 }

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 = DBStyle
  { dbsEmptyStyle :: DBEmptyStyle
  , dbsEmptyMessage :: UniWorXMessage
  , dbsAttrs :: [(Text, Text)]
  , dbsLayoutFilter :: Widget -- ^ Filter UI
                    -> Enctype
                    -> Text -- ^ Filter action (target uri)
                    -> Widget -- ^ Table
                    -> Widget
  }

instance Default DBStyle where
  def = DBStyle
    { dbsEmptyStyle = def
    , dbsEmptyMessage = MsgNoTableContent
    , dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
    , dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default")
    }

data DBTable m x = forall a r r' h i t.
  ( ToSortable h, Functor h
  , E.SqlSelect a r
  , PathPiece i, Eq i
  , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
  ) => DBTable
  { dbtSQLQuery :: t -> E.SqlQuery a
  , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
  , dbtColonnade :: Colonnade h r' (DBCell m x)
  , dbtSorting :: Map SortingKey (SortColumn t)
  , dbtFilter :: Map FilterKey (FilterColumn t)
  , dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
  , dbtStyle :: DBStyle
  , dbtParams :: DBParams m x
  , dbtIdent :: i
  }

class (MonadHandler m, 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'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget
  -- | Format @DBTable@ when not short-circuiting
  dbHandler  :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)

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

instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
  data DBParams (HandlerT UniWorX IO) x = DBParamsWidget
  type DBResult (HandlerT UniWorX IO) x = (x, Widget)
  -- type DBResult' (WidgetT UniWorX IO) () = ()

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

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

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

instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
  mempty = WidgetCell mempty $ return mempty
  (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')

instance Default (DBParams (HandlerT UniWorX IO) x) where
  def = DBParamsWidget

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

  data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
    { dbCellAttrs :: [(Text, Text)]
    , dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerT UniWorX IO)) 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 (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
  runDBTable _ _ = mapReaderT liftHandlerT

instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
  mempty = DBCell mempty $ return mempty
  (DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')

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

instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
  data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = DBParamsForm
    { dbParamsFormMethod     :: StdMethod
    , dbParamsFormAction     :: Maybe (SomeRoute UniWorX)
    , dbParamsFormAttrs      :: [(Text, Text)]
    , dbParamsFormAddSubmit  :: Bool
    , dbParamsFormAdditional :: Form a
    , dbParamsFormEvaluate   :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => Form a -> m' ((FormResult a, Widget), Enctype)
    }
  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Widget)
  -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)

  data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
    { formCellAttrs :: [(Text, Text)]
    , formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
    }

  -- dbCell :: Iso'
  --             (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) (FormResult a))
  --             ([(Text, Text)], WriterT (FormResult a) (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
  dbCell = iso
    (\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents))
    (\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget)

  -- 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 :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
  -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
  runDBTable dbtable pi = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenField dbtable pi . withFragment

instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
  def = DBParamsForm
    { dbParamsFormMethod     = POST
    , dbParamsFormAction     = Nothing
    , dbParamsFormAttrs      = []
    , dbParamsFormAddSubmit  = False
    , dbParamsFormAdditional = \_ -> return mempty
    , dbParamsFormEvaluate   = liftHandlerT . runFormPost
    }

dbParamsFormWrap :: Monoid a => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) -> Form a -> Form a
dbParamsFormWrap DBParamsForm{..} tableForm frag = do
  let form = mappend <$> tableForm frag <*> dbParamsFormAdditional mempty
  ((res, fWidget), enctype) <- listen form
  return . (res,) $ do
    btnId <- newIdent
    act <- traverse toTextUrl dbParamsFormAction
    let submitField = buttonField BtnSubmit
        enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype
    $(widgetFile "table/form-wrap")

addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a
addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet|
    $newline never
    <input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
  |]
  where
    wIdent n
      | not $ null dbtIdent = dbtIdent <> "-" <> n
      | otherwise           = n

instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
  mempty = FormCell mempty (return mempty)
  (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')

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


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 n
      | not $ null dbtIdent = dbtIdent <> "-" <> n
      | otherwise           = n
    dbsAttrs'
      | not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
      | otherwise           = dbsAttrs
    multiTextField = Field
      { fieldParse = \ts _ -> return . Right $ Just ts
      , fieldView = error "multiTextField: should not be rendered"
      , fieldEnctype = UrlEncoded
      }

  piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")

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

  let filterPi
        | FormSuccess PaginationInput{..} <- piPrevious <|> piInput
          = def{ piSorting, piLimit }
        | otherwise
          = def

  ((filterRes, filterWdgt), filterEnc) <- runFormGet . renderAForm FormDBTableFilter $ (,)
    <$> areq (jsonField True) "" (Just filterPi)
    <*> dbtFilterUI

  let
    piResult = piPrevious <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes <|> piInput

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

  let
    (errs, PaginationSettings{..}) = case piResult of
      FormSuccess pi
        | not (piIsUnset pi)
          -> runPSValidator dbtable $ Just pi
      FormFailure errs'
          -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
      _   -> runPSValidator dbtable Nothing
    paginationInput
      | FormSuccess pi <- piResult
      , not $ piIsUnset pi
      = pi
      | otherwise
      = def
    psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting

  mapM_ (addMessageI Warning) errs

  rows' <- E.select . E.from $ \t -> do
    res <- dbtSQLQuery t
    E.orderBy (map (sqlSortDirection t) psSorting')
    E.limit psLimit
    E.offset (psPage * psLimit)
    Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
    return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), res)

  let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)

  rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'

  getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest

  let
    rowCount
      | (E.Value n, _):_ <- rows' = n
      | otherwise = 0

    tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ f getParams

    filterAction = tblLink
      $ setParam (wIdent "page") Nothing
      . Map.foldrWithKey (\k _ f -> setParam (wIdent $ toPathPiece k) Nothing . f) id dbtFilter

    table' :: WriterT x m Widget
    table' = do

      let
        genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
          widget <- sortableContent ^. cellContents
          let
            directions = [dir | SortingSetting k dir <- psSorting, Just k == sortableKey ]
            isSortable = isJust sortableKey
            isSorted = (`elem` directions)
            attrs = sortableContent ^. cellAttrs
          return $(widgetFile "table/cell/header")

        columnCount :: Int64
        columnCount = olength64 $ getColonnade dbtColonnade

      wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable

      wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
        widget <- cell' ^. cellContents
        let attrs = cell' ^. cellAttrs
        return $(widgetFile "table/cell/body")

      let table = $(widgetFile "table/colonnade")
          pageCount = max 1 . ceiling $ rowCount % psLimit
          pageNumbers = [0..pred pageCount]

      return $(widgetFile "table/layout")

  bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable dbtable paginationInput . fmap swap $ runWriterT table'
  where
    tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
    tblLayout tbl' = do
      tbl <- liftHandlerT $ widgetToPageContent tbl'
      withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")

    setParam :: Text -> Maybe Text -> QueryText -> QueryText
    setParam key v qt = maybe id (\v' -> (:) (key, Just v')) v [ i | i@(key', _) <- qt, key' /= key ]

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

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

widgetColonnade :: (Headedness h, Monoid x)
                => Colonnade h r (DBCell (HandlerT UniWorX IO) x)
                -> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
widgetColonnade = id

formColonnade :: (Headedness h, Monoid a)
              => Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
              -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
formColonnade = id

dbColonnade :: (Headedness h, Monoid x)
            => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
dbColonnade = id


--- DBCell utility functions

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

tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
tickmarkCell True  = textCell (tickmark :: Text)
tickmarkCell False = mempty

cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
  where
    tipWdgt = [whamlet|
        <div .js-tooltip>
          <div .tooltip__handle>
          <div .tooltip__content>_{msg}
      |]


anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
anchorCell = anchorCellM . return

{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-}
anchorCell' :: IsDBTable m a
           => (r -> Route UniWorX)
           -> (r -> Widget)
           -> (r -> DBCell m a)
anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)

anchorCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> Widget -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget)

anchorCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
anchorCellM' xM x2route x2widget = cell $ do
  x <- xM
  let route  = x2route  x
      widget = x2widget x
  authResult <- liftHandlerT $ isAuthorized route False
  case authResult of
    Authorized -> $(widgetFile "table/cell/link") -- show allowed link
    _otherwise -> widget                          -- don't show prohibited link


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

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

instance Ord i => Monoid (DBFormResult r i a) where
  mempty = DBFormResult Map.empty
  (DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2

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

formCell :: forall res r i a. (Ord i, Monoid res)
         => Lens' res (DBFormResult r i a)
         -> (r -> MForm (HandlerT UniWorX IO) i)
         -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
         -> (r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
formCell resLens genIndex genForm input = FormCell
  { formCellAttrs    = []
  , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
      i <- genIndex input
      (edit, w) <- genForm input i
      return (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w)
  }


-- Predefined colonnades

--Number column?
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex

dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res)
         => Lens' res (DBFormResult r i a)
         -> Setter' a Bool
         -> (r -> MForm (HandlerT UniWorX IO) i)
         -> Colonnade h r (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell resLens genIndex) r $ \_ i -> do
  (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
  return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])