mirror of
https://github.com/byteverse/colonnade.git
synced 2024-09-11 06:45:41 +03:00
improve docs
This commit is contained in:
parent
eb29b10c39
commit
9d03776c03
@ -24,6 +24,16 @@ library
|
||||
, text >= 1.0 && < 1.3
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite test
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: Main.hs
|
||||
build-depends:
|
||||
base >= 4.7 && <= 5
|
||||
, colonnade
|
||||
, doctest
|
||||
default-language: Haskell2010
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/andrewthad/colonnade
|
||||
|
@ -1,8 +1,8 @@
|
||||
-- | Build HTML tables using @blaze-html@ and @colonnade@.
|
||||
--
|
||||
-- | Build HTML tables using @blaze-html@ and @colonnade@.
|
||||
module Text.Blaze.Colonnade
|
||||
( -- * Apply
|
||||
-- $build
|
||||
( -- * Example
|
||||
-- $example
|
||||
-- * Apply
|
||||
encodeHeadedHtmlTable
|
||||
, encodeHeadlessHtmlTable
|
||||
, encodeHeadedCellTable
|
||||
@ -16,6 +16,8 @@ module Text.Blaze.Colonnade
|
||||
, textCell
|
||||
, lazyTextCell
|
||||
, builderCell
|
||||
-- * Interactive
|
||||
, prettyPrintTable
|
||||
-- * Discussion
|
||||
-- $discussion
|
||||
) where
|
||||
@ -28,6 +30,10 @@ import Control.Monad
|
||||
import Data.Monoid
|
||||
import Data.Foldable
|
||||
import Data.String (IsString(..))
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Char (isSpace)
|
||||
import qualified Data.List as List
|
||||
import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
|
||||
import qualified Text.Blaze as Blaze
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
@ -36,6 +42,143 @@ import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy as LText
|
||||
import qualified Data.Text.Lazy.Builder as TBuilder
|
||||
|
||||
-- $example
|
||||
-- We start with a few necessary imports and some example data
|
||||
-- types:
|
||||
--
|
||||
-- >>> :set -XOverloadedStrings
|
||||
-- >>> import Data.Monoid (mconcat,(<>))
|
||||
-- >>> import Data.Char (toLower)
|
||||
-- >>> import Data.Functor.Contravariant (Contravariant(contramap))
|
||||
-- >>> import Colonnade (Colonnade,Headed,Headless,headed)
|
||||
-- >>> import Text.Blaze.Html (Html, toHtml, toValue)
|
||||
-- >>> import qualified Colonnade as C
|
||||
-- >>> import qualified Text.Blaze.Html5 as H
|
||||
-- >>> data Department = Management | Sales | Engineering deriving (Show,Eq)
|
||||
-- >>> data Employee = Employee { name :: String, 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 Html Employee
|
||||
-- tableEmpA = mconcat
|
||||
-- [ headed "Name" $ \emp -> case department emp of
|
||||
-- Engineering -> H.strong (toHtml (name emp))
|
||||
-- _ -> toHtml (name emp)
|
||||
-- , headed "Age" (toHtml . show . age)
|
||||
-- ]
|
||||
-- :}
|
||||
--
|
||||
-- The type signature of @tableEmpA@ is inferrable but is written
|
||||
-- out for clarity in this example. Additionally, note that the first
|
||||
-- argument to 'headed' is of type 'Html', so @OverloadedStrings@ is
|
||||
-- necessary for the above example to compile. To avoid using this extension,
|
||||
-- it is possible to instead use 'toHtml' to convert a 'String' to 'Html'.
|
||||
-- Let\'s continue:
|
||||
--
|
||||
-- >>> let customAttrs = HA.class_ "stylish-table" <> HA.id "main-table"
|
||||
-- >>> prettyPrintTable (encodeHeadedHtmlTable customAttrs tableEmpA employees)
|
||||
-- <table class="stylish-table" id="main-table">
|
||||
-- <thead>
|
||||
-- <th>Name</th>
|
||||
-- <th>Age</th>
|
||||
-- </thead>
|
||||
-- <tbody>
|
||||
-- <tr>
|
||||
-- <td>Thaddeus</td>
|
||||
-- <td>34</td>
|
||||
-- </tr>
|
||||
-- <tr>
|
||||
-- <td><strong>Lucia</strong></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 'Html' 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 'Html' content and a set
|
||||
-- of attributes to be applied to its parent @<th>@ or @<td>@. 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 Cell Department
|
||||
-- tableDept = mconcat
|
||||
-- [ headed "Dept." $ \d -> Cell
|
||||
-- (HA.class_ (toValue (map toLower (show d))))
|
||||
-- (toHtml (show d))
|
||||
-- ]
|
||||
-- :}
|
||||
--
|
||||
-- We can try it out on a list of departments. We need to use
|
||||
-- 'encodeHeadedCellTable' instead of 'encodeHeadedHtmlTable':
|
||||
--
|
||||
-- >>> let twoDepts = [Sales,Management]
|
||||
-- >>> prettyPrintTable (encodeHeadedCellTable customAttrs tableDept twoDepts)
|
||||
-- <table class="stylish-table" id="main-table">
|
||||
-- <thead>
|
||||
-- <th>Dept.</th>
|
||||
-- </thead>
|
||||
-- <tbody>
|
||||
-- <tr>
|
||||
-- <td class="sales">Sales</td>
|
||||
-- </tr>
|
||||
-- <tr>
|
||||
-- <td class="management">Management</td>
|
||||
-- </tr>
|
||||
-- </tbody>
|
||||
-- </table>
|
||||
--
|
||||
-- We can take advantage of 'Colonnade'\'s 'Contravariant' instance to allow
|
||||
-- this to work on 'Employee'\'s instead:
|
||||
--
|
||||
-- >>> :t contramap
|
||||
-- contramap :: Contravariant f => (a -> b) -> f b -> f a
|
||||
-- >>> let tableEmpB = contramap department tableDept
|
||||
-- >>> :t tableEmpB
|
||||
-- tableEmpB :: Colonnade Headed Cell Employee
|
||||
-- >>> prettyPrintTable (encodeHeadedCellTable customAttrs tableEmpB employees)
|
||||
-- <table class="stylish-table" id="main-table">
|
||||
-- <thead>
|
||||
-- <th>Dept.</th>
|
||||
-- </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>
|
||||
|
||||
|
||||
-- $build
|
||||
--
|
||||
-- The 'Cell' type is used to build a 'Colonnade' that
|
||||
@ -91,10 +234,10 @@ encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
|
||||
H.table ! tableAttrs $ do
|
||||
for_ mtheadAttrs $ \theadAttrs -> do
|
||||
H.thead ! theadAttrs $ do
|
||||
Encode.headerMonadicGeneral_ colonnade (wrapContent H.th)
|
||||
Encode.headerMonoidalGeneral colonnade (wrapContent H.th)
|
||||
H.tbody ! tbodyAttrs $ do
|
||||
forM_ xs $ \x -> do
|
||||
H.tr ! trAttrs x $ Encode.rowMonadic_ colonnade (wrapContent H.td) x
|
||||
H.tr ! trAttrs x $ Encode.rowMonoidal colonnade (wrapContent H.td) x
|
||||
|
||||
encodeHeadedCellTable ::
|
||||
Foldable f
|
||||
@ -132,17 +275,75 @@ encodeHeadlessHtmlTable ::
|
||||
encodeHeadlessHtmlTable = encodeTable
|
||||
Nothing mempty (const mempty) ($)
|
||||
|
||||
tableBody :: Foldable f
|
||||
=> Colonnade h Cell a -- ^ How to encode data as a row
|
||||
-> f a -- ^ Rows of data
|
||||
-> Html
|
||||
tableBody enc xs = H.tbody $ do
|
||||
forM_ xs $ \x -> do
|
||||
H.tr $ Encode.rowMonadic enc (htmlFromCell H.td) x
|
||||
|
||||
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:)
|
||||
|
||||
prettyPrintTable :: Html -> IO ()
|
||||
prettyPrintTable = putStrLn
|
||||
. List.dropWhileEnd (== '\n')
|
||||
. removeWhitespaceAfterTag "td"
|
||||
. removeWhitespaceAfterTag "th"
|
||||
. removeWhitespaceAfterTag "strong"
|
||||
. Pretty.renderHtml
|
||||
|
||||
|
||||
-- $discussion
|
||||
--
|
||||
-- In this module, some of the functions for applying a 'Colonnade' to
|
||||
|
6
blaze-colonnade/test/Main.hs
Normal file
6
blaze-colonnade/test/Main.hs
Normal file
@ -0,0 +1,6 @@
|
||||
import Test.DocTest
|
||||
|
||||
main :: IO ()
|
||||
main = doctest
|
||||
[ "src/Text/Blaze/Colonnade.hs"
|
||||
]
|
@ -29,11 +29,13 @@ module Colonnade.Encode
|
||||
, rowMonadic
|
||||
, rowMonadic_
|
||||
, rowMonadicWith
|
||||
, rowMonoidal
|
||||
, header
|
||||
, headerMonadic
|
||||
, headerMonadic_
|
||||
, headerMonadicGeneral
|
||||
, headerMonadicGeneral_
|
||||
, headerMonoidalGeneral
|
||||
, bothMonadic_
|
||||
) where
|
||||
|
||||
@ -76,6 +78,15 @@ rowMonadic_ ::
|
||||
rowMonadic_ (Colonnade v) g a =
|
||||
forM_ v $ \e -> g (oneColonnadeEncode e a)
|
||||
|
||||
rowMonoidal ::
|
||||
Monoid m
|
||||
=> Colonnade h c a
|
||||
-> (c -> m)
|
||||
-> a
|
||||
-> m
|
||||
rowMonoidal (Colonnade v) g a =
|
||||
foldMap (\e -> g (oneColonnadeEncode e a)) v
|
||||
|
||||
rowMonadicWith ::
|
||||
(Monad m)
|
||||
=> b
|
||||
@ -120,6 +131,15 @@ headerMonadicGeneral_ ::
|
||||
headerMonadicGeneral_ (Colonnade v) g =
|
||||
Vector.mapM_ (mapM_ g . oneColonnadeHead) v
|
||||
|
||||
headerMonoidalGeneral ::
|
||||
(Monoid m, Foldable h)
|
||||
=> Colonnade h c a
|
||||
-> (c -> m)
|
||||
-> m
|
||||
headerMonoidalGeneral (Colonnade v) g =
|
||||
foldMap (foldMap g . oneColonnadeHead) v
|
||||
|
||||
|
||||
headerMonadic_ ::
|
||||
(Monad m)
|
||||
=> Colonnade Headed content a
|
||||
|
Loading…
Reference in New Issue
Block a user