module Text.Digestive.Lucid.Html5
( inputText
, inputTextArea
, inputPassword
, inputHidden
, inputSelect
, inputSelectGroup
, inputRadio
, inputCheckbox
, inputFile
, inputSubmit
, inputWithType
, label
, form
, errorList
, childErrorList
, ifSingleton
) where
import Control.Monad (forM_, when)
import Data.Text (Text, pack)
import Lucid
import Text.Digestive.View
ifSingleton :: Bool -> a -> [a]
ifSingleton False _ = []
ifSingleton True a = [a]
inputText :: Monad m => Text -> View v -> HtmlT m ()
inputText = inputWithType "text" []
inputTextArea :: ( Monad m
) => Maybe Int
-> Maybe Int
-> Text
-> View (HtmlT m ())
-> HtmlT m ()
inputTextArea r c ref view = textarea_
([ id_ ref'
, name_ ref'
] ++ rows' r ++ cols' c) $
toHtmlRaw $ fieldInputText ref view
where
ref' = absoluteRef ref view
rows' (Just x) = [rows_ $ pack $ show x]
rows' _ = []
cols' (Just x) = [cols_ $ pack $ show x]
cols' _ = []
inputPassword :: Monad m => Text -> View v -> HtmlT m ()
inputPassword = inputWithType "password" []
inputHidden :: Monad m => Text -> View v -> HtmlT m ()
inputHidden = inputWithType "hidden" []
inputSelect :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
inputSelect ref view = select_
[ id_ ref'
, name_ ref'
] $ forM_ choices $ \(i, c, sel) -> option_
(value_ (value i) : ifSingleton sel (selected_ "selected")) c
where
ref' = absoluteRef ref view
value i = ref' `mappend` "." `mappend` i
choices = fieldInputChoice ref view
inputSelectGroup :: Monad m => Text -> View (Lucid.HtmlT m ()) -> HtmlT m ()
inputSelectGroup ref view = Lucid.select_
[ id_ ref'
, name_ ref'
] $ forM_ choices $ \(groupName, subChoices) -> optgroup_ [label_ groupName] $
forM_ subChoices $ \(i, c, sel) -> option_
(value_ (value i) : ifSingleton sel (selected_ "selected")) c
where
ref' = absoluteRef ref view
value i = ref' `mappend` "." `mappend` i
choices = fieldInputChoiceGroup ref view
inputWithType
:: Monad m
=> Text
-> [Attribute]
-> Text
-> View v
-> HtmlT m ()
inputWithType ty additionalAttrs ref view = input_ attrs
where
ref' = absoluteRef ref view
attrs = defAttrs `mappend` additionalAttrs
defAttrs =
[ type_ ty
, id_ ref'
, name_ ref'
, value_ $ fieldInputText ref view
]
inputRadio :: ( Monad m
) => Bool
-> Text
-> View (HtmlT m ())
-> HtmlT m ()
inputRadio brs ref view = forM_ choices $ \(i, c, sel) -> do
let val = value i
input_ $ [type_ "radio", value_ val, id_ val, name_ ref']
++ ifSingleton sel checked_
label_ [for_ val] c
when brs (br_ [])
where
ref' = absoluteRef ref view
value i = ref' `mappend` "." `mappend` i
choices = fieldInputChoice ref view
inputCheckbox :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
inputCheckbox ref view = input_ $
[ type_ "checkbox"
, id_ ref'
, name_ ref'
] ++ ifSingleton selected checked_
where
ref' = absoluteRef ref view
selected = fieldInputBool ref view
inputFile :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
inputFile ref view = input_
[ type_ "file"
, id_ ref'
, name_ ref'
]
where
ref' = absoluteRef ref view
inputSubmit :: Monad m => Text -> HtmlT m ()
inputSubmit value = input_
[ type_ "submit"
, value_ value
]
label :: Monad m => Text -> View v -> HtmlT m () -> HtmlT m ()
label ref view = label_
[ for_ ref'
]
where
ref' = absoluteRef ref view
form :: Monad m => View (HtmlT m ()) -> Text -> HtmlT m () -> HtmlT m ()
form view action = form_
[ method_ "POST"
, enctype_ (pack $ show $ viewEncType view)
, action_ action
]
errorList :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
errorList ref view = case errors ref view of
[] -> mempty
errs -> ul_ [class_ "digestive-functors-error-list"] $ forM_ errs $ \e ->
li_ [class_ "digestive-functors-error"] e
childErrorList :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
childErrorList ref view = case childErrors ref view of
[] -> mempty
errs -> ul_ [class_ "digestive-functors-error-list"] $ forM_ errs $ \e ->
li_ [class_ "digestive-functors-error"] e