Introduce DBCell-Constructor and dbColonnade
This commit is contained in:
Gregor Kleen
parent
d0fcf2e9e3
commit
96eea52344
@ -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)]
|
||||
, dbCellContents :: Widget
|
||||
{ wgtCellAttrs :: [(Text, Text)]
|
||||
, wgtCellContents :: Widget
|
||||
}
|
||||
cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
|
||||
cellContents = return . dbCellContents
|
||||
cellAttrs = lens wgtCellAttrs $ \w as -> w { wgtCellAttrs = as }
|
||||
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,54 +376,55 @@ 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
|
||||
| (E.Value n, _):_ <- rows' = n
|
||||
| otherwise = 0
|
||||
rows = map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
|
||||
let
|
||||
rowCount
|
||||
| (E.Value n, _):_ <- rows' = n
|
||||
| otherwise = 0
|
||||
rows = map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
|
||||
|
||||
table' :: WriterT x m Widget
|
||||
table' = do
|
||||
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
||||
table' :: WriterT x m Widget
|
||||
table' = do
|
||||
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
||||
|
||||
let
|
||||
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
|
||||
let
|
||||
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
|
||||
|
||||
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
|
||||
widget <- cellContents sortableContent
|
||||
let
|
||||
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
|
||||
isSortable = isJust sortableKey
|
||||
isSorted = (`elem` directions)
|
||||
attrs = sortableContent ^. cellAttrs
|
||||
return $(widgetFile "table/cell/header")
|
||||
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
|
||||
widget <- cellContents sortableContent
|
||||
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
|
||||
columnCount :: Int64
|
||||
columnCount = olength64 $ getColonnade dbtColonnade
|
||||
|
||||
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
|
||||
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
|
||||
|
||||
wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
|
||||
widget <- cellContents cell
|
||||
let attrs = cell ^. cellAttrs
|
||||
return $(widgetFile "table/cell/body")
|
||||
wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
|
||||
widget <- cellContents cell
|
||||
let attrs = cell ^. cellAttrs
|
||||
return $(widgetFile "table/cell/body")
|
||||
|
||||
let table = $(widgetFile "table/colonnade")
|
||||
pageCount = max 1 . ceiling $ rowCount % psLimit
|
||||
pageNumbers = [0..pred pageCount]
|
||||
let table = $(widgetFile "table/colonnade")
|
||||
pageCount = max 1 . ceiling $ rowCount % psLimit
|
||||
pageNumbers = [0..pred pageCount]
|
||||
|
||||
return $(widgetFile "table/layout")
|
||||
return $(widgetFile "table/layout")
|
||||
|
||||
dbWidget' :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBResult m x -> m' Widget
|
||||
dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
|
||||
|
||||
dbWidget' :: DBResult m x -> Handler Widget
|
||||
dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
|
||||
|
||||
bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user