Introduce DBCell-Constructor and dbColonnade

src/Handler/Utils/Table/Pagination.hs

@@ -29,7 +29,7 @@ module Handler.Utils.Table.Pagination
   , restrictFilter, restrictSorting
   , ToSortable(..), Sortable(..), sortable
   , dbTable
-  , widgetColonnade, formColonnade
+  , widgetColonnade, formColonnade, dbColonnade
   , textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM
   , formCell, DBFormResult, getDBFormResult
   , dbRow, dbSelect
@@ -54,6 +54,7 @@ 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 Data.Map (Map, (!))
 import qualified Data.Map as Map
@@ -251,18 +252,18 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
     
   -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
   dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Proxy m -> Proxy x -> DBResult m x -> m' Widget
-  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> m' (DBResult m x)
+  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
 
 instance IsDBTable (WidgetT UniWorX IO) () where
   type DBResult (WidgetT UniWorX IO) () = Widget
   -- type DBResult' (WidgetT UniWorX IO) () = ()
 
   data DBCell (WidgetT UniWorX IO) () = WidgetCell
-    { dbCellAttrs :: [(Text, Text)]
+    { wgtCellAttrs :: [(Text, Text)]
-    , dbCellContents :: Widget
+    , wgtCellContents :: Widget
     }
-  cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
+  cellAttrs = lens wgtCellAttrs $ \w as -> w { wgtCellAttrs = as }
-  cellContents = return . dbCellContents
+  cellContents = return . wgtCellContents
 
   cell = WidgetCell []
   
@@ -274,6 +275,27 @@ instance Monoid (DBCell (WidgetT UniWorX IO) ()) where
   mempty = WidgetCell mempty mempty
   (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend c c')
 
+instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where
+  type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) () = Widget
+
+  data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) () = DBCell
+    { dbCellAttrs :: [(Text, Text)]
+    , dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget
+    }
+
+  cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
+  cellContents = lift . dbCellContents
+
+  cell = DBCell [] . return
+
+  dbWidget Proxy Proxy = return
+  -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
+  runDBTable = fmap snd . mapReaderT liftHandlerT
+
+instance Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) 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
@@ -354,7 +376,8 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
 
   mapM_ (addMessageI "warning") errs
 
-  rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
+  runDB $ do
+    rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
 
     let
       rowCount
@@ -394,14 +417,14 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
 
         return $(widgetFile "table/layout")
     
-    dbWidget' :: DBResult m x -> Handler Widget
+      dbWidget' :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBResult m x -> m' Widget
       dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
 
     bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
   where
-    tblLayout :: Widget -> Handler Html
+    tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
     tblLayout tbl' = do
-      tbl <- widgetToPageContent tbl'
+      tbl <- liftHandlerT $ widgetToPageContent tbl'
       withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")
 
     setParam :: Text -> Maybe Text -> QueryText -> QueryText
@@ -419,6 +442,11 @@ formColonnade :: (Headedness h, Monoid a)
               -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
 formColonnade = id
 
+dbColonnade :: Headedness h
+            => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
+            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
+dbColonnade = id
+
 textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
 stringCell = textCell
 i18nCell = textCell