Generate valid HTML from renderTable

This commit is contained in:
Michael Snoyman 2014-07-24 10:45:06 +03:00
parent 027dfa9d91
commit 99621c17b0

View File

@ -1,4 +1,5 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -356,15 +357,21 @@ type FormRender m a =
-> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()) -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
-- | Render a form into a series of tr tags. Note that, in order to allow
-- you to add extra rows to the table, this function does /not/ wrap up
-- the resulting HTML in a table tag; you must do that yourself.
renderTable aform fragment = do renderTable aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []
let widget = [whamlet| let widget = [whamlet|
$newline never $newline never
\#{fragment} $if null views
$forall view <- views \#{fragment}
$forall (isFirst, view) <- addIsFirst views
<tr :fvRequired view:.required :not $ fvRequired view:.optional> <tr :fvRequired view:.required :not $ fvRequired view:.optional>
<td> <td>
$if isFirst
\#{fragment}
<label for=#{fvId view}>#{fvLabel view} <label for=#{fvId view}>#{fvLabel view}
$maybe tt <- fvTooltip view $maybe tt <- fvTooltip view
<div .tooltip>#{tt} <div .tooltip>#{tt}
@ -373,6 +380,9 @@ $forall view <- views
<td .errors>#{err} <td .errors>#{err}
|] |]
return (res, widget) return (res, widget)
where
addIsFirst [] = []
addIsFirst (x:y) = (True, x) : map (False, ) y
-- | render a field inside a div -- | render a field inside a div
renderDivs = renderDivsMaybeLabels True renderDivs = renderDivsMaybeLabels True