module Text.Digestive.Forms.Html
( FormHtmlConfig (..)
, FormEncType (..)
, FormHtml (..)
, createFormHtml
, createFormHtmlWith
, applyClasses
, defaultHtmlConfig
, emptyHtmlConfig
, renderFormHtml
, renderFormHtmlWith
) where
import Data.Monoid (Monoid (..))
import Data.List (intercalate)
import Control.Applicative ((<*>), pure)
import Control.Arrow ((&&&))
data FormHtmlConfig = FormHtmlConfig
{ htmlInputClasses :: [String]
, htmlSubmitClasses :: [String]
, htmlLabelClasses :: [String]
, htmlErrorClasses :: [String]
, htmlErrorListClasses :: [String]
} deriving (Show)
data FormEncType = UrlEncoded
| MultiPart
deriving (Eq)
instance Show FormEncType where
show UrlEncoded = "application/x-www-form-urlencoded"
show MultiPart = "multipart/form-data"
instance Monoid FormEncType where
mempty = UrlEncoded
mappend UrlEncoded x = x
mappend MultiPart _ = MultiPart
data FormHtml a = FormHtml
{ formEncType :: FormEncType
, formHtml :: FormHtmlConfig -> a
}
instance Monoid a => Monoid (FormHtml a) where
mempty = FormHtml mempty $ const mempty
mappend (FormHtml x f) (FormHtml y g) =
FormHtml (x `mappend` y) $ f `mappend` g
instance Functor FormHtml where
fmap f (FormHtml e g) = FormHtml e (f . g)
createFormHtml :: (FormHtmlConfig -> a) -> FormHtml a
createFormHtml = FormHtml mempty
createFormHtmlWith :: FormEncType -> (FormHtmlConfig -> a) -> FormHtml a
createFormHtmlWith = FormHtml
applyClasses :: (a -> String -> a)
-> [FormHtmlConfig -> [String]]
-> FormHtmlConfig
-> a
-> a
applyClasses applyAttribute fs cfg element = case concat (fs <*> pure cfg) of
[] -> element
classes -> applyAttribute element $ intercalate " " classes
defaultHtmlConfig :: FormHtmlConfig
defaultHtmlConfig = FormHtmlConfig
{ htmlInputClasses = ["digestive-input"]
, htmlSubmitClasses = ["digestive-submit"]
, htmlLabelClasses = ["digestive-label"]
, htmlErrorClasses = ["digestive-error"]
, htmlErrorListClasses = ["digestive-error-list"]
}
emptyHtmlConfig :: FormHtmlConfig
emptyHtmlConfig = FormHtmlConfig
{ htmlInputClasses = []
, htmlSubmitClasses = []
, htmlLabelClasses = []
, htmlErrorClasses = []
, htmlErrorListClasses = []
}
renderFormHtml :: FormHtml a -> (a, FormEncType)
renderFormHtml = renderFormHtmlWith defaultHtmlConfig
renderFormHtmlWith :: FormHtmlConfig -> FormHtml a -> (a, FormEncType)
renderFormHtmlWith cfg = ($ cfg) . formHtml &&& formEncType