Framework for forms in dbTable
This commit is contained in:
Gregor Kleen
parent
710ace42bf
commit
7b336dd5a6
@ -154,6 +154,9 @@ instance RenderMessage UniWorX TermIdentifier where
|
||||
Winter -> renderMessage' $ MsgWinterTerm year
|
||||
where renderMessage' = renderMessage foundation ls
|
||||
|
||||
instance RenderMessage UniWorX String where
|
||||
renderMessage f ls str = renderMessage f ls $ Text.pack str
|
||||
|
||||
|
||||
-- Access Control
|
||||
data AccessPredicate
|
||||
|
||||
@ -9,6 +9,7 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
|
||||
module Handler.Sheet where
|
||||
|
||||
@ -23,7 +24,7 @@ import qualified Data.Text as T
|
||||
-- import Data.Function ((&))
|
||||
--
|
||||
import Colonnade hiding (fromMaybe, singleton)
|
||||
import Yesod.Colonnade
|
||||
import qualified Yesod.Colonnade as Yesod
|
||||
--
|
||||
import qualified Data.UUID.Cryptographic as UUID
|
||||
import qualified Data.Conduit.List as C
|
||||
@ -180,7 +181,7 @@ getSheetList courseEnt = do
|
||||
setTitle $ toHtml $ T.append "Übungsblätter " csh
|
||||
if null sheets
|
||||
then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
|
||||
else encodeWidgetTable tableDefault colSheets sheets
|
||||
else Yesod.encodeWidgetTable tableDefault colSheets sheets
|
||||
|
||||
|
||||
-- Show single sheet
|
||||
@ -211,12 +212,14 @@ getSShowR tid csh shn = do
|
||||
E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
|
||||
-- return desired columns
|
||||
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = mconcat
|
||||
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
|
||||
(\(E.Value fName,_,_) -> str2widget fName)
|
||||
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
|
||||
]
|
||||
let
|
||||
colonnadeFiles :: Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
|
||||
colonnadeFiles = mconcat
|
||||
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
|
||||
(\(E.Value fName,_,_) -> str2widget fName)
|
||||
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
|
||||
]
|
||||
fileTable <- dbTable def $ DBTable
|
||||
{ dbtSQLQuery = fileData
|
||||
, dbtColonnade = colonnadeFiles
|
||||
|
||||
@ -13,6 +13,7 @@
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
|
||||
module Handler.Submission where
|
||||
|
||||
@ -49,7 +50,7 @@ import Data.Bifunctor
|
||||
import System.FilePath
|
||||
|
||||
import Colonnade hiding (bool)
|
||||
import Yesod.Colonnade
|
||||
import qualified Yesod.Colonnade as Yesod
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
|
||||
|
||||
@ -236,7 +237,8 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
let formText = Nothing :: Maybe UniWorXMessage
|
||||
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
|
||||
-- Maybe construct a table to display uploaded archive files
|
||||
let colonnadeFiles cid = mconcat
|
||||
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
|
||||
colonnadeFiles cid = mconcat
|
||||
-- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
||||
[ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle)
|
||||
(\(Entity _ File{..}) -> str2widget fileTitle)
|
||||
@ -356,9 +358,9 @@ submissionTable = do
|
||||
anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
|
||||
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
|
||||
colonnade = mconcat
|
||||
[ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText
|
||||
, headed "Kurs" $ anchorCell anchorCourse courseText
|
||||
, headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> textCell $ sheetName
|
||||
[ headed "Abgabe-ID" $ Yesod.anchorCell anchorSubmission submissionText
|
||||
, headed "Kurs" $ Yesod.anchorCell anchorCourse courseText
|
||||
, headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> Yesod.textCell $ sheetName
|
||||
]
|
||||
toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission
|
||||
toExternal (_, cID, _) = return cID
|
||||
|
||||
@ -7,6 +7,7 @@
|
||||
, MultiParamTypeClasses
|
||||
, TypeFamilies
|
||||
, FlexibleContexts
|
||||
, PartialTypeSignatures
|
||||
#-}
|
||||
|
||||
module Handler.Term where
|
||||
@ -18,7 +19,6 @@ import Handler.Utils
|
||||
import Yesod.Form.Bootstrap3
|
||||
|
||||
import Colonnade hiding (bool)
|
||||
import Yesod.Colonnade
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
@ -41,33 +41,35 @@ getTermShowR = do
|
||||
selectRep $ do
|
||||
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
|
||||
provideRep $ do
|
||||
let colonnadeTerms = mconcat
|
||||
[ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
|
||||
-- Scrap this if to slow, create term edit page instead
|
||||
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
|
||||
[whamlet|
|
||||
$if adminLink == Authorized
|
||||
<a href=@{TermEditExistR tid}>
|
||||
#{termToText termName}
|
||||
$else
|
||||
#{termToText termName}
|
||||
|]
|
||||
, sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termLectureStart
|
||||
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termLectureEnd
|
||||
, sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
|
||||
textCell $ bool "" tickmark termActive
|
||||
, sortable Nothing "Kursliste" $ anchorCell
|
||||
(\(Entity tid _, _) -> TermCourseListR tid)
|
||||
(\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|])
|
||||
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
|
||||
let
|
||||
colonnadeTerms :: Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
|
||||
colonnadeTerms = mconcat
|
||||
[ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
|
||||
-- Scrap this if to slow, create term edit page instead
|
||||
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
|
||||
[whamlet|
|
||||
$if adminLink == Authorized
|
||||
<a href=@{TermEditExistR tid}>
|
||||
#{termToText termName}
|
||||
$else
|
||||
#{termToText termName}
|
||||
|]
|
||||
, sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termLectureStart
|
||||
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termLectureEnd
|
||||
, sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
|
||||
textCell $ (bool "" tickmark termActive :: Text)
|
||||
, sortable Nothing "Kursliste" $ anchorCell
|
||||
(\(Entity tid _, _) -> TermCourseListR tid)
|
||||
(\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|])
|
||||
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termStart
|
||||
, sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) ->
|
||||
, sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termEnd
|
||||
, sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
|
||||
, sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
|
||||
]
|
||||
]
|
||||
table <- dbTable def $ DBTable
|
||||
{ dbtSQLQuery = termData
|
||||
, dbtColonnade = colonnadeTerms
|
||||
|
||||
@ -10,29 +10,32 @@
|
||||
, FlexibleInstances
|
||||
, MultiParamTypeClasses
|
||||
, TypeFamilies
|
||||
, ScopedTypeVariables
|
||||
, TupleSections
|
||||
, RankNTypes
|
||||
#-}
|
||||
|
||||
module Handler.Utils.Table.Pagination
|
||||
( SortColumn(..), SortDirection(..)
|
||||
, FilterColumn(..), IsFilterColumn
|
||||
, DBRow(..), DBOutput
|
||||
, DBTable(..)
|
||||
, DBTable(..), IsDBTable(..)
|
||||
, PaginationSettings(..)
|
||||
, PSValidator(..)
|
||||
, Sortable(..), sortable
|
||||
, dbTable
|
||||
, textCell, stringCell, anchorCell
|
||||
) where
|
||||
|
||||
import Handler.Utils.Table.Pagination.Types
|
||||
|
||||
import Import
|
||||
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 Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))
|
||||
|
||||
import qualified Data.Binary.Builder as Builder
|
||||
|
||||
@ -42,6 +45,7 @@ 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 Data.Map (Map, (!))
|
||||
import qualified Data.Map as Map
|
||||
@ -50,12 +54,15 @@ import Data.Profunctor (lmap)
|
||||
|
||||
import Colonnade hiding (bool, fromMaybe, singleton)
|
||||
import Colonnade.Encode
|
||||
import Yesod.Colonnade
|
||||
|
||||
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) }
|
||||
|
||||
@ -106,28 +113,28 @@ data DBRow r = DBRow
|
||||
class DBOutput r r' where
|
||||
dbProj :: r -> r'
|
||||
|
||||
instance DBOutput r r where
|
||||
instance DBOutput (DBRow r) (DBRow r) where
|
||||
dbProj = id
|
||||
instance DBOutput (DBRow r) r where
|
||||
dbProj = dbrOutput
|
||||
instance DBOutput (DBRow r) (Int64, r) where
|
||||
dbProj = (,) <$> dbrIndex <*> dbrOutput
|
||||
|
||||
|
||||
data DBTable = forall a r r' h i t.
|
||||
data DBTable m x = forall a r r' h i t.
|
||||
( ToSortable h, Functor h
|
||||
, E.SqlSelect a r, DBOutput (DBRow r) r'
|
||||
, PathPiece i
|
||||
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
|
||||
) => DBTable
|
||||
{ dbtSQLQuery :: t -> E.SqlQuery a
|
||||
, dbtColonnade :: Colonnade h r' (Cell UniWorX)
|
||||
, dbtColonnade :: Colonnade h r' (DBCell m x)
|
||||
, dbtSorting :: Map Text (SortColumn t)
|
||||
, dbtFilter :: Map Text (FilterColumn t)
|
||||
, dbtAttrs :: Attribute
|
||||
, dbtAttrs :: Attribute -- FIXME: currently unused
|
||||
, dbtIdent :: i
|
||||
}
|
||||
|
||||
|
||||
data PaginationSettings = PaginationSettings
|
||||
{ psSorting :: [(Text, SortDirection)]
|
||||
, psFilter :: Map Text [Text]
|
||||
@ -145,9 +152,9 @@ instance Default PaginationSettings where
|
||||
, psShortcircuit = False
|
||||
}
|
||||
|
||||
newtype PSValidator = PSValidator { runPSValidator :: DBTable -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
|
||||
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
|
||||
|
||||
instance Default PSValidator where
|
||||
instance Default (PSValidator m x) where
|
||||
def = PSValidator $ \DBTable{..} -> \case
|
||||
Nothing -> def
|
||||
Just ps -> swap . (\act -> execRWS act () ps) $ do
|
||||
@ -156,8 +163,59 @@ instance Default PSValidator where
|
||||
modify $ \ps -> ps { psLimit = psLimit def }
|
||||
tell . pure $ SomeMessage MsgPSLimitNonPositive
|
||||
|
||||
class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where
|
||||
type DBResult m x :: *
|
||||
type DBResult' m x :: *
|
||||
|
||||
dbTable :: PSValidator -> DBTable -> Handler Widget
|
||||
data DBCell m x :: *
|
||||
cellAttrs :: Lens' (DBCell m x) [(Text, Text)]
|
||||
cellContents :: DBCell m x -> WriterT x m Widget
|
||||
|
||||
cell :: Widget -> DBCell m x
|
||||
|
||||
|
||||
dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
||||
runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (Widget, x) -> 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
|
||||
}
|
||||
cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
|
||||
cellContents = return . dbCellContents
|
||||
|
||||
cell = WidgetCell []
|
||||
|
||||
dbWidget Proxy Proxy = iso (, ()) $ view _1
|
||||
runDBTable = return . join . fmap (view _1)
|
||||
|
||||
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) = (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)
|
||||
}
|
||||
cellAttrs = lens formCellAttrs $ \w as -> w { formCellAttrs = as }
|
||||
cellContents = WriterT . fmap swap . formCellContents
|
||||
|
||||
cell widget = FormCell [] $ return (mempty, widget)
|
||||
|
||||
dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
|
||||
((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
|
||||
-- runDBTable :: MForm (HandlerT UniWorX IO) (Widget, FormResult a) -> m ((FormResult a, Widget), Enctype)
|
||||
runDBTable = undefined -- use runFormPost
|
||||
|
||||
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), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do
|
||||
let
|
||||
sortingOptions = mkOptionList
|
||||
@ -214,23 +272,39 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
|
||||
| otherwise = 0
|
||||
rows = map (\((E.Value i, E.Value n), r) -> DBRow i n r) rows'
|
||||
|
||||
bool return (sendResponse <=< tblLayout) psShortcircuit $ do
|
||||
getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
||||
let table = $(widgetFile "table/colonnade")
|
||||
pageCount = max 1 . ceiling $ rowCount % psLimit
|
||||
pageNumbers = [0..pred pageCount]
|
||||
table' :: WriterT x m Widget
|
||||
table' = do
|
||||
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
||||
|
||||
let
|
||||
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
|
||||
|
||||
withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell
|
||||
{ cellContents = $(widgetFile "table/sortable-header")
|
||||
, cellAttrs = maybe mempty (const sortableAttr) sortableKey <> cellAttrs
|
||||
}
|
||||
where
|
||||
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
|
||||
widget <- cellContents sortableContent
|
||||
let
|
||||
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
|
||||
sortableAttr = Html5.class_ . fromString . unwords $ "sortable" : foldMap toAttr directions
|
||||
toAttr SortAsc = ["sorted-asc"]
|
||||
toAttr SortDesc = ["sorted-desc"]
|
||||
$(widgetFile "table/layout")
|
||||
isSortable = isJust sortableKey
|
||||
isSorted = (`elem` directions)
|
||||
attrs = sortableContent ^. cellAttrs
|
||||
return $(widgetFile "table/cell/header")
|
||||
|
||||
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")
|
||||
|
||||
let table = $(widgetFile "table/colonnade")
|
||||
pageCount = max 1 . ceiling $ rowCount % psLimit
|
||||
pageNumbers = [0..pred pageCount]
|
||||
|
||||
return $(widgetFile "table/layout")
|
||||
|
||||
dbWidget' :: Iso' (DBResult m x) (Widget, DBResult' m x)
|
||||
dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
|
||||
|
||||
bool return (sendResponse <=< tblLayout . view (dbWidget' . _1)) psShortcircuit <=< runDBTable $ runWriterT table'
|
||||
where
|
||||
tblLayout :: Widget -> Handler Html
|
||||
tblLayout tbl' = do
|
||||
@ -240,22 +314,17 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
|
||||
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
||||
setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
|
||||
|
||||
widgetFromCell ::
|
||||
(Attribute -> WidgetT site IO () -> WidgetT site IO ())
|
||||
-> Cell site
|
||||
-> WidgetT site IO ()
|
||||
widgetFromCell f (Cell attrs contents) =
|
||||
f attrs contents
|
||||
td,th ::
|
||||
Attribute -> WidgetT site IO () -> WidgetT site IO ()
|
||||
--- DBCell utility functions
|
||||
|
||||
td = liftParent Html5.td
|
||||
th = liftParent Html5.th
|
||||
textCell, stringCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
||||
stringCell = textCell
|
||||
textCell msg = cell [whamlet|_{msg}|]
|
||||
|
||||
liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a
|
||||
liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do
|
||||
(a,gwd) <- f hdata
|
||||
let Body bodyFunc = gwdBody gwd
|
||||
newBodyFunc render =
|
||||
el Html5.! attrs $ (bodyFunc render)
|
||||
return (a,gwd { gwdBody = Body newBodyFunc })
|
||||
anchorCell :: IsDBTable m a
|
||||
=> (r -> Route UniWorX)
|
||||
-> (r -> Widget)
|
||||
-> (r -> DBCell m a)
|
||||
anchorCell mkRoute mkWidget val = cell $(widgetFile "table/cell/link")
|
||||
where
|
||||
route = mkRoute val
|
||||
widget = mkWidget val
|
||||
|
||||
@ -40,4 +40,3 @@ instance ToSortable Headed where
|
||||
|
||||
instance ToSortable Headless where
|
||||
pSortable = Nothing
|
||||
|
||||
|
||||
2
templates/table/cell/body.hamlet
Normal file
2
templates/table/cell/body.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
<td *{attrs}>
|
||||
^{widget}
|
||||
11
templates/table/cell/header.hamlet
Normal file
11
templates/table/cell/header.hamlet
Normal file
@ -0,0 +1,11 @@
|
||||
<th *{attrs} :isSortable:.sortable :isSorted SortAsc:.sorted-asc :isSorted SortDesc:.sorted-desc>
|
||||
$maybe flag <- sortableKey
|
||||
$case directions
|
||||
$of [SortAsc]
|
||||
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ flag <> "-desc")}>
|
||||
^{widget}
|
||||
$of _
|
||||
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ flag <> "-asc")}>
|
||||
^{widget}
|
||||
$nothing
|
||||
^{widget}
|
||||
2
templates/table/cell/link.hamlet
Normal file
2
templates/table/cell/link.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
<a href=@{route}>
|
||||
^{widget}
|
||||
@ -1,18 +1,13 @@
|
||||
$newline never
|
||||
<table id="#{dbtIdent}" .table.table--striped.table--hover>
|
||||
$maybe sortableP <- pSortable
|
||||
$with toSortable <- toSortable sortableP
|
||||
<thead>
|
||||
<tr .table__row.table__row--head>
|
||||
$forall OneColonnade{..} <- getColonnade dbtColonnade
|
||||
<!-- TODO: give ths a class 'table__th' -->
|
||||
<!-- TODO: wrap content of th in 'div.table__th-content' -->
|
||||
^{widgetFromCell th $ withSortLinks $ toSortable oneColonnadeHead}
|
||||
$maybe wHeaders' <- wHeaders
|
||||
<thead>
|
||||
<tr .table__row.table__row--head>
|
||||
$forall widget <- wHeaders'
|
||||
^{widget}
|
||||
$nothing
|
||||
<tbody>
|
||||
$forall row <- rows
|
||||
$forall row <- wRows
|
||||
<tr .table__row>
|
||||
$forall OneColonnade{..} <- getColonnade dbtColonnade
|
||||
<!-- TODO: give tds a class 'table__td' -->
|
||||
<!-- TODO: wrap content of td in 'div.table__td-content' -->
|
||||
^{widgetFromCell td $ oneColonnadeEncode row}
|
||||
$forall widget <- row
|
||||
^{widget}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user