From 9d03776c03a3c4af3b275ec8b491a84de22af67b Mon Sep 17 00:00:00 2001 From: Andrew Martin Date: Mon, 6 Feb 2017 17:28:02 -0500 Subject: [PATCH] improve docs --- blaze-colonnade/blaze-colonnade.cabal | 10 + blaze-colonnade/src/Text/Blaze/Colonnade.hs | 229 ++++++++++++++++++-- blaze-colonnade/test/Main.hs | 6 + colonnade/src/Colonnade/Encode.hs | 20 ++ 4 files changed, 251 insertions(+), 14 deletions(-) create mode 100644 blaze-colonnade/test/Main.hs diff --git a/blaze-colonnade/blaze-colonnade.cabal b/blaze-colonnade/blaze-colonnade.cabal index 58811c8..45dd3b6 100644 --- a/blaze-colonnade/blaze-colonnade.cabal +++ b/blaze-colonnade/blaze-colonnade.cabal @@ -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 diff --git a/blaze-colonnade/src/Text/Blaze/Colonnade.hs b/blaze-colonnade/src/Text/Blaze/Colonnade.hs index 25de99f..ef3e41d 100644 --- a/blaze-colonnade/src/Text/Blaze/Colonnade.hs +++ b/blaze-colonnade/src/Text/Blaze/Colonnade.hs @@ -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 @@ 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) +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +--
NameAge
Thaddeus34
Lucia33
Pranav57
+-- +-- Excellent. As expected, Lucia\'s name is wrapped in a @@ 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 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) +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +--
Dept.
Sales
Management
+-- +-- 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) +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +-- +--
Dept.
Sales
Engineering
Management
+ + -- $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 diff --git a/blaze-colonnade/test/Main.hs b/blaze-colonnade/test/Main.hs new file mode 100644 index 0000000..1cadcff --- /dev/null +++ b/blaze-colonnade/test/Main.hs @@ -0,0 +1,6 @@ +import Test.DocTest + +main :: IO () +main = doctest + [ "src/Text/Blaze/Colonnade.hs" + ] diff --git a/colonnade/src/Colonnade/Encode.hs b/colonnade/src/Colonnade/Encode.hs index 7db967a..61017e3 100644 --- a/colonnade/src/Colonnade/Encode.hs +++ b/colonnade/src/Colonnade/Encode.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