redo yesod-colonnade

blaze-colonnade/src/Text/Blaze/Colonnade.hs

@@ -296,6 +296,9 @@ lazyTextCell = textCell . LText.toStrict
 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 @\<tr\>@ elements.
 encodeTable ::
      (Foldable f, Foldable h)
   => Maybe Attribute -- ^ Attributes of @\<thead\>@, pass 'Nothing' to omit @\<thead\>@
@@ -315,6 +318,8 @@ encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
       forM_ xs $ \x -> do
         H.tr ! trAttrs x $ Encode.rowMonoidal colonnade (wrapContent H.td) x
 
+-- | Encode a table with a header. Table cells may have attributes
+--   applied to them.
 encodeHeadedCellTable :: 
      Foldable f
   => Attribute -- ^ Attributes of @\<table\>@ element
@@ -324,6 +329,8 @@ encodeHeadedCellTable ::
 encodeHeadedCellTable = encodeTable
   (Just mempty) mempty (const mempty) htmlFromCell 
 
+-- | Encode a table without a header. Table cells may have attributes
+--   applied to them.
 encodeHeadlessCellTable :: 
      Foldable f
   => Attribute -- ^ Attributes of @\<table\>@ element
@@ -333,6 +340,8 @@ encodeHeadlessCellTable ::
 encodeHeadlessCellTable = encodeTable
   Nothing mempty (const mempty) htmlFromCell 
 
+-- | Encode a table with a header. Table cells cannot have attributes
+--   applied to them.
 encodeHeadedHtmlTable :: 
      Foldable f
   => Attribute -- ^ Attributes of @\<table\>@ element
@@ -342,6 +351,8 @@ encodeHeadedHtmlTable ::
 encodeHeadedHtmlTable = encodeTable
   (Just mempty) mempty (const mempty) ($) 
 
+-- | Encode a table without a header. Table cells cannot have attributes
+--   applied to them.
 encodeHeadlessHtmlTable :: 
      Foldable f
   => Attribute -- ^ Attributes of @\<table\>@ element

colonnade/src/Colonnade.hs

@@ -42,7 +42,7 @@ import qualified Data.Vector as Vector
 -- >>> import Data.Monoid (mconcat,(<>))
 -- >>> import Data.Functor.Contravariant (contramap)
 --
--- Assume that the data we wish to encode is:
+-- The data types we wish to encode are:
 --
 -- >>> data Color = Red | Green | Blue deriving (Show,Eq)
 -- >>> data Person = Person { name :: String, age :: Int }
@@ -51,19 +51,19 @@ import qualified Data.Vector as Vector
 -- One potential columnar encoding of a @Person@ would be:
 --
 -- >>> :{
--- let encodingPerson :: Colonnade Headed String Person
+-- let colPerson :: Colonnade Headed String Person
---     encodingPerson = mconcat
+--     colPerson = mconcat
 --       [ headed "Name" name
 --       , headed "Age" (show . age)
 --       ]
 -- :}
 --
--- The type signature on @encodingPerson@ is not neccessary
+-- The type signature on @colPerson@ is not neccessary
 -- but is included for clarity. We can feed data into this encoding
 -- to build a table:
 --
 -- >>> let people = [Person "David" 63, Person "Ava" 34, Person "Sonia" 12]
--- >>> putStr (ascii encodingPerson people)
+-- >>> putStr (ascii colPerson people)
 -- +-------+-----+
 -- | Name  | Age |
 -- +-------+-----+
@@ -123,14 +123,14 @@ singleton h = Colonnade . Vector.singleton . OneColonnade h
 -- the help of 'fromMaybe':
 --
 -- >>> :{
--- let encodingOwners :: Colonnade Headed String (Person,Maybe House)
+-- let colOwners :: Colonnade Headed String (Person,Maybe House)
---     encodingOwners = mconcat
+--     colOwners = mconcat
---       [ contramap fst encodingPerson
+--       [ contramap fst colPerson
 --       , contramap snd (fromMaybe "" encodingHouse)
 --       ]
 -- :}
 --
--- >>> putStr (ascii encodingOwners owners)
+-- >>> putStr (ascii colOwners owners)
 -- +--------+-----+-------+---------+
 -- | Name   | Age | Color | Price   |
 -- +--------+-----+-------+---------+

yesod-colonnade/src/Yesod/Colonnade.hs

@@ -1,6 +1,10 @@
-{-# LANGUAGE TemplateHaskell #-}
+-- | Build HTML tables using @yesod@ and @colonnade@. To learn
-{-# LANGUAGE QuasiQuotes #-}
+--   how to use this module, first read the documentation for @colonnade@,
-
+--   and then read the documentation for @blaze-colonnade@. This library
+--   and @blaze-colonnade@ are entirely distinct; neither depends on the
+--   other. However, the interfaces they expose are very similar, and
+--   the explanations provided counterpart are sufficient to understand
+--   this library.
 module Yesod.Colonnade
   ( -- * Build
     Cell(..)
@@ -10,18 +14,25 @@ module Yesod.Colonnade
   , builderCell
   , anchorCell
     -- * Apply
-  , table
+  , encodeHeadedWidgetTable
-  , tableHeadless
+  , encodeHeadlessWidgetTable
-  , definitionTable
+  , encodeHeadedCellTable
-  , listItems
+  , encodeHeadlessCellTable
+  , encodeDefinitionTable
+  , encodeListItems
   ) where
 
 import Yesod.Core
+import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))
 import Colonnade (Colonnade,Headed,Headless)
 import Data.Text (Text)
 import Control.Monad
 import Data.Monoid
 import Data.String (IsString(..))
+import Text.Blaze (Attribute,toValue)
+import Data.Foldable
+import qualified Text.Blaze.Html5.Attributes as HA
+import qualified Text.Blaze.Html5 as H
 import qualified Colonnade.Encode as Encode
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as LText
@@ -30,7 +41,7 @@ import qualified Data.Text.Lazy.Builder as TBuilder
 -- | The attributes that will be applied to a @<td>@ and
 --   the HTML content that will go inside it.
 data Cell site = Cell
-  { cellAttrs :: ![(Text,Text)]
+  { cellAttrs :: !Attribute
   , cellContents :: !(WidgetT site IO ())
   }
 
@@ -38,12 +49,12 @@ instance IsString (Cell site) where
   fromString = stringCell
 
 instance Monoid (Cell site) where
-  mempty = Cell [] mempty
+  mempty = Cell mempty mempty
   mappend (Cell a1 c1) (Cell a2 c2) = Cell (mappend a1 a2) (mappend c1 c2)
 
 -- | Create a 'Cell' from a 'Widget'
 cell :: WidgetT site IO () -> Cell site
-cell = Cell []
+cell = Cell mempty
 
 -- | Create a 'Cell' from a 'String'
 stringCell :: String -> Cell site
@@ -58,20 +69,20 @@ builderCell :: TBuilder.Builder -> Cell site
 builderCell = cell . toWidget . toHtml . LText.toStrict . TBuilder.toLazyText
 
 -- | Creata a 'Cell' whose content is hyperlinked by wrapping
---   it in an @<a>@.
+--   it in an @\<a\>@.
 anchorCell :: 
      (a -> Route site) -- ^ Route that will go in @href@ attribute
-   -> (a -> WidgetT site IO ()) -- ^ Content wrapped by @<a>@ tag
+  -> (a -> WidgetT site IO ()) -- ^ Content wrapped by @<a>@ tag
   -> a -- ^ Value
   -> Cell site
 anchorCell getRoute getContent a = cell $ do
   urlRender <- getUrlRender
-  aTag [(Text.pack "href",urlRender (getRoute a))] (getContent a)
+  a_ (HA.href (toValue (urlRender (getRoute a)))) (getContent a)
 
 -- | This determines the attributes that are added
 --   to the individual @li@s by concatenating the header\'s
 --   attributes with the data\'s attributes. 
-listItems :: 
+encodeListItems :: 
      (WidgetT site IO () -> WidgetT site IO ())
      -- ^ Wrapper for items, often @ul@
   -> (WidgetT site IO () -> WidgetT site IO () -> WidgetT site IO ())
@@ -81,92 +92,116 @@ listItems ::
   -> a
      -- ^ The value to display
   -> WidgetT site IO ()
-listItems ulWrap combine enc =
+encodeListItems ulWrap combine enc =
   ulWrap . Encode.bothMonadic_ enc
     (\(Cell ha hc) (Cell ba bc) ->
-      li (ha ++ ba) (combine hc bc)
+      li_ (ha <> ba) (combine hc bc)
     )
 
 -- | A two-column table with the header content displayed in the
 --   first column and the data displayed in the second column. Note
 --   that the generated HTML table does not have a @thead@.
-definitionTable ::
+encodeDefinitionTable ::
-     [(Text,Text)]
+     Attribute
      -- ^ Attributes of @table@ element.
   -> Colonnade Headed (Cell site) a
      -- ^ How to encode data as a row
   -> a
      -- ^ The value to display
   -> WidgetT site IO ()
-definitionTable attrs enc a = tableEl attrs $ tbody [] $ 
+encodeDefinitionTable attrs enc a = table_ attrs $ tbody_ mempty $ 
   Encode.bothMonadic_ enc
-    (\theKey theValue -> tr [] $ do
+    (\theKey theValue -> tr_ mempty $ do
-      widgetFromCell td theKey
+      widgetFromCell td_ theKey
-      widgetFromCell td theValue
+      widgetFromCell td_ theValue
     ) a
 
 -- | If you are using the bootstrap css framework, then you may want
 --   to call this with the first argument as:
 --
---   > table [("class","table table-striped")] ...
+--   > encodeHeadedCellTable (HA.class_ "table table-striped") ...
-table :: Foldable f
+encodeHeadedCellTable :: Foldable f
-  => [(Text,Text)] -- ^ Attributes of @table@ element
+  => Attribute -- ^ Attributes of @table@ element
   -> Colonnade Headed (Cell site) a -- ^ How to encode data as a row
   -> f a -- ^ Rows of data
   -> WidgetT site IO ()
-table attrs enc xs = tableEl attrs $ do
+encodeHeadedCellTable = encodeTable
-  thead [] $ Encode.headerMonadic enc (widgetFromCell th)
+  (Just mempty) mempty (const mempty) widgetFromCell 
-  tableBody enc xs
 
-tableHeadless :: Foldable f
+encodeHeadlessCellTable :: Foldable f
-  => [(Text,Text)] -- ^ Attributes of @table@ element
+  => Attribute -- ^ Attributes of @table@ element
-  -> Colonnade Headless (Cell site) a -- ^ How to encode data as a row
+  -> Colonnade Headless (Cell site) a -- ^ How to encode data as columns
   -> f a -- ^ Rows of data
   -> WidgetT site IO ()
-tableHeadless attrs enc xs = tableEl attrs $ tableBody enc xs
+encodeHeadlessCellTable = encodeTable
+  Nothing mempty (const mempty) widgetFromCell 
 
-tableBody :: Foldable f
+encodeHeadedWidgetTable :: Foldable f
-  => Colonnade h (Cell site) a -- ^ How to encode data as a row
+  => Attribute -- ^ Attributes of @table@ element
+  -> Colonnade Headed (WidgetT site IO ()) a -- ^ How to encode data as columns
   -> f a -- ^ Rows of data
   -> WidgetT site IO ()
-tableBody enc xs = tbody [] $ do
+encodeHeadedWidgetTable = encodeTable
-  forM_ xs $ \x -> do
+  (Just mempty) mempty (const mempty) ($ mempty)
-    tr [] $ Encode.rowMonadic enc (widgetFromCell td) x
+
+encodeHeadlessWidgetTable :: Foldable f
+  => Attribute -- ^ Attributes of @\<table\>@ element
+  -> Colonnade Headless (WidgetT site IO ()) a -- ^ How to encode data as columns
+  -> f a -- ^ Rows of data
+  -> WidgetT site IO ()
+encodeHeadlessWidgetTable = encodeTable
+  Nothing mempty (const mempty) ($ mempty) 
+
+-- | 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 @\<tr\>@ elements.
+encodeTable ::
+     (Foldable f, Foldable h)
+  => Maybe Attribute -- ^ Attributes of @\<thead\>@, pass 'Nothing' to omit @\<thead\>@
+  -> Attribute -- ^ Attributes of @\<tbody\>@ element
+  -> (a -> Attribute) -- ^ Attributes of each @\<tr\>@ element
+  -> ((Attribute -> WidgetT site IO () -> WidgetT site IO ()) -> c -> WidgetT site IO ()) -- ^ Wrap content and convert to 'Html'
+  -> Attribute -- ^ Attributes of @\<table\>@ element
+  -> Colonnade h c a -- ^ How to encode data as a row
+  -> f a -- ^ Collection of data
+  -> WidgetT site IO ()
+encodeTable mtheadAttrs tbodyAttrs trAttrs wrapContent tableAttrs colonnade xs =
+  table_ tableAttrs $ do
+    for_ mtheadAttrs $ \theadAttrs -> do
+      thead_ theadAttrs $ do
+        Encode.headerMonadicGeneral_ colonnade (wrapContent th_)
+    tbody_ tbodyAttrs $ do
+      forM_ xs $ \x -> do
+        tr_ (trAttrs x) (Encode.rowMonadic_ colonnade (wrapContent td_) x)
 
 widgetFromCell ::
-  ([(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ())
+  (Attribute -> WidgetT site IO () -> WidgetT site IO ())
   -> Cell site
   -> WidgetT site IO ()
 widgetFromCell f (Cell attrs contents) =
   f attrs contents
 
-tr,tbody,thead,tableEl,td,th,ul,li,aTag ::
+tr_,tbody_,thead_,table_,td_,th_,ul_,li_,a_ ::
-  [(Text,Text)] -> WidgetT site IO () -> WidgetT site IO ()
+  Attribute -> WidgetT site IO () -> WidgetT site IO ()
-tableEl str b = [whamlet|
+
-  <table *{str}>^{b}
+table_ = liftParent H.table
-|]
+thead_ = liftParent H.thead
-thead str b = [whamlet|
+tbody_ = liftParent H.tbody
-  <thead *{str}>^{b}
+tr_ = liftParent H.tr
-|]
+td_ = liftParent H.td
-tbody str b = [whamlet|
+th_ = liftParent H.th
-  <tbody *{str}>^{b}
+ul_ = liftParent H.ul
-|]
+li_ = liftParent H.li
-tr str b = [whamlet|
+a_ = liftParent H.a
-  <tr *{str}>^{b}
+
-|]
+liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a
-th str b = [whamlet|
+liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do
-  <th *{str}>^{b}
+  (a,gwd) <- f hdata
-|]
+  let Body bodyFunc = gwdBody gwd
-td str b = [whamlet|
+      newBodyFunc render =
-  <td *{str}>^{b}
+        el H.! attrs $ (bodyFunc render)
-|]
+  return (a,gwd { gwdBody = Body newBodyFunc })
-ul str b = [whamlet|
+
-  <ul *{str}>^{b}
+
-|]
+
-li str b = [whamlet|
-  <li *{str}>^{b}
-|]
-aTag str b = [whamlet|
-  <a *{str}>^{b}
-|]
 

yesod-colonnade/yesod-colonnade.cabal

@@ -1,5 +1,5 @@
 name:                yesod-colonnade
-version:             0.3
+version:             0.4
 synopsis:            Helper functions for using yesod with colonnade
 description:         Yesod and colonnade
 homepage:            https://github.com/andrewthad/colonnade#readme
@@ -19,8 +19,10 @@ library
   build-depends:
       base >= 4.7 && < 5
     , colonnade >= 1.0 && < 1.1
-    , yesod-core >= 1.4.0 && < 1.5
+    , yesod-core >= 1.4 && < 1.5
     , text >= 1.0 && < 1.3
+    , blaze-markup >= 0.7 && < 0.9
+    , blaze-html >= 0.8 && < 0.10
   default-language: Haskell2010
 
 source-repository head