module Text.Digestive.Html
( FormHtmlConfig (..)
, FormHtml (..)
, applyClasses
, defaultHtmlConfig
, emptyHtmlConfig
, renderFormHtml
, renderFormHtmlWith
) where
import Data.Monoid (Monoid (..))
import Data.List (intercalate)
import Control.Applicative ((<*>), pure)
data FormHtmlConfig = FormHtmlConfig
{ htmlInputClasses :: [String]
, htmlLabelClasses :: [String]
, htmlErrorClasses :: [String]
, htmlErrorListClasses :: [String]
} deriving (Show)
newtype FormHtml a = FormHtml
{ unFormHtml :: FormHtmlConfig -> a
}
instance Monoid a => Monoid (FormHtml a) where
mempty = FormHtml $ const mempty
mappend (FormHtml x) (FormHtml y) = FormHtml $ \c -> mappend (x c) (y c)
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"]
, htmlLabelClasses = ["digestive-label"]
, htmlErrorClasses = ["digestive-error"]
, htmlErrorListClasses = ["digestive-error-list"]
}
emptyHtmlConfig :: FormHtmlConfig
emptyHtmlConfig = FormHtmlConfig
{ htmlInputClasses = []
, htmlLabelClasses = []
, htmlErrorClasses = []
, htmlErrorListClasses = []
}
renderFormHtml :: FormHtml a -> a
renderFormHtml = renderFormHtmlWith defaultHtmlConfig
renderFormHtmlWith :: FormHtmlConfig -> FormHtml a -> a
renderFormHtmlWith cfg = ($ cfg) . unFormHtml