{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}


module WebView.Colonnade
  ( -- * What is this?
    -- $whatis
    -- * How to use this library
    -- $use

    -- * Encoding functions
    encodeHtmlTable
  , encodeCellTable
  , encodeTable
    -- * Cell
  , Cell(..)
  , charCell
  , stringCell
  , textCell
  , htmlCell
  , htmlFromCell
  ) where

import Colonnade (Colonnade)
import qualified Web.View.View as V
import qualified Web.View.Element as E
import qualified Colonnade.Encode as E
import qualified Data.Text as T
import Data.String (IsString(..))
import Data.Foldable (for_)
import Web.View.Types (Mod)

{- $whatis
  Build HTML tables using @web-view@ and @colonnade@. This module provides
  functionality similar to @lucid-colonnade@ and @blaze-colonnade@ but for the
  web-view library.
-}

{- $use

  = Usage

  We start with a few necessary imports and some example data types:

  >>> :set -XOverloadedStrings
  >>> import Data.Monoid (mconcat,(<>))
  >>> import Data.Char (toLower)
  >>  import qualified Data.Text as T
  >>> import Data.Profunctor (Profunctor(lmap))
  >>> import Colonnade (Colonnade,Headed,Headless,headed)
  >>> import Web.View
  >>> import qualified Web.View.Style as V 
  >>> import qualified Web.View.Types as V
  >>> data Department = Management | Sales | Engineering deriving (Show,Eq)
  >>> data Employee = Employee { name :: T.Text, department :: Department, age :: Int }

  We define some employees that we will display in a table:

  >>> :{
  let employees =
        [ Employee "Thaddeus" Sales 34
        , Employee "Lucia" Engineering 33
        , Employee "Pranav" Management 57
        ]
  :}

  Let's build a table that displays the name and the age
  of an employee. Additionally, we will emphasize the names of
  engineers using a @\<strong\>@ tag.

  >>> :{
  let tableEmpA :: Colonnade Headed Employee (View c ())
      tableEmpA = mconcat
        [ headed "Name" $ \emp -> case department emp of
            Engineering -> el bold (text (name emp))
            _ -> text (name emp)
        , headed "Age" (text . T.pack . show . age)
        ]
  :}

  The type signature of @tableEmpA@ is inferrable but is written
  out for clarity in this example. Note that the first
  argument to 'headed' can be passed as a string literal due to the @OverloadedStrings@ extension.
  Let's continue:

  >>> let customAttrs = V.extClass "stylish-table" <> V.att "id" "main-table"
  >>> renderText (encodeHtmlTable customAttrs tableEmpA employees)
  <table class='stylish-table' id='main-table'>
    <thead>
      <tr>
        <th>Name</th>
        <th>Age</th>
      </tr>
    </thead>
    <tbody>
      <tr>
        <td>Thaddeus</td>
        <td>34</td>
      </tr>
      <tr>
        <td><div class="bold">Lucia</div></td>
        <td>33</td>
      </tr>
      <tr>
        <td>Pranav</td>
        <td>57</td>
      </tr>
    </tbody>
  </table>

  Excellent. As expected, Lucia's name is wrapped in a @\<strong\>@ tag
  since she is an engineer.

  One limitation of using @View@ as the content
  type of a 'Colonnade' is that we are unable to add attributes to
  the @\<td\>@ and @\<th\>@ elements. This library provides the 'Cell' type
  to work around this problem. A 'Cell' is just a @V.View@ content and a set
  of attributes to be applied to its parent @\<th\>@ or @\<td\>@. To illustrate
  its use, another employee table will be built. This table will
  contain a single column indicating the department of each employee. Each
  cell will be assigned a class name based on the department. Let's build a table 
  that encodes departments:

  >>> :{
  let tableDept :: Colonnade Headed Department (Cell c)
      tableDept = mconcat
        [ headed "Dept." $ \d -> Cell
            (V.extClass (V.ClassName $ T.pack (map Data.Char.toLower (show d))))
            (E.text (T.pack (show d)))
        ]
  :}

  Again, @OverloadedStrings@ plays a role, this time allowing the
  literal @"Dept."@ to be accepted as a value of type 'Cell'. To avoid
  this extension, 'stringCell' could be used to upcast the 'String'.
  To try out our 'Colonnade' on a list of departments, we need to use
  'encodeCellTable' instead of 'encodeHtmlTable':

  >>> let twoDepts = [Sales,Management]
  >>> renderText (encodeCellTable customAttrs tableDept twoDepts)
  <table class='stylish-table' id='main-table'>
    <thead>
      <tr>
        <th>Dept.</th>
      </tr>
    </thead>
    <tbody>
      <tr>
        <td class='sales'>Sales</td>
      </tr>
      <tr>
        <td class='management'>Management</td>
      </tr>
    </tbody>
  </table>

  The attributes on the @\<td\>@ elements show up as they are expected to.
  Now, we take advantage of the @Profunctor@ instance of 'Colonnade' to allow
  this to work on @Employee@\'s instead:

  >>> :t lmap
  lmap :: Profunctor p => (a -> b) -> p b c -> p a c
  >>> let tableEmpB = lmap department tableDept
  >>> :t tableEmpB
  tableEmpB :: Colonnade Headed Employee (Cell c)
  >>> renderText (encodeCellTable customAttrs tableEmpB employees)
  <table class='stylish-table' id='main-table'>
    <thead>
      <tr>
        <th>Dept.</th>
      </tr>
    </thead>
    <tbody>
      <tr>
        <td class='sales'>Sales</td>
      </tr>
      <tr>
        <td class='engineering'>Engineering</td>
      </tr>
      <tr>
        <td class='management'>Management</td>
      </tr>
    </tbody>
  </table>

  This table shows the department of each of our three employees, additionally
  making a lowercased version of the department into a class name for the @\<td\>@.
  This table is nice for illustrative purposes, but it does not provide all the
  information that we have about the employees. If we combine it with the
  earlier table we wrote, we can present everything in the table. One small
  roadblock is that the types of @tableEmpA@ and @tableEmpB@ do not match, which
  prevents a straightforward monoidal append:

  >>> :t tableEmpA
  tableEmpA :: Colonnade Headed Employee (V.View c ())
  >>> :t tableEmpB
  tableEmpB :: Colonnade Headed Employee (Cell c)

  We can upcast the content type with 'fmap':

  >>> let tableEmpC = fmap htmlCell tableEmpA <> tableEmpB
  >>> :t tableEmpC
  tableEmpC :: Colonnade Headed Employee (Cell c)
  >>> renderText (encodeCellTable customAttrs tableEmpC employees)
  <table class='stylish-table' id='main-table'>
    <thead>
      <tr>
        <th>Name</th>
        <th>Age</th>
        <th>Dept.</th>
      </tr>
    </thead>
    <tbody>
      <tr>
        <td>Thaddeus</td>
        <td>34</td>
        <td class='sales'>Sales</td>
      </tr>
      <tr>
        <td><strong>Lucia</strong></td>
        <td>33</td>
        <td class='engineering'>Engineering</td>
      </tr>
      <tr>
        <td>Pranav</td>
        <td>57</td>
        <td class='management'>Management</td>
      </tr>
    </tbody>
  </table>
-}

-- | A table cell with attributes and content
data Cell c = Cell
  { forall c. Cell c -> Mod c
cellAttributes :: Mod c  -- ^ Attributes for the td/th element
  , forall c. Cell c -> View c ()
cellHtml :: V.View c ()      -- ^ Content inside the cell
  }

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

instance Semigroup (Cell c) where
  Cell Mod c
attrs1 View c ()
content1 <> :: Cell c -> Cell c -> Cell c
<> Cell Mod c
attrs2 View c ()
content2 = 
    Mod c -> View c () -> Cell c
forall c. Mod c -> View c () -> Cell c
Cell (Mod c
attrs1 Mod c -> Mod c -> Mod c
forall a. Semigroup a => a -> a -> a
<> Mod c
attrs2) (View c ()
content1 View c () -> View c () -> View c ()
forall a b. View c a -> View c b -> View c b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> View c ()
content2)

instance Monoid (Cell c) where
  mempty :: Cell c
mempty = Mod c -> View c () -> Cell c
forall c. Mod c -> View c () -> Cell c
Cell Mod c
forall a. Monoid a => a
mempty (() -> View c ()
forall a. a -> View c a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  mappend :: Cell c -> Cell c -> Cell c
mappend = Cell c -> Cell c -> Cell c
forall a. Semigroup a => a -> a -> a
(<>)

-- | Create a cell from HTML content
htmlCell :: V.View c () -> Cell c
htmlCell :: forall c. View c () -> Cell c
htmlCell View c ()
content = Mod c -> View c () -> Cell c
forall c. Mod c -> View c () -> Cell c
Cell Mod c
forall a. Monoid a => a
mempty View c ()
content

-- | Create a cell from a string
stringCell :: String -> Cell c
stringCell :: forall c. String -> Cell c
stringCell = View c () -> Cell c
forall c. View c () -> Cell c
htmlCell (View c () -> Cell c) -> (String -> View c ()) -> String -> Cell c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> View c ()
forall c. Text -> View c ()
E.text (Text -> View c ()) -> (String -> Text) -> String -> View c ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | Create a cell from a character
charCell :: Char -> Cell c
charCell :: forall c. Char -> Cell c
charCell = String -> Cell c
forall c. String -> Cell c
stringCell (String -> Cell c) -> (Char -> String) -> Char -> Cell c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Create a cell from text
textCell :: T.Text -> Cell c
textCell :: forall c. Text -> Cell c
textCell = View c () -> Cell c
forall c. View c () -> Cell c
htmlCell (View c () -> Cell c) -> (Text -> View c ()) -> Text -> Cell c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> View c ()
forall c. Text -> View c ()
E.text

-- | Convert a cell to an HTML element
htmlFromCell :: (Mod c -> V.View c () -> V.View c ()) -> (Cell c) -> V.View c ()
htmlFromCell :: forall c. (Mod c -> View c () -> View c ()) -> Cell c -> View c ()
htmlFromCell Mod c -> View c () -> View c ()
f (Cell Mod c
attrs View c ()
content) = Mod c -> View c () -> View c ()
f Mod c
attrs View c ()
content

-- | Encode a table with HTML content
encodeHtmlTable ::
  forall h f x c.
  (E.Headedness h, Foldable f) =>
  -- | Attributes of @\<table\>@ element
  Mod c ->
  -- | How to encode data as columns
  Colonnade h x (V.View c ()) ->
  -- | Collection of data
  f x ->
  V.View c ()
encodeHtmlTable :: forall (h :: * -> *) (f :: * -> *) x c.
(Headedness h, Foldable f) =>
Mod c -> Colonnade h x (View c ()) -> f x -> View c ()
encodeHtmlTable =
  h (Mod c, Mod c)
-> Mod c
-> (x -> Mod c)
-> ((Mod c -> View c () -> View c ()) -> View c () -> View c ())
-> Mod c
-> Colonnade h x (View c ())
-> f x
-> View c ()
forall (h :: * -> *) (f :: * -> *) x v c.
(Headedness h, Foldable f) =>
h (Mod c, Mod c)
-> Mod c
-> (x -> Mod c)
-> ((Mod c -> View c () -> View c ()) -> v -> View c ())
-> Mod c
-> Colonnade h x v
-> f x
-> View c ()
encodeTable
    ((Mod c, Mod c) -> h (Mod c, Mod c)
forall a. a -> h a
forall (h :: * -> *) a. Headedness h => a -> h a
E.headednessPure (Mod c
forall a. Monoid a => a
mempty, Mod c
forall a. Monoid a => a
mempty))
    Mod c
forall a. Monoid a => a
mempty
    (Mod c -> x -> Mod c
forall a b. a -> b -> a
const Mod c
forall a. Monoid a => a
mempty)
    (\Mod c -> View c () -> View c ()
tagFn View c ()
content -> Mod c -> View c () -> View c ()
tagFn Mod c
forall a. Monoid a => a
mempty View c ()
content)

-- | Encode a table with cells that may have attributes
encodeCellTable ::
  forall h f x c.
  (E.Headedness h, Foldable f) =>
  -- | Attributes of @\<table\>@ element
  Mod c ->
  -- | How to encode data as columns
  Colonnade h x (Cell c) ->
  -- | Collection of data
  f x ->
  V.View c ()
encodeCellTable :: forall (h :: * -> *) (f :: * -> *) x c.
(Headedness h, Foldable f) =>
Mod c -> Colonnade h x (Cell c) -> f x -> View c ()
encodeCellTable =
  h (Mod c, Mod c)
-> Mod c
-> (x -> Mod c)
-> ((Mod c -> View c () -> View c ()) -> Cell c -> View c ())
-> Mod c
-> Colonnade h x (Cell c)
-> f x
-> View c ()
forall (h :: * -> *) (f :: * -> *) x v c.
(Headedness h, Foldable f) =>
h (Mod c, Mod c)
-> Mod c
-> (x -> Mod c)
-> ((Mod c -> View c () -> View c ()) -> v -> View c ())
-> Mod c
-> Colonnade h x v
-> f x
-> View c ()
encodeTable
    ((Mod c, Mod c) -> h (Mod c, Mod c)
forall a. a -> h a
forall (h :: * -> *) a. Headedness h => a -> h a
E.headednessPure (Mod c
forall a. Monoid a => a
mempty, Mod c
forall a. Monoid a => a
mempty))
    Mod c
forall a. Monoid a => a
mempty
    (Mod c -> x -> Mod c
forall a b. a -> b -> a
const Mod c
forall a. Monoid a => a
mempty)
    (Mod c -> View c () -> View c ()) -> Cell c -> View c ()
forall c. (Mod c -> View c () -> View c ()) -> Cell c -> View c ()
htmlFromCell

{- | 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 ::
  forall h f x v c.
  (E.Headedness h, Foldable f) =>
  -- | Attributes and structure for header section
  h (Mod c, Mod c) ->
  -- | Attributes for tbody element
  Mod c ->
  -- | Attributes for each tr element
  (x -> Mod c) ->
  -- | Cell wrapper function
  ((Mod c -> V.View c () -> V.View c ()) -> v -> V.View c ()) ->
  -- | Table attributes
  Mod c ->
  -- | How to encode data as columns
  Colonnade h x v ->
  -- | Collection of data
  f x ->
  V.View c ()
encodeTable :: forall (h :: * -> *) (f :: * -> *) x v c.
(Headedness h, Foldable f) =>
h (Mod c, Mod c)
-> Mod c
-> (x -> Mod c)
-> ((Mod c -> View c () -> View c ()) -> v -> View c ())
-> Mod c
-> Colonnade h x v
-> f x
-> View c ()
encodeTable h (Mod c, Mod c)
mtheadAttrs Mod c
tbodyAttrs x -> Mod c
trAttrs (Mod c -> View c () -> View c ()) -> v -> View c ()
wrapContent Mod c
tableAttrs Colonnade h x v
colonnade f x
xs =
  Text -> Mod c -> View c () -> View c ()
forall c. Text -> Mod c -> View c () -> View c ()
V.tag Text
"table" Mod c
tableAttrs (View c () -> View c ()) -> View c () -> View c ()
forall a b. (a -> b) -> a -> b
$ do
    ()
d1 <- case Maybe (ExtractForall h)
forall (h :: * -> *). Headedness h => Maybe (ExtractForall h)
E.headednessExtractForall of
      Maybe (ExtractForall h)
Nothing -> () -> View c ()
forall a. a -> View c a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall a. Monoid a => a
mempty
      Just ExtractForall h
extractForall -> do
        let (Mod c
theadAttrs, Mod c
theadTrAttrs) = h (Mod c, Mod c) -> (Mod c, Mod c)
forall y. h y -> y
extract h (Mod c, Mod c)
mtheadAttrs
        Text -> Mod c -> View c () -> View c ()
forall c. Text -> Mod c -> View c () -> View c ()
V.tag Text
"thead" Mod c
theadAttrs (View c () -> View c ()) -> View c () -> View c ()
forall a b. (a -> b) -> a -> b
$
          Text -> Mod c -> View c () -> View c ()
forall c. Text -> Mod c -> View c () -> View c ()
V.tag Text
"tr" Mod c
theadTrAttrs (View c () -> View c ()) -> View c () -> View c ()
forall a b. (a -> b) -> a -> b
$ do
            (OneColonnade h x v -> View c ())
-> Vector (OneColonnade h x v) -> View c ()
forall (g :: * -> *) b a (m :: * -> *).
(Foldable g, Monoid b, Monad m) =>
(a -> m b) -> g a -> m b
foldlMapM' ((Mod c -> View c () -> View c ()) -> v -> View c ()
wrapContent (Text -> Mod c -> View c () -> View c ()
forall c. Text -> Mod c -> View c () -> View c ()
V.tag Text
"th") (v -> View c ())
-> (OneColonnade h x v -> v) -> OneColonnade h x v -> View c ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h v -> v
forall y. h y -> y
extract (h v -> v)
-> (OneColonnade h x v -> h v) -> OneColonnade h x v -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneColonnade h x v -> h v
forall (h :: * -> *) a c. OneColonnade h a c -> h c
E.oneColonnadeHead) (Colonnade h x v -> Vector (OneColonnade h x v)
forall (h :: * -> *) a c.
Colonnade h a c -> Vector (OneColonnade h a c)
E.getColonnade Colonnade h x v
colonnade)
        where
          extract :: forall y. h y -> y
          extract :: forall y. h y -> y
extract = ExtractForall h -> forall y. h y -> y
forall (h :: * -> *). ExtractForall h -> forall a. h a -> a
E.runExtractForall ExtractForall h
extractForall
    ()
d2 <- (x -> Mod c)
-> ((Mod c -> View c () -> View c ()) -> v -> View c ())
-> Mod c
-> Colonnade h x v
-> f x
-> View c ()
forall (f :: * -> *) a c v (h :: * -> *).
Foldable f =>
(a -> Mod c)
-> ((Mod c -> View c () -> View c ()) -> v -> View c ())
-> Mod c
-> Colonnade h a v
-> f a
-> View c ()
encodeBody x -> Mod c
trAttrs (Mod c -> View c () -> View c ()) -> v -> View c ()
wrapContent Mod c
tbodyAttrs Colonnade h x v
colonnade f x
xs
    () -> View c ()
forall a. a -> View c a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (()
d1 () -> () -> ()
forall a. Semigroup a => a -> a -> a
<> ()
d2)

foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b
foldlMapM' :: forall (g :: * -> *) b a (m :: * -> *).
(Foldable g, Monoid b, Monad m) =>
(a -> m b) -> g a -> m b
foldlMapM' a -> m b
f g a
xs = (a -> (b -> m b) -> b -> m b) -> (b -> m b) -> g a -> b -> m b
forall a b. (a -> b -> b) -> b -> g a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> (b -> m b) -> b -> m b
f' b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure g a
xs b
forall a. Monoid a => a
mempty
 where
  f' :: a -> (b -> m b) -> b -> m b
  f' :: a -> (b -> m b) -> b -> m b
f' a
x b -> m b
k b
bl = do
    b
br <- a -> m b
f a
x
    let !b :: b
b = b -> b -> b
forall a. Monoid a => a -> a -> a
mappend b
bl b
br
    b -> m b
k b
b

encodeBody ::
  (Foldable f) =>
  -- | Attributes of each @\<tr\>@ element
  (a -> Mod c) ->
  -- | Wrap content and convert to 'Html'
  ((Mod c -> V.View c () -> V.View c ()) -> v -> V.View c ()) ->
  -- | Attributes of @\<tbody\>@ element
  Mod c ->
  -- | How to encode data as a row
  Colonnade h a v ->
  -- | Collection of data
  f a ->
  V.View c ()
encodeBody :: forall (f :: * -> *) a c v (h :: * -> *).
Foldable f =>
(a -> Mod c)
-> ((Mod c -> View c () -> View c ()) -> v -> View c ())
-> Mod c
-> Colonnade h a v
-> f a
-> View c ()
encodeBody a -> Mod c
trAttrs (Mod c -> View c () -> View c ()) -> v -> View c ()
wrapContent Mod c
tbodyAttrs Colonnade h a v
colonnade f a
xs = do
  Text -> Mod c -> View c () -> View c ()
forall c. Text -> Mod c -> View c () -> View c ()
V.tag Text
"tbody" Mod c
tbodyAttrs (View c () -> View c ()) -> View c () -> View c ()
forall a b. (a -> b) -> a -> b
$ do
    f a -> (a -> View c ()) -> View c ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
xs ((a -> View c ()) -> View c ()) -> (a -> View c ()) -> View c ()
forall a b. (a -> b) -> a -> b
$ \a
x -> do
      Text -> Mod c -> View c () -> View c ()
forall c. Text -> Mod c -> View c () -> View c ()
V.tag Text
"tr" (a -> Mod c
trAttrs a
x) (View c () -> View c ()) -> View c () -> View c ()
forall a b. (a -> b) -> a -> b
$ do
        Colonnade h a v -> (v -> View c ()) -> a -> View c ()
forall (m :: * -> *) b (f :: * -> *) a c.
(Monad m, Monoid b) =>
Colonnade f a c -> (c -> m b) -> a -> m b
E.rowMonadic Colonnade h a v
colonnade ((Mod c -> View c () -> View c ()) -> v -> View c ()
wrapContent (Text -> Mod c -> View c () -> View c ()
forall c. Text -> Mod c -> View c () -> View c ()
V.tag Text
"td")) a
x