{-# LANGUAGE OverloadedStrings #-} 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 Data.Text (Text) 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 -- | Form HTML generated by blaze -- type BlazeFormHtml = FormHtml Html -- | 'applyClasses' instantiated for blaze -- applyClasses' :: [FormHtmlConfig -> [String]] -- ^ Labels to apply -> FormHtmlConfig -- ^ Label configuration -> Html -- ^ HTML element -> Html -- ^ Resulting element applyClasses' = applyClasses $ \element value -> element ! A.class_ (toValue value) -- | Checks the input element when the argument is true -- checked :: Bool -> Html -> Html checked False x = x checked True x = x ! A.checked "checked" inputString :: (Monad m, Functor m, FormInput i f) => Formlet m i e BlazeFormHtml String inputString = 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) inputText :: (Monad m, Functor m, FormInput i f) => Formlet m i e BlazeFormHtml Text inputText = Forms.inputText $ \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 -- ^ Rows -> Maybe Int -- ^ Columns -> Maybe String -- ^ Default input -> Form m i e BlazeFormHtml String -- ^ Result 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 -- ^ Use @
@ tags -> a -- ^ Default option -> [(a, Html)] -- ^ Choices with their names -> Form m i e BlazeFormHtml a -- ^ Resulting form 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) -- ^ Form 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 -- ^ Text on the submit button -> Form m i e BlazeFormHtml () -- ^ Submit button 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 -- | Wraps the more generic 'Text.Digestive.Forms.inputList' function to -- provide a reasonable default for adding add/remove controls to a form. -- The whole thing is wrapped in another div with the class inputList. For -- this function to work, the javascript code in 'inputListJs' or something -- similar must be in scope. -- -- The user needs to specify the hidden formlet because transformRead requires -- an error parameter, and this function can't specify it without loss of -- generality. The idea is that the extra power of being able to customize -- the formlet is worth the small amount of extra code compared to having to -- specify the error. -- inputList :: (Monad m, Functor m, FormInput i f) => Formlet m i e BlazeFormHtml Int -- ^ The formlet holding the number of items in the list -> Formlet m i e BlazeFormHtml a -- ^ The formlet used for each list item. This function surrounds it -- with a div tag with the inputListItem class. -> Formlet m i e BlazeFormHtml [a] -- ^ The dynamic list formlet 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 -- | A string containing the javascript functions needed for inputList. This -- code requires JQuery. -- 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');" ," }" ,"}" ]