module Yesod.Colonnade
(
Cell(..)
, cell
, stringCell
, textCell
, builderCell
, anchorCell
, anchorWidget
, encodeWidgetTable
, encodeCellTable
, encodeDefinitionTable
, encodeListItems
) where
import Yesod.Core
import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))
import Colonnade (Colonnade,Headed,Headless)
import Data.Text (Text)
import Control.Monad
import Data.Monoid
import Data.String (IsString(..))
import Text.Blaze (Attribute,toValue)
import Data.Foldable
import qualified Text.Blaze.Html5.Attributes as HA
import qualified Text.Blaze.Html5 as H
import qualified Colonnade.Encode as E
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Builder as TBuilder
data Cell site = Cell
{ cellAttrs :: !Attribute
, cellContents :: !(WidgetT site IO ())
}
instance IsString (Cell site) where
fromString = stringCell
instance Monoid (Cell site) where
mempty = Cell mempty mempty
mappend (Cell a1 c1) (Cell a2 c2) = Cell (mappend a1 a2) (mappend c1 c2)
cell :: WidgetT site IO () -> Cell site
cell = Cell mempty
stringCell :: String -> Cell site
stringCell = cell . fromString
textCell :: Text -> Cell site
textCell = cell . toWidget . toHtml
builderCell :: TBuilder.Builder -> Cell site
builderCell = cell . toWidget . toHtml . LText.toStrict . TBuilder.toLazyText
anchorCell ::
(a -> Route site)
-> (a -> WidgetT site IO ())
-> a
-> Cell site
anchorCell getRoute getContent = cell . anchorWidget getRoute getContent
anchorWidget ::
(a -> Route site)
-> (a -> WidgetT site IO ())
-> a
-> WidgetT site IO ()
anchorWidget getRoute getContent a = do
urlRender <- getUrlRender
a_ (HA.href (toValue (urlRender (getRoute a)))) (getContent a)
encodeListItems ::
(WidgetT site IO () -> WidgetT site IO ())
-> (WidgetT site IO () -> WidgetT site IO () -> WidgetT site IO ())
-> Colonnade Headed a (Cell site)
-> a
-> WidgetT site IO ()
encodeListItems ulWrap combine enc =
ulWrap . E.bothMonadic_ enc
(\(Cell ha hc) (Cell ba bc) ->
li_ (ha <> ba) (combine hc bc)
)
encodeDefinitionTable ::
Attribute
-> Colonnade Headed a (Cell site)
-> a
-> WidgetT site IO ()
encodeDefinitionTable attrs enc a = table_ attrs $ tbody_ mempty $
E.bothMonadic_ enc
(\theKey theValue -> tr_ mempty $ do
widgetFromCell td_ theKey
widgetFromCell td_ theValue
) a
encodeCellTable :: (Foldable f, E.Headedness h)
=> Attribute
-> Colonnade h a (Cell site)
-> f a
-> WidgetT site IO ()
encodeCellTable = encodeTable
(E.headednessPure mempty) mempty (const mempty) widgetFromCell
encodeWidgetTable :: (Foldable f, E.Headedness h)
=> Attribute
-> Colonnade h a (WidgetT site IO ())
-> f a
-> WidgetT site IO ()
encodeWidgetTable = encodeTable
(E.headednessPure mempty) mempty (const mempty) ($ mempty)
encodeTable ::
(Foldable f, E.Headedness h)
=> h Attribute
-> Attribute
-> (a -> Attribute)
-> ((Attribute -> WidgetT site IO () -> WidgetT site IO ()) -> c -> WidgetT site IO ())
-> Attribute
-> Colonnade h a c
-> f a
-> WidgetT site IO ()
encodeTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
table_ tableAttrs $ do
for_ E.headednessExtract $ \unhead ->
thead_ (unhead theadAttrs) $ do
E.headerMonadicGeneral_ colonnade (wrapContent th_)
tbody_ tbodyAttrs $ do
forM_ xs $ \x -> do
tr_ (trAttrs x) (E.rowMonadic_ colonnade (wrapContent td_) x)
widgetFromCell ::
(Attribute -> WidgetT site IO () -> WidgetT site IO ())
-> Cell site
-> WidgetT site IO ()
widgetFromCell f (Cell attrs contents) =
f attrs contents
tr_,tbody_,thead_,table_,td_,th_,ul_,li_,a_ ::
Attribute -> WidgetT site IO () -> WidgetT site IO ()
table_ = liftParent H.table
thead_ = liftParent H.thead
tbody_ = liftParent H.tbody
tr_ = liftParent H.tr
td_ = liftParent H.td
th_ = liftParent H.th
ul_ = liftParent H.ul
li_ = liftParent H.li
a_ = liftParent H.a
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 H.! attrs $ (bodyFunc render)
return (a,gwd { gwdBody = Body newBodyFunc })