module Text.Digestive.Blaze.Html5
( BlazeFormHtml
, inputText
, inputHidden
, inputTextArea
, inputTextRead
, inputPassword
, inputCheckBox
, inputRadio
, inputFile
, submit
, label
, errors
, childErrors
, inputList
, inputListJs
, module Text.Digestive.Forms.Html
) where
import Control.Monad (forM_, unless, when)
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty)
import Text.Blaze.Html5 (Html, (!), toValue, toHtml)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Digestive.Types
import Text.Digestive.Forms (FormInput (..))
import qualified Text.Digestive.Forms as Forms
import qualified Text.Digestive.Common as Common
import Text.Digestive.Forms.Html
type BlazeFormHtml = FormHtml Html
applyClasses' :: [FormHtmlConfig -> [String]]
-> FormHtmlConfig
-> Html
-> Html
applyClasses' = applyClasses $ \element value ->
element ! A.class_ (toValue value)
checked :: Bool -> Html -> Html
checked False x = x
checked True x = x ! A.checked "checked"
inputText :: (Monad m, Functor m, FormInput i f)
=> Formlet m i e BlazeFormHtml String
inputText = Forms.inputString $ \id' inp -> createFormHtml $ \cfg ->
applyClasses' [htmlInputClasses] cfg $
H.input ! A.type_ "text"
! A.name (toValue $ show id')
! A.id (toValue $ show id')
! A.value (toValue $ fromMaybe "" inp)
inputHidden :: (Monad m, Functor m, FormInput i f)
=> Formlet m i e BlazeFormHtml String
inputHidden = Forms.inputString $ \id' inp -> createFormHtml $ \cfg ->
applyClasses' [htmlInputClasses] cfg $
H.input ! A.type_ "hidden"
! A.name (toValue $ show id')
! A.id (toValue $ show id')
! A.value (toValue $ fromMaybe "" inp)
inputTextArea :: (Monad m, Functor m, FormInput i f)
=> Maybe Int
-> Maybe Int
-> Maybe String
-> Form m i e BlazeFormHtml String
inputTextArea r c = Forms.inputString $ \id' inp -> createFormHtml $ \cfg ->
applyClasses' [htmlInputClasses] cfg $ rows r $ cols c $
H.textarea ! A.name (toValue $ show id')
! A.id (toValue $ show id')
$ toHtml $ fromMaybe "" inp
where
rows Nothing = id
rows (Just x) = (! A.rows (toValue $ show x))
cols Nothing = id
cols (Just x) = (! A.cols (toValue $ show x))
inputTextRead :: (Monad m, Functor m, FormInput i f, Show a, Read a)
=> e
-> Maybe a
-> Form m i e BlazeFormHtml a
inputTextRead error' = flip Forms.inputRead error' $ \id' inp ->
createFormHtml $ \cfg -> applyClasses' [htmlInputClasses] cfg $
H.input ! A.type_ "text"
! A.name (toValue $ show id')
! A.id (toValue $ show id')
! A.value (toValue $ fromMaybe "" inp)
inputPassword :: (Monad m, Functor m, FormInput i f)
=> Form m i e BlazeFormHtml String
inputPassword = flip Forms.inputString Nothing $ \id' inp ->
createFormHtml $ \cfg -> applyClasses' [htmlInputClasses] cfg $
H.input ! A.type_ "password"
! A.name (toValue $ show id')
! A.id (toValue $ show id')
! A.value (toValue $ fromMaybe "" inp)
inputCheckBox :: (Monad m, Functor m, FormInput i f)
=> Bool
-> Form m i e BlazeFormHtml Bool
inputCheckBox inp = flip Forms.inputBool inp $ \id' inp' ->
createFormHtml $ \cfg -> applyClasses' [htmlInputClasses] cfg $
checked inp' $ H.input ! A.type_ "checkbox"
! A.name (toValue $ show id')
! A.id (toValue $ show id')
inputRadio :: (Monad m, Functor m, FormInput i f, Eq a)
=> Bool
-> a
-> [(a, Html)]
-> Form m i e BlazeFormHtml a
inputRadio br def choices = Forms.inputChoice toView def (map fst choices)
where
toView group id' sel val = createFormHtml $ \cfg -> do
applyClasses' [htmlInputClasses] cfg $ checked sel $
H.input ! A.type_ "radio"
! A.name (toValue $ show group)
! A.value (toValue id')
! A.id (toValue id')
H.label ! A.for (toValue id')
$ fromMaybe mempty $ lookup val choices
when br H.br
inputFile :: (Monad m, Functor m, FormInput i f)
=> Form m i e BlazeFormHtml (Maybe f)
inputFile = Forms.inputFile toView
where
toView id' = createFormHtmlWith MultiPart $ \cfg -> do
applyClasses' [htmlInputClasses] cfg $
H.input ! A.type_ "file"
! A.name (toValue $ show id')
! A.id (toValue $ show id')
submit :: Monad m
=> String
-> Form m i e BlazeFormHtml ()
submit text = view $ createFormHtml $ \cfg ->
applyClasses' [htmlInputClasses, htmlSubmitClasses] cfg $
H.input ! A.type_ "submit"
! A.value (toValue text)
label :: Monad m
=> String
-> Form m i e BlazeFormHtml ()
label string = Common.label $ \id' -> createFormHtml $ \cfg ->
applyClasses' [htmlLabelClasses] cfg $
H.label ! A.for (toValue $ show id')
$ toHtml string
errorList :: [Html] -> BlazeFormHtml
errorList errors' = createFormHtml $ \cfg -> unless (null errors') $
applyClasses' [htmlErrorListClasses] cfg $
H.ul $ forM_ errors' $ applyClasses' [htmlErrorClasses] cfg . H.li
errors :: Monad m
=> Form m i Html BlazeFormHtml ()
errors = Common.errors errorList
childErrors :: Monad m
=> Form m i Html BlazeFormHtml ()
childErrors = Common.childErrors errorList
inputList :: (Monad m, Functor m, FormInput i f)
=> Formlet m i e BlazeFormHtml Int
-> Formlet m i e BlazeFormHtml a
-> Formlet m i e BlazeFormHtml [a]
inputList hidden single d =
mapView (fmap addControls) $ Forms.inputList hidden s d
where
s def = mapView (fmap (H.div ! A.class_ "inputListItem")) $ single def
addControls form = do
H.div ! A.class_ "inputList" $ do
H.div $ do
H.input ! A.type_ "button"
! A.onclick "addItem(this); return false;"
! A.value "Add Item"
H.input ! A.type_ "button"
! A.onclick "removeItem(this); return false;"
! A.value "Remove Item"
form
inputListJs :: String
inputListJs = unlines
["// Requires that JQuery also be in scope"
,"function findInputList(button) {"
," var mainDiv = $(button).parent();"
," while ( !mainDiv.hasClass('inputList') ) {"
," mainDiv = $(mainDiv).parent();"
," }"
," return mainDiv;"
,"}"
,""
,"function findItems(button) {"
," return $('.inputListItem', findInputList(button));"
,"}"
,""
,"function addItem(button) {"
," var count = $(':hidden', findInputList(button))[0];"
," var items = findItems(button);"
," var item = $(items[items.length-1]);"
," var newItem = item.clone(true);"
," var i;"
,""
," // Increment counter"
," $(count).val(parseInt($(count).val())+1);"
,""
," // We have to change the raw html because IE doesn't allow the"
," // name field to be changed."
," newItem.html(newItem.html().replace(/fval\\[(\\d+\\.)*(\\d+)\\.(\\d+)\\]/g,"
," function(a, b, c, d) {"
," var newC = parseInt(c)+1;"
," return a.replace(/\\d+\\.\\d+\\]/, newC+'.'+d+']');"
," }"
," ));"
," newItem.appendTo(item.parent());"
,""
," // Copy the values of all children that had the name attribute set."
," // The direct html insertion does not preserve the most current"
," // values. It only preserves default values, so if we want values"
," // copied, we have to use an approach like this."
," var items2 = findItems(button);"
," var newLast = $(items2[items2.length-1]);"
," var c1 = $('[name]', item);"
," var c2 = $('[name]', newLast);"
," if ( c1.length == c2.length ) {"
," for ( i = 0; i < c1.length; i++ ) {"
," $(c2[i]).val($(c1[i]).val());"
," }"
," }"
,"}"
,""
,"function removeItem(button) {"
," var items = findItems(button);"
," if ( items.length > 1 ) {"
," var count = $(':hidden', findInputList(button))[0];"
," var item = $(items[items.length-1]);"
," item.remove();"
,""
," // Decrement counter"
," $(count).val(parseInt($(count).val())-1);"
," } else {"
," alert('Cannot remove any more rows');"
," }"
,"}"
]