@ 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)
--
--
-- Dept. |
--
--
-- Sales |
-- Management |
--
--
--
-- 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)
=> h (Attribute,Attribute) -- ^ Attributes of @\@ and its @\@, pass 'Nothing' to omit @\@
-> Attribute -- ^ Attributes of @\
@ element
-> (a -> Attribute) -- ^ Attributes of each @\@ element
-> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
-> Attribute -- ^ Attributes of @\@ element
-> Colonnade h a c -- ^ How to encode data as a row
-> f a -- ^ Collection of data
-> 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
=> Attribute -- ^ Attributes of @\@ element
-> Fascia p Attribute -- ^ Attributes for @\@ elements in the @\@
-> Cornice Headed p a Cell
-> f a -- ^ Collection of data
-> 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
=> Attribute -- ^ Attributes of @\@
-> Attribute -- ^ Attributes of @\
@ element
-> (a -> Attribute) -- ^ Attributes of each @\@ element in the @\
@
-> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
-> Attribute -- ^ Attributes of @\@ element
-> Fascia p Attribute -- ^ Attributes for @\@ elements in the @\@
-> Cornice Headed p a c
-> f a -- ^ Collection of data
-> 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
=> (a -> Attribute) -- ^ Attributes of each @\@ element
-> ((Html -> Html) -> c -> Html) -- ^ Wrap content and convert to 'Html'
-> Attribute -- ^ Attributes of @\
@ element
-> Colonnade h a c -- ^ How to encode data as a row
-> f a -- ^ Collection of data
-> 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
=> Attribute -- ^ Attributes of @\@ element
-> Colonnade Headed a Cell -- ^ How to encode data as columns
-> f a -- ^ Collection of data
-> 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)
=> Attribute -- ^ Attributes of @\@ element
-> Colonnade h a Html -- ^ How to encode data as columns
-> f a -- ^ Collection of data
-> 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.
|