--------------------------------------------------------------------------------
{-# LANGUAGE
OverloadedStrings
, ExtendedDefaultRules
#-}
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 -- ^ Rows
-> Maybe Int -- ^ Columns
-> Text -- ^ Form path
-> View (HtmlT m ()) -- ^ View
-> HtmlT m () -- ^ Resulting HTML
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
-------------------------------------------------------------------------------
-- | Creates a grouped select field using optgroup
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
-------------------------------------------------------------------------------
-- | More generic textual input field to support newer input types
-- like range, date, email, etc.
inputWithType
:: Monad m
=> Text
-- ^ Type
-> [Attribute]
-- ^ Additional attributes
-> 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 -- ^ Add @br@ tags?
-> Text -- ^ Form path
-> View (HtmlT m ()) -- ^ View
-> HtmlT m () -- ^ Resulting HTML
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