improve docs

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

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 @<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

blaze-colonnade/test/Main.hs

@@ -0,0 +1,6 @@
+import Test.DocTest
+
+main :: IO ()
+main = doctest
+  [ "src/Text/Blaze/Colonnade.hs"
+  ]

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