{-# LANGUAGE NoImplicitPrelude
           , ExistentialQuantification
           , RecordWildCards
           , NamedFieldPuns
           , OverloadedStrings
           , TemplateHaskell
           , QuasiQuotes
           , LambdaCase
           , ViewPatterns
           , FlexibleContexts
           , FlexibleInstances
           , MultiParamTypeClasses
           , TypeFamilies
           , ScopedTypeVariables
           , TupleSections
           , RankNTypes
           , MultiWayIf
           , FunctionalDependencies
  #-}

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

import Handler.Utils.Table.Pagination.Types

import Import hiding (Proxy(..))
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 Text.Blaze (Attribute)
import qualified Text.Blaze.Html5.Attributes as Html5
import qualified Text.Blaze.Html5 as Html5

import qualified Data.Binary.Builder as Builder

import qualified Network.Wai as Wai

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
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 Data.Profunctor (lmap)

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.Proxy


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

data SortDirection = SortAsc | SortDesc
  deriving (Eq, Ord, Enum, Show, Read)
instance PathPiece SortDirection where
  toPathPiece SortAsc  = "asc"
  toPathPiece SortDesc = "desc"
  fromPathPiece (CI.mk -> t)
    | t == "asc"  = Just SortAsc
    | t == "desc" = Just SortDesc
    | otherwise   = Nothing

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

data PaginationSettings = PaginationSettings
  { psSorting      :: [(CI Text, SortDirection)]
  , psFilter       :: Map (CI Text) [Text]
  , psLimit        :: Int64
  , psPage         :: Int64
  , psShortcircuit :: Bool
  }

makeClassy_ ''PaginationSettings

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

data PaginationInput = PaginationInput
  { piSorting      :: Maybe [(CI Text, SortDirection)]
  , piFilter       :: Maybe (Map (CI Text) [Text])
  , piLimit        :: Maybe Int64
  , piPage         :: Maybe Int64
  , piShortcircuit :: Bool
  }

makeClassy_ ''PaginationInput

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

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 })
      asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s })

defaultFilter :: Map (CI Text) [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 :: [(CI Text, SortDirection)] -> 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 :: (CI Text -> [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 :: (CI Text -> 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 (uncurry restrict) $ psSorting p }

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

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

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

instance Default DBStyle where
  def = DBStyle
    { dbsEmptyStyle = def
    , dbsEmptyMessage = MsgNoTableContent
    , dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
    }

data DBTable m x = forall a r r' h i t.
  ( ToSortable h, Functor h
  , E.SqlSelect a r
  , PathPiece 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 (CI Text) (SortColumn t)
  , dbtFilter :: Map (CI Text) (FilterColumn t)
  , dbtStyle :: DBStyle
  , dbtIdent :: i
  }

class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where
  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)
  dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget
  dbHandler :: forall m'. (MonadHandler m' , HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => 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
  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))
    (\(attrs, mkWidget) -> WidgetCell attrs mkWidget)
  
  -- dbWidget Proxy Proxy = iso (, ()) $ view _1
  dbWidget _ = return . snd
  dbHandler _ f = return . over _2 f
  runDBTable act = liftHandlerT act

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 Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
  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))
    (\(attrs, mkWidget) -> DBCell attrs mkWidget)

  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 Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
  -- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
  -- 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 DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . identifyForm dbtIdent
  dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> identifyForm dbtIdent form csrf
  -- 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 = return . withFragment

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 -> Handler (DBResult m x)
dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. }) = do
  let
    sortingOptions = mkOptionList
      [ Option t' (t, d) t'
      | (t, _) <- mapToList dbtSorting
      , d <- [SortAsc, SortDesc]
      , let t' = CI.foldedCase t <> "-" <> toPathPiece d
      ]
    (_, defPS) = runPSValidator dbtable Nothing
    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 = undefined
      , fieldEnctype = UrlEncoded
      }
    
  psResult <- runInputGetResult $ PaginationInput
    <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
    <*> ((assertM' $ not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
    <*> iopt intField (wIdent "pagesize")
    <*> iopt intField (wIdent "page")
    <*> ireq checkBoxField (wIdent "table-only")

  $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> psResult)
                               <*> (piFilter <$> psResult)
                               <*> (piLimit <$> psResult)
                               <*> (piPage <$> psResult)
                               <*> (piShortcircuit <$> psResult)

  let
    (errs, PaginationSettings{..}) = case psResult of
      FormSuccess pi
        | not (piIsUnset pi) -> runPSValidator dbtable $ Just pi
      FormFailure errs       -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing
      _                      -> runPSValidator dbtable Nothing
    psSorting' = map (first (dbtSorting !)) psSorting
    sqlQuery' = E.from $ \t -> 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

  mapM_ (addMessageI "warning") errs

  runDB $ do
    rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'

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

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

      table' :: WriterT x m Widget
      table' = do
        getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest

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

          genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
            widget <- sortableContent ^. cellContents
            let
              directions = [dir | (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 $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable) psShortcircuit <=< runDBTable . 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 = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]

--- DBCell utility functions

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

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

textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
stringCell = textCell
i18nCell = textCell
textCell msg = cell [whamlet|_{msg}|]

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


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

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 = cell $ do
  route <- routeM
  authResult <- liftHandlerT $ isAuthorized route False

  if
    | Authorized <- authResult -> $(widgetFile "table/cell/link")
    | otherwise                -> widget

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 r i a. Ord i
         => (r -> MForm (HandlerT UniWorX IO) i)
         -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
         -> (r -> DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
formCell 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 (DBFormResult . Map.singleton i . (input,) <$> edit, w)
  }

-- Predefined colonnades

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

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