@ tag
since she is an engineer.
One limitation of using 'Html' as the content
type of a 'Colonnade' is that we are unable to add attributes to
the @\@ and @\ | @ elements. This library provides the 'Cell' type
to work around this problem. A 'Cell' is just 'Html' content and a set
of attributes to be applied to its parent @ | @ or @ | @. To illustrate
how its use, another employee table will be built. This table will
contain a single column indicating the department of each employ. Each
cell will be assigned a class name based on the department. To start off,
let\'s build a table that encodes departments:
>>> :{
let tableDept :: Colonnade Headed Department Cell
tableDept = mconcat
[ headed "Dept." $ \d -> Cell
(HA.class_ (toValue (map toLower (show d))))
(toHtml (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]
>>> printVeryCompactHtml (encodeCellTable customAttrs tableDept twoDepts)
The attributes on the @\ | @ 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
>>> printVeryCompactHtml (encodeCellTable customAttrs tableEmpB employees)
Dept. |
Sales |
Engineering |
Management |
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 @\ | @.
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 Html
>>> :t tableEmpB
tableEmpB :: Colonnade Headed Employee Cell
We can upcast the content type with 'fmap'.
Monoidal append is then well-typed, and the resulting 'Colonnade'
can be applied to the employees:
>>> let tableEmpC = fmap htmlCell tableEmpA <> tableEmpB
>>> :t tableEmpC
tableEmpC :: Colonnade Headed Employee Cell
>>> printCompactHtml (encodeCellTable customAttrs tableEmpC employees)
Name |
Age |
Dept. |
Thaddeus |
34 |
Sales |
Lucia |
33 |
Engineering |
Pranav |
57 |
Management |
-}
{- $build
The 'Cell' type is used to build a 'Colonnade' that
has 'Html' content inside table cells and may optionally
have attributes added to the @\ | @ or @\ | @ elements
that wrap this HTML content.
-}
{- | The attributes that will be applied to a @\ | @ and
the HTML content that will go inside it. When using
this type, remember that 'Attribute', defined in @blaze-markup@,
is actually a collection of attributes, not a single attribute.
-}
data Cell = Cell
{ cellAttribute :: !Attribute
, cellHtml :: !Html
}
instance IsString Cell where
fromString = stringCell
instance Semigroup Cell where
(Cell a1 c1) <> (Cell a2 c2) = Cell (a1 <> a2) (c1 <> c2)
instance Monoid Cell where
mempty = Cell mempty mempty
mappend = (<>)
-- | Create a 'Cell' from a 'Widget'
htmlCell :: Html -> Cell
htmlCell = Cell mempty
-- | Create a 'Cell' from a 'String'
stringCell :: String -> Cell
stringCell = htmlCell . fromString
-- | Create a 'Cell' from a 'Char'
charCell :: Char -> Cell
charCell = stringCell . pure
-- | Create a 'Cell' from a 'Text'
textCell :: Text -> Cell
textCell = htmlCell . toHtml
-- | Create a 'Cell' from a lazy text
lazyTextCell :: LText.Text -> Cell
lazyTextCell = textCell . LText.toStrict
-- | Create a 'Cell' from a text builder
builderCell :: TBuilder.Builder -> Cell
builderCell = lazyTextCell . TBuilder.toLazyText
{- | 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 @\ | @ elements.
-}
encodeTable ::
forall h f a c.
(Foldable f, E.Headedness h) =>
-- | Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@
h (Attribute, Attribute) ->
-- | Attributes of @\
@ element
Attribute ->
-- | Attributes of each @\@ element
(a -> Attribute) ->
-- | Wrap content and convert to 'Html'
((Html -> Html) -> c -> Html) ->
-- | Attributes of @\@ element
Attribute ->
-- | How to encode data as a row
Colonnade h a c ->
-- | Collection of data
f a ->
Html
encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
H.table ! tableAttrs $ do
case E.headednessExtractForall of
Nothing -> return mempty
Just extractForall -> do
let (theadAttrs, theadTrAttrs) = extract mtheadAttrs
H.thead ! theadAttrs $ H.tr ! theadTrAttrs $ do
-- E.headerMonoidalGeneral colonnade (wrapContent H.th)
foldlMapM' (wrapContent H.th . extract . E.oneColonnadeHead) (E.getColonnade colonnade)
where
extract :: forall y. h y -> y
extract = E.runExtractForall extractForall
encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b
foldlMapM' f xs = foldr f' pure xs mempty
where
f' :: a -> (b -> m b) -> b -> m b
f' x k bl = do
br <- f x
let !b = mappend bl br
k b
{- | Encode a table with tiered header rows.
>>> let cor = mconcat [cap "Personal" (fmap htmlCell tableEmpA), cap "Work" tableEmpB]
>>> let fascia = FasciaCap (HA.class_ "category") (FasciaBase (HA.class_ "subcategory"))
>>> printCompactHtml (encodeCappedCellTable mempty fascia cor [head employees])
Personal |
Work |
Name |
Age |
Dept. |
Thaddeus |
34 |
Sales |
-}
encodeCappedCellTable ::
(Foldable f) =>
-- | Attributes of @\@ element
Attribute ->
-- | Attributes for @\@ elements in the @\@
Fascia p Attribute ->
Cornice Headed p a Cell ->
-- | Collection of data
f a ->
Html
encodeCappedCellTable = encodeCappedTable mempty mempty (const mempty) htmlFromCell
{- | Encode a table with tiered header rows. This is the most general function
in this library for encoding a 'Cornice'.
-}
encodeCappedTable ::
(Foldable f) =>
-- | Attributes of @\@
Attribute ->
-- | Attributes of @\
@ element
Attribute ->
-- | Attributes of each @\@ element in the @\
@
(a -> Attribute) ->
-- | Wrap content and convert to 'Html'
((Html -> Html) -> c -> Html) ->
-- | Attributes of @\@ element
Attribute ->
-- | Attributes for @\@ elements in the @\@
Fascia p Attribute ->
Cornice Headed p a c ->
-- | Collection of data
f a ->
Html
encodeCappedTable theadAttrs tbodyAttrs trAttrs wrapContent tableAttrs fascia cornice xs = do
let colonnade = E.discard cornice
annCornice = E.annotate cornice
H.table ! tableAttrs $ do
H.thead ! theadAttrs $ do
E.headersMonoidal
(Just (fascia, \attrs theHtml -> H.tr ! attrs $ theHtml))
[
( \msz c -> case msz of
Just sz -> wrapContent H.th c ! HA.colspan (H.toValue (show sz))
Nothing -> mempty
, id
)
]
annCornice
-- H.tr ! trAttrs $ do
-- E.headerMonoidalGeneral colonnade (wrapContent H.th)
encodeBody trAttrs wrapContent tbodyAttrs colonnade xs
encodeBody ::
(Foldable f) =>
-- | Attributes of each @\@ element
(a -> Attribute) ->
-- | Wrap content and convert to 'Html'
((Html -> Html) -> c -> Html) ->
-- | Attributes of @\
@ element
Attribute ->
-- | How to encode data as a row
Colonnade h a c ->
-- | Collection of data
f a ->
Html
encodeBody trAttrs wrapContent tbodyAttrs colonnade xs = do
H.tbody ! tbodyAttrs $ do
forM_ xs $ \x -> do
H.tr ! trAttrs x $ E.rowMonoidal colonnade (wrapContent H.td) x
{- | Encode a table. Table cells may have attributes
applied to them.
-}
encodeCellTable ::
(Foldable f) =>
-- | Attributes of @\@ element
Attribute ->
-- | How to encode data as columns
Colonnade Headed a Cell ->
-- | Collection of data
f a ->
Html
encodeCellTable =
encodeTable
(E.headednessPure (mempty, mempty))
mempty
(const mempty)
htmlFromCell
{- | Encode a table. Table cell element do not have
any attributes applied to them.
-}
encodeHtmlTable ::
(Foldable f, E.Headedness h) =>
-- | Attributes of @\@ element
Attribute ->
-- | How to encode data as columns
Colonnade h a Html ->
-- | Collection of data
f a ->
Html
encodeHtmlTable =
encodeTable
(E.headednessPure (mempty, mempty))
mempty
(const mempty)
($)
{- | Convert a 'Cell' to 'Html' by wrapping the content with a tag
and applying the 'Cell' attributes to that tag.
-}
htmlFromCell :: (Html -> Html) -> Cell -> Html
htmlFromCell f (Cell attr content) = f ! attr $ content
data St = St
{ _stContext :: [String]
, _stTagStatus :: TagStatus
, stResult :: String -> String
-- ^ difference list
}
data TagStatus
= TagStatusSomeTag
| TagStatusOpening (String -> String)
| TagStatusOpeningAttrs
| TagStatusNormal
| TagStatusClosing (String -> String)
| TagStatusAfterTag
removeWhitespaceAfterTag :: String -> String -> String
removeWhitespaceAfterTag chosenTag =
either id (\st -> stResult st "") . foldlM (flip f) (St [] TagStatusNormal id)
where
f :: Char -> St -> Either String St
f c (St ctx status res) = case status of
TagStatusNormal
| c == '<' -> Right (St ctx TagStatusSomeTag likelyRes)
| isSpace c ->
if Just chosenTag == listToMaybe ctx
then Right (St ctx TagStatusNormal res) -- drops the whitespace
else Right (St ctx TagStatusNormal likelyRes)
| otherwise -> Right (St ctx TagStatusNormal likelyRes)
TagStatusSomeTag
| c == '/' -> Right (St ctx (TagStatusClosing id) likelyRes)
| c == '>' -> Left "unexpected >"
| c == '<' -> Left "unexpected <"
| otherwise -> Right (St ctx (TagStatusOpening (c :)) likelyRes)
TagStatusOpening tag
| c == '>' -> Right (St (tag "" : ctx) TagStatusAfterTag likelyRes)
| isSpace c -> Right (St (tag "" : ctx) TagStatusOpeningAttrs likelyRes)
| otherwise -> Right (St ctx (TagStatusOpening (tag . (c :))) likelyRes)
TagStatusOpeningAttrs
| c == '>' -> Right (St ctx TagStatusAfterTag likelyRes)
| otherwise -> Right (St ctx TagStatusOpeningAttrs likelyRes)
TagStatusClosing tag
| c == '>' -> do
otherTags <- case ctx of
[] -> Left "closing tag without any opening tag"
closestTag : otherTags ->
if closestTag == tag ""
then Right otherTags
else Left $ "closing tag <" ++ tag "" ++ "> did not match opening tag <" ++ closestTag ++ ">"
Right (St otherTags TagStatusAfterTag likelyRes)
| otherwise -> Right (St ctx (TagStatusClosing (tag . (c :))) likelyRes)
TagStatusAfterTag
| c == '<' -> Right (St ctx TagStatusSomeTag likelyRes)
| isSpace c ->
if Just chosenTag == listToMaybe ctx
then Right (St ctx TagStatusAfterTag res) -- drops the whitespace
else Right (St ctx TagStatusNormal likelyRes)
| otherwise -> Right (St ctx TagStatusNormal likelyRes)
where
likelyRes :: String -> String
likelyRes = res . (c :)
{- | Pretty print an HTML table, stripping whitespace from inside @\@,
@\ | @, and common inline tags. The implementation is inefficient and is
incorrect in many corner cases. It is only provided to reduce the line
count of the HTML printed by GHCi examples in this module\'s documentation.
Use of this function is discouraged.
-}
printCompactHtml :: Html -> IO ()
printCompactHtml =
putStrLn
. List.dropWhileEnd (== '\n')
. removeWhitespaceAfterTag "td"
. removeWhitespaceAfterTag "th"
. removeWhitespaceAfterTag "strong"
. removeWhitespaceAfterTag "span"
. removeWhitespaceAfterTag "em"
. Pretty.renderHtml
{- | Similar to 'printCompactHtml'. Additionally strips all whitespace inside
@\ | @ elements and @\@ elements.
-}
printVeryCompactHtml :: Html -> IO ()
printVeryCompactHtml =
putStrLn
. List.dropWhileEnd (== '\n')
. removeWhitespaceAfterTag "td"
. removeWhitespaceAfterTag "th"
. removeWhitespaceAfterTag "strong"
. removeWhitespaceAfterTag "span"
. removeWhitespaceAfterTag "em"
. removeWhitespaceAfterTag "tr"
. Pretty.renderHtml
{- $discussion
In this module, some of the functions for applying a 'Colonnade' to
some values to build a table have roughly this type signature:
> Foldable a => Colonnade Headedness Cell a -> f a -> Html
The 'Colonnade' content type is 'Cell', but the content
type of the result is 'Html'. It may not be immidiately clear why
this is useful done. Another strategy, which this library also
uses, is to write
these functions to take a 'Colonnade' whose content is 'Html':
> Foldable a => Colonnade Headedness Html a -> f a -> Html
When the 'Colonnade' content type is 'Html', then the header
content is rendered as the child of a @\@ and the row
content the child of a @\ | @. However, it is not possible
to add attributes to these parent elements. To accomodate this
situation, it is necessary to introduce 'Cell', which includes
the possibility of attributes on the parent node.
-}
|