module Text.Digestive.Foundation
( FormMeta (..), FormElement (..), FormElementCfg (..)
, StdMethod (..)
, renderForm
)
where
import Data.Maybe
import Data.Monoid
import Network.HTTP.Types.Method
import Lucid.Foundation
import Lucid
import Lucid.Base
import Text.Digestive
import Text.Digestive.Lucid.Html5
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
type NumberUnit = T.Text
data FormElementCfg = InputText
| InputNumber (Maybe NumberUnit)
| InputPassword
| InputTextArea (Maybe Int) (Maybe Int)
| InputHidden
| InputSelect
| InputRadio Bool
| InputCheckbox
| InputFile
| InputDate
data FormElement = FormElement
{ fe_name :: T.Text
, fe_label :: Maybe T.Text
, fe_cfg :: FormElementCfg
}
data FormMeta = FormMeta
{ fm_method :: StdMethod
, fm_target :: T.Text
, fm_elements :: [FormElement]
, fm_submitText :: T.Text
}
renderForm :: FormMeta -> View (Html ()) -> Html ()
renderForm formMeta formView =
form_ [ makeAttribute "role" "form"
, method_ formMethod
, action_ formAction
] $
do mconcat $ map (renderElement formView) (fm_elements formMeta)
input_ [type_ "submit", value_ (fm_submitText formMeta)]
where
formMethod = T.decodeUtf8 $ renderStdMethod (fm_method formMeta)
formAction = fm_target formMeta
renderElement :: View (Html ()) -> FormElement -> Html ()
renderElement formView formElement =
div_ [] $
do case errors (fe_name formElement) formView of
[] -> mempty
errorMsgs ->
div_ [class_ alert_box_] $ ul_ [] $ mapM_ (li_ []) errorMsgs
case fe_label formElement of
Just lbl ->
label_ [name_ $ fe_name formElement] $ toHtmlRaw lbl
Nothing ->
mempty
let ct = buildFun (fe_name formElement) formView
if hasAddon
then div_ [class_ "input-group"] (ct >>= \_ -> groupAddonAfter)
else ct
where
(hasAddon, groupAddonAfter) =
case fe_cfg formElement of
InputNumber (Just numberUnit) ->
(True, span_ [class_ "input-group-addon"] $ toHtmlRaw numberUnit)
_ ->
(False, mempty)
buildFun =
case fe_cfg formElement of
InputText -> inputText
InputPassword -> inputPassword
InputTextArea taRows taCols -> inputTextArea taRows taCols
InputHidden -> inputHidden
InputSelect -> inputSelect
InputRadio rBr -> inputRadio rBr
InputCheckbox -> inputCheckbox
InputFile -> inputFile
InputNumber _ -> inputX "number"
InputDate -> inputX "date"
inputX :: T.Text -> T.Text -> View v -> Html ()
inputX x ref view =
input_ $ [ type_ x
, id_ ref'
, name_ ref'
, value_ (fieldInputText ref view)
] ++ (ifSingleton (x == "number") $ step_ "any")
where
ref' = absoluteRef ref view