{- | Build HTML tables using @yesod@ and @colonnade@. To learn
  how to use this module, first read the documentation for @colonnade@,
  and then read the documentation for @blaze-colonnade@. This library
  and @blaze-colonnade@ are entirely distinct; neither depends on the
  other. However, the interfaces they expose are very similar, and
  the explanations provided counterpart are sufficient to understand
  this library.
-}
module Yesod.Colonnade
  ( -- * Build
    Cell (..)
  , cell
  , stringCell
  , textCell
  , builderCell
  , anchorCell
  , anchorWidget

    -- * Apply
  , encodeWidgetTable
  , encodeCellTable
  , encodeDefinitionTable
  , encodeListItems
  ) where

import Colonnade (Colonnade, Headed)
import qualified Colonnade.Encode as E
import Control.Monad
import Data.Foldable
import qualified Data.Semigroup as SG
import Data.String (IsString (..))
import Data.Text (Text)
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Builder as TBuilder
import Text.Blaze (Attribute, toValue)
import qualified Text.Blaze.Html5.Attributes as HA
import Yesod.Core
import Yesod.Elements (a_, li_, table_, tbody_, td_, th_, thead_, tr_)

{- | The attributes that will be applied to a @<td>@ and
  the HTML content that will go inside it.
-}
data Cell site = Cell
  { forall site. Cell site -> [Attribute]
cellAttrs :: [Attribute]
  , forall site. Cell site -> WidgetFor site ()
cellContents :: !(WidgetFor site ())
  }

instance IsString (Cell site) where
  fromString :: String -> Cell site
fromString = String -> Cell site
forall site. String -> Cell site
stringCell

instance Semigroup (Cell site) where
  Cell [Attribute]
a1 WidgetFor site ()
c1 <> :: Cell site -> Cell site -> Cell site
<> Cell [Attribute]
a2 WidgetFor site ()
c2 = [Attribute] -> WidgetFor site () -> Cell site
forall site. [Attribute] -> WidgetFor site () -> Cell site
Cell ([Attribute] -> [Attribute] -> [Attribute]
forall a. Monoid a => a -> a -> a
mappend [Attribute]
a1 [Attribute]
a2) (WidgetFor site () -> WidgetFor site () -> WidgetFor site ()
forall a. Monoid a => a -> a -> a
mappend WidgetFor site ()
c1 WidgetFor site ()
c2)
instance Monoid (Cell site) where
  mempty :: Cell site
mempty = [Attribute] -> WidgetFor site () -> Cell site
forall site. [Attribute] -> WidgetFor site () -> Cell site
Cell [Attribute]
forall a. Monoid a => a
mempty WidgetFor site ()
forall a. Monoid a => a
mempty
  mappend :: Cell site -> Cell site -> Cell site
mappend = Cell site -> Cell site -> Cell site
forall a. Semigroup a => a -> a -> a
(SG.<>)

-- | Create a 'Cell' from a 'Widget'
cell :: WidgetFor site () -> Cell site
cell :: forall site. WidgetFor site () -> Cell site
cell = [Attribute] -> WidgetFor site () -> Cell site
forall site. [Attribute] -> WidgetFor site () -> Cell site
Cell [Attribute]
forall a. Monoid a => a
mempty

-- | Create a 'Cell' from a 'String'
stringCell :: String -> Cell site
stringCell :: forall site. String -> Cell site
stringCell = WidgetFor site () -> Cell site
forall site. WidgetFor site () -> Cell site
cell (WidgetFor site () -> Cell site)
-> (String -> WidgetFor site ()) -> String -> Cell site
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> WidgetFor site ()
forall a. IsString a => String -> a
fromString

-- | Create a 'Cell' from a 'Text'
textCell :: Text -> Cell site
textCell :: forall site. Text -> Cell site
textCell = WidgetFor site () -> Cell site
forall site. WidgetFor site () -> Cell site
cell (WidgetFor site () -> Cell site)
-> (Text -> WidgetFor site ()) -> Text -> Cell site
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ site) =>
Html -> m ()
toWidget (Html -> WidgetFor site ())
-> (Text -> Html) -> Text -> WidgetFor site ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
forall a. ToMarkup a => a -> Html
toHtml

-- | Create a 'Cell' from a text builder
builderCell :: TBuilder.Builder -> Cell site
builderCell :: forall site. Builder -> Cell site
builderCell = WidgetFor site () -> Cell site
forall site. WidgetFor site () -> Cell site
cell (WidgetFor site () -> Cell site)
-> (Builder -> WidgetFor site ()) -> Builder -> Cell site
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
forall (m :: * -> *).
(MonadWidget m, HandlerSite m ~ site) =>
Html -> m ()
toWidget (Html -> WidgetFor site ())
-> (Builder -> Html) -> Builder -> WidgetFor site ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
forall a. ToMarkup a => a -> Html
toHtml (Text -> Html) -> (Builder -> Text) -> Builder -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LText.toStrict (Text -> Text) -> (Builder -> Text) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TBuilder.toLazyText

{- | Create a 'Cell' whose content is hyperlinked by wrapping
  it in an @\<a\>@.
-}
anchorCell ::
  -- | Route that will go in @href@ attribute
  (a -> Route site) ->
  -- | Content wrapped by @<a>@ tag
  (a -> WidgetFor site ()) ->
  -- | Value
  a ->
  Cell site
anchorCell :: forall a site.
(a -> Route site) -> (a -> WidgetFor site ()) -> a -> Cell site
anchorCell a -> Route site
getRoute a -> WidgetFor site ()
getContent = WidgetFor site () -> Cell site
forall site. WidgetFor site () -> Cell site
cell (WidgetFor site () -> Cell site)
-> (a -> WidgetFor site ()) -> a -> Cell site
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Route site)
-> (a -> WidgetFor site ()) -> a -> WidgetFor site ()
forall a site.
(a -> Route site)
-> (a -> WidgetFor site ()) -> a -> WidgetFor site ()
anchorWidget a -> Route site
getRoute a -> WidgetFor site ()
getContent

{- | Create a widget whose content is hyperlinked by wrapping
  it in an @\<a\>@.
-}
anchorWidget ::
  -- | Route that will go in @href@ attribute
  (a -> Route site) ->
  -- | Content wrapped by @<a>@ tag
  (a -> WidgetFor site ()) ->
  -- | Value
  a ->
  WidgetFor site ()
anchorWidget :: forall a site.
(a -> Route site)
-> (a -> WidgetFor site ()) -> a -> WidgetFor site ()
anchorWidget a -> Route site
getRoute a -> WidgetFor site ()
getContent a
a = do
  Route site -> Text
urlRender <- WidgetFor site (Route site -> Text)
WidgetFor site (Route (HandlerSite (WidgetFor site)) -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
  [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
a_ [AttributeValue -> Attribute
HA.href (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (Route site -> Text
urlRender (a -> Route site
getRoute a
a)))] (a -> WidgetFor site ()
getContent a
a)

{- | This determines the attributes that are added
  to the individual @li@s by concatenating the header\'s
  attributes with the data\'s attributes.
-}
encodeListItems ::
  -- | Wrapper for items, often @ul@
  (WidgetFor site () -> WidgetFor site ()) ->
  -- | Combines header with data
  (WidgetFor site () -> WidgetFor site () -> WidgetFor site ()) ->
  -- | How to encode data as a row
  Colonnade Headed a (Cell site) ->
  -- | The value to display
  a ->
  WidgetFor site ()
encodeListItems :: forall site a.
(WidgetFor site () -> WidgetFor site ())
-> (WidgetFor site () -> WidgetFor site () -> WidgetFor site ())
-> Colonnade Headed a (Cell site)
-> a
-> WidgetFor site ()
encodeListItems WidgetFor site () -> WidgetFor site ()
ulWrap WidgetFor site () -> WidgetFor site () -> WidgetFor site ()
combine Colonnade Headed a (Cell site)
enc =
  WidgetFor site () -> WidgetFor site ()
ulWrap
    (WidgetFor site () -> WidgetFor site ())
-> (a -> WidgetFor site ()) -> a -> WidgetFor site ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colonnade Headed a (Cell site)
-> (Cell site -> Cell site -> WidgetFor site ())
-> a
-> WidgetFor site ()
forall (m :: * -> *) a c b.
Monad m =>
Colonnade Headed a c -> (c -> c -> m b) -> a -> m ()
E.bothMonadic_
      Colonnade Headed a (Cell site)
enc
      ( \(Cell [Attribute]
ha WidgetFor site ()
hc) (Cell [Attribute]
ba WidgetFor site ()
bc) ->
          [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
li_ ([Attribute]
ha [Attribute] -> [Attribute] -> [Attribute]
forall a. Semigroup a => a -> a -> a
<> [Attribute]
ba) (WidgetFor site () -> WidgetFor site () -> WidgetFor site ()
combine WidgetFor site ()
hc WidgetFor site ()
bc)
      )

{- | A two-column table with the header content displayed in the
  first column and the data displayed in the second column. Note
  that the generated HTML table does not have a @thead@.
-}
encodeDefinitionTable ::
  -- | Attributes of @table@ element.
  [Attribute] ->
  -- | How to encode data as a row
  Colonnade Headed a (Cell site) ->
  -- | The value to display
  a ->
  WidgetFor site ()
encodeDefinitionTable :: forall a site.
[Attribute]
-> Colonnade Headed a (Cell site) -> a -> WidgetFor site ()
encodeDefinitionTable [Attribute]
attrs Colonnade Headed a (Cell site)
enc a
a =
  [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
table_ [Attribute]
attrs (WidgetFor site () -> WidgetFor site ())
-> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$
    [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
tbody_ [] (WidgetFor site () -> WidgetFor site ())
-> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$
      Colonnade Headed a (Cell site)
-> (Cell site -> Cell site -> WidgetFor site ())
-> a
-> WidgetFor site ()
forall (m :: * -> *) a c b.
Monad m =>
Colonnade Headed a c -> (c -> c -> m b) -> a -> m ()
E.bothMonadic_
        Colonnade Headed a (Cell site)
enc
        ( \Cell site
theKey Cell site
theValue -> [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
tr_ [] (WidgetFor site () -> WidgetFor site ())
-> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ do
            ([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> Cell site -> WidgetFor site ()
forall site.
([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> Cell site -> WidgetFor site ()
widgetFromCell [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
td_ Cell site
theKey
            ([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> Cell site -> WidgetFor site ()
forall site.
([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> Cell site -> WidgetFor site ()
widgetFromCell [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
td_ Cell site
theValue
        )
        a
a

{- | Encode an html table with attributes on the table cells.
  If you are using the bootstrap css framework, then you may want
  to call this with the first argument as:

  > encodeCellTable (HA.class_ "table table-striped") ...
-}
encodeCellTable ::
  (Foldable f, E.Headedness h) =>
  -- | Attributes of @table@ element
  [Attribute] ->
  -- | How to encode data as a row
  Colonnade h a (Cell site) ->
  -- | Rows of data
  f a ->
  WidgetFor site ()
encodeCellTable :: forall (f :: * -> *) (h :: * -> *) a site.
(Foldable f, Headedness h) =>
[Attribute]
-> Colonnade h a (Cell site) -> f a -> WidgetFor site ()
encodeCellTable =
  h [Attribute]
-> [Attribute]
-> (a -> [Attribute])
-> (([Attribute] -> WidgetFor site () -> WidgetFor site ())
    -> Cell site -> WidgetFor site ())
-> [Attribute]
-> Colonnade h a (Cell site)
-> f a
-> WidgetFor site ()
forall (f :: * -> *) (h :: * -> *) a site c.
(Foldable f, Headedness h) =>
h [Attribute]
-> [Attribute]
-> (a -> [Attribute])
-> (([Attribute] -> WidgetFor site () -> WidgetFor site ())
    -> c -> WidgetFor site ())
-> [Attribute]
-> Colonnade h a c
-> f a
-> WidgetFor site ()
encodeTable
    ([Attribute] -> h [Attribute]
forall a. a -> h a
forall (h :: * -> *) a. Headedness h => a -> h a
E.headednessPure [Attribute]
forall a. Monoid a => a
mempty)
    [Attribute]
forall a. Monoid a => a
mempty
    ([Attribute] -> a -> [Attribute]
forall a b. a -> b -> a
const [Attribute]
forall a. Monoid a => a
mempty)
    ([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> Cell site -> WidgetFor site ()
forall site.
([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> Cell site -> WidgetFor site ()
widgetFromCell

-- | Encode an html table.
encodeWidgetTable ::
  (Foldable f, E.Headedness h) =>
  -- | Attributes of @\<table\>@ element
  [Attribute] ->
  -- | How to encode data as columns
  Colonnade h a (WidgetFor site ()) ->
  -- | Rows of data
  f a ->
  WidgetFor site ()
encodeWidgetTable :: forall (f :: * -> *) (h :: * -> *) a site.
(Foldable f, Headedness h) =>
[Attribute]
-> Colonnade h a (WidgetFor site ()) -> f a -> WidgetFor site ()
encodeWidgetTable =
  h [Attribute]
-> [Attribute]
-> (a -> [Attribute])
-> (([Attribute] -> WidgetFor site () -> WidgetFor site ())
    -> WidgetFor site () -> WidgetFor site ())
-> [Attribute]
-> Colonnade h a (WidgetFor site ())
-> f a
-> WidgetFor site ()
forall (f :: * -> *) (h :: * -> *) a site c.
(Foldable f, Headedness h) =>
h [Attribute]
-> [Attribute]
-> (a -> [Attribute])
-> (([Attribute] -> WidgetFor site () -> WidgetFor site ())
    -> c -> WidgetFor site ())
-> [Attribute]
-> Colonnade h a c
-> f a
-> WidgetFor site ()
encodeTable
    ([Attribute] -> h [Attribute]
forall a. a -> h a
forall (h :: * -> *) a. Headedness h => a -> h a
E.headednessPure [Attribute]
forall a. Monoid a => a
mempty)
    [Attribute]
forall a. Monoid a => a
mempty
    ([Attribute] -> a -> [Attribute]
forall a b. a -> b -> a
const [Attribute]
forall a. Monoid a => a
mempty)
    (([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ [Attribute]
forall a. Monoid a => a
mempty)

{- | Encode a table. This handles a very general case and
  is seldom needed by users. One of the arguments provided is
  used to add attributes to the generated @\<tr\>@ elements.
-}
encodeTable ::
  (Foldable f, E.Headedness h) =>
  -- | Attributes of @\<thead\>@
  h [Attribute] ->
  -- | Attributes of @\<tbody\>@ element
  [Attribute] ->
  -- | Attributes of each @\<tr\>@ element
  (a -> [Attribute]) ->
  -- | Wrap content and convert to 'Html'
  (([Attribute] -> WidgetFor site () -> WidgetFor site ()) -> c -> WidgetFor site ()) ->
  -- | Attributes of @\<table\>@ element
  [Attribute] ->
  -- | How to encode data as a row
  Colonnade h a c ->
  -- | Collection of data
  f a ->
  WidgetFor site ()
encodeTable :: forall (f :: * -> *) (h :: * -> *) a site c.
(Foldable f, Headedness h) =>
h [Attribute]
-> [Attribute]
-> (a -> [Attribute])
-> (([Attribute] -> WidgetFor site () -> WidgetFor site ())
    -> c -> WidgetFor site ())
-> [Attribute]
-> Colonnade h a c
-> f a
-> WidgetFor site ()
encodeTable h [Attribute]
theadAttrs [Attribute]
tbodyAttrs a -> [Attribute]
trAttrs ([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> c -> WidgetFor site ()
wrapContent [Attribute]
tableAttrs Colonnade h a c
colonnade f a
xs =
  [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
table_ [Attribute]
tableAttrs (WidgetFor site () -> WidgetFor site ())
-> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe (h [Attribute] -> [Attribute])
-> ((h [Attribute] -> [Attribute]) -> WidgetFor site ())
-> WidgetFor site ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (h [Attribute] -> [Attribute])
forall a. Maybe (h a -> a)
forall (h :: * -> *) a. Headedness h => Maybe (h a -> a)
E.headednessExtract (((h [Attribute] -> [Attribute]) -> WidgetFor site ())
 -> WidgetFor site ())
-> ((h [Attribute] -> [Attribute]) -> WidgetFor site ())
-> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ \h [Attribute] -> [Attribute]
unhead ->
      [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
thead_ (h [Attribute] -> [Attribute]
unhead h [Attribute]
theadAttrs) (WidgetFor site () -> WidgetFor site ())
-> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ do
        Colonnade h a c -> (c -> WidgetFor site ()) -> WidgetFor site ()
forall (m :: * -> *) (h :: * -> *) a c b.
(Monad m, Headedness h) =>
Colonnade h a c -> (c -> m b) -> m ()
E.headerMonadicGeneral_ Colonnade h a c
colonnade (([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> c -> WidgetFor site ()
wrapContent [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
th_)
    [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
tbody_ [Attribute]
tbodyAttrs (WidgetFor site () -> WidgetFor site ())
-> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ do
      f a -> (a -> WidgetFor site ()) -> WidgetFor site ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ f a
xs ((a -> WidgetFor site ()) -> WidgetFor site ())
-> (a -> WidgetFor site ()) -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ \a
x -> do
        [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
tr_ (a -> [Attribute]
trAttrs a
x) (Colonnade h a c
-> (c -> WidgetFor site ()) -> a -> WidgetFor site ()
forall (m :: * -> *) (f :: * -> *) a c b.
Monad m =>
Colonnade f a c -> (c -> m b) -> a -> m ()
E.rowMonadic_ Colonnade h a c
colonnade (([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> c -> WidgetFor site ()
wrapContent [Attribute] -> WidgetFor site () -> WidgetFor site ()
forall (t :: * -> *) site a.
Foldable t =>
t Attribute -> WidgetFor site a -> WidgetFor site a
td_) a
x)

widgetFromCell ::
  ([Attribute] -> WidgetFor site () -> WidgetFor site ()) ->
  Cell site ->
  WidgetFor site ()
widgetFromCell :: forall site.
([Attribute] -> WidgetFor site () -> WidgetFor site ())
-> Cell site -> WidgetFor site ()
widgetFromCell [Attribute] -> WidgetFor site () -> WidgetFor site ()
f (Cell [Attribute]
attrs WidgetFor site ()
contents) =
  [Attribute] -> WidgetFor site () -> WidgetFor site ()
f [Attribute]
attrs WidgetFor site ()
contents