module Text.Reform.Blaze.Common where
import Data.Monoid (mconcat, mempty, (<>))
import Data.Text.Lazy (Text)
import Text.Reform.Backend
import Text.Reform.Core
import Text.Reform.Generalized as G
import Text.Reform.Result (FormId, Result(Ok), unitRange)
import Text.Blaze.Html (Html, (!), toValue)
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes (type_, name, value)
import qualified Text.Blaze.Html5.Attributes as A
instance H.ToValue FormId where
toValue fid = toValue (show fid)
inputText :: (Monad m, FormError error, H.ToValue text) =>
(input -> Either error text)
-> text
-> Form m input error Html () text
inputText getInput initialValue = G.input getInput inputField initialValue
where
inputField i a = H.input ! type_ "text" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)
inputPassword :: (Monad m, FormError error, H.ToValue text) =>
(input -> Either error text)
-> text
-> Form m input error Html () text
inputPassword getInput initialValue = G.input getInput inputField initialValue
where
inputField i a = H.input ! type_ "password" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)
inputSubmit :: (Monad m, FormError error, H.ToValue text) =>
(input -> Either error text)
-> text
-> Form m input error Html () (Maybe text)
inputSubmit getInput initialValue = G.inputMaybe getInput inputField initialValue
where
inputField i a = H.input ! type_ "submit" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)
inputReset :: (Monad m, FormError error, H.ToValue text) =>
text
-> Form m input error Html () ()
inputReset lbl = G.inputNoData inputField lbl
where
inputField i a = H.input ! type_ "submit" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)
inputHidden :: (Monad m, FormError error, H.ToValue text) =>
(input -> Either error text)
-> text
-> Form m input error Html () text
inputHidden getInput initialValue = G.input getInput inputField initialValue
where
inputField i a = H.input ! type_ "hidden" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)
inputButton :: (Monad m, FormError error, H.ToValue text) =>
text
-> Form m input error Html () ()
inputButton label = G.inputNoData inputField label
where
inputField i a = H.input ! type_ "button" ! A.id (toValue i) ! name (toValue i) ! value (toValue a)
textarea :: (Monad m, FormError error, H.ToMarkup text) =>
(input -> Either error text)
-> Int
-> Int
-> text
-> Form m input error Html () text
textarea getInput cols rows initialValue = G.input getInput textareaView initialValue
where
textareaView i txt =
H.textarea ! A.rows (toValue rows)
! A.cols (toValue cols)
! A.id (toValue i)
! A.name (toValue i) $
H.toHtml txt
inputFile :: (Monad m, FormError error, FormInput input, ErrorInputType error ~ input) =>
Form m input error Html () (FileType input)
inputFile = G.inputFile fileView
where
fileView i = H.input ! type_ "file" ! A.id (toValue i) ! name (toValue i)
buttonSubmit :: (Monad m, FormError error, H.ToValue text, H.ToMarkup children) =>
(input -> Either error text)
-> text
-> children
-> Form m input error Html () (Maybe text)
buttonSubmit getInput text c = G.inputMaybe getInput inputField text
where
inputField i a = H.button ! type_ "submit" ! A.id (toValue i) ! name (toValue i) ! value (toValue a) $ H.toHtml c
buttonReset :: (Monad m, FormError error, H.ToMarkup children) =>
children
-> Form m input error Html () ()
buttonReset c = G.inputNoData inputField Nothing
where
inputField i a = H.button ! type_ "reset" ! A.id (toValue i) ! name (toValue i) $ H.toHtml c
button :: (Monad m, FormError error, H.ToMarkup children) =>
children
-> Form m input error Html () ()
button c = G.inputNoData inputField Nothing
where
inputField i a = H.button ! type_ "button" ! A.id (toValue i) ! name (toValue i) $ H.toHtml c
label :: (Monad m, H.ToMarkup children) =>
children
-> Form m input error Html () ()
label c = G.label mkLabel
where
mkLabel i = H.label ! A.for (toValue i) $ H.toHtml c
inputCheckbox :: forall x error input m. (Monad m, FormInput input, FormError error, ErrorInputType error ~ input) =>
Bool
-> Form m input error Html () Bool
inputCheckbox initiallyChecked =
Form $
do i <- getFormId
v <- getFormInput' i
case v of
Default -> mkCheckbox i initiallyChecked
Missing -> mkCheckbox i False
(Found input) ->
case getInputString input of
(Right _) -> mkCheckbox i True
(Left (e :: error) ) -> mkCheckbox i False
where
mkCheckbox i checked =
let checkbox = H.input ! type_ "checkbox" ! A.id (toValue i) ! name (toValue i) ! value (toValue i)
checkbox' = if checked then checkbox ! A.checked "checked" else checkbox
in
return ( View $ const $ checkbox'
, return $ Ok (Proved { proofs = ()
, pos = unitRange i
, unProved = if checked then True else False
})
)
inputCheckboxes :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, H.ToMarkup lbl) =>
[(a, lbl)]
-> (a -> Bool)
-> Form m input error Html () [a]
inputCheckboxes choices isChecked =
G.inputMulti choices mkCheckboxes isChecked
where
mkCheckboxes nm choices' = mconcat $ concatMap (mkCheckbox nm) choices'
mkCheckbox nm (i, val, lbl, checked) =
[ ((if checked then (! A.checked "checked") else id) $
H.input ! type_ "checkbox" ! A.id (toValue i) ! name (toValue nm) ! value (toValue val))
, H.label ! A.for (toValue i) $ H.toHtml lbl
]
inputRadio :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, H.ToMarkup lbl) =>
[(a, lbl)]
-> (a -> Bool)
-> Form m input error Html () a
inputRadio choices isDefault =
G.inputChoice isDefault choices mkRadios
where
mkRadios nm choices' = mconcat $ concatMap (mkRadio nm) choices'
mkRadio nm (i, val, lbl, checked) =
[ ((if checked then (! A.checked "checked") else id) $
H.input ! type_ "radio" ! A.id (toValue i) ! name (toValue nm) ! value (toValue val))
, H.label ! A.for (toValue i) $ H.toHtml lbl
, H.br
]
select :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, H.ToMarkup lbl) =>
[(a, lbl)]
-> (a -> Bool)
-> Form m input error Html () a
select choices isDefault =
G.inputChoice isDefault choices mkSelect
where
mkSelect nm choices' =
H.select ! name (toValue nm) $
mconcat $ map mkOption choices'
mkOption (_, val, lbl, selected) =
(if selected then (! A.selected "selected") else id)
H.option ! value (toValue val) $ H.toHtml lbl
selectMultiple :: (Functor m, Monad m, FormError error, ErrorInputType error ~ input, FormInput input, H.ToMarkup lbl) =>
[(a, lbl)]
-> (a -> Bool)
-> Form m input error Html () [a]
selectMultiple choices isSelected =
G.inputMulti choices mkSelect isSelected
where
mkSelect nm choices' =
H.select ! name (toValue nm) ! A.multiple "multiple" $
mconcat $ map mkOption choices'
mkOption (_, val, lbl, selected) =
(if selected then (! A.selected "selected") else id)
H.option ! value (toValue val) $ H.toHtml lbl
errorList :: (Monad m, H.ToMarkup error) =>
Form m input error Html () ()
errorList = G.errors mkErrors
where
mkErrors [] = mempty
mkErrors errs =
H.ul ! A.class_ "reform-error-list" $
mconcat $ map mkError errs
mkError e = H.li $ H.toHtml e
childErrorList :: (Monad m, H.ToMarkup error) =>
Form m input error Html () ()
childErrorList = G.childErrors mkErrors
where
mkErrors [] = mempty
mkErrors errs =
H.ul ! A.class_ "reform-error-list" $
mconcat $ map mkError errs
mkError e = H.li $ H.toHtml e
br :: (Monad m) => Form m input error Html () ()
br = view H.br
fieldset :: (Monad m, Functor m) =>
Form m input error Html proof a
-> Form m input error Html proof a
fieldset frm = mapView (H.fieldset ! A.class_ "reform") frm
ol :: (Monad m, Functor m) =>
Form m input error Html proof a
-> Form m input error Html proof a
ol frm = mapView (H.ol ! A.class_ "reform") frm
ul :: (Monad m, Functor m) =>
Form m input error Html proof a
-> Form m input error Html proof a
ul frm = mapView (H.ul ! A.class_ "reform") frm
li :: (Monad m, Functor m) =>
Form m input error Html proof a
-> Form m input error Html proof a
li frm = mapView (H.li ! A.class_ "reform") frm
form :: (H.ToValue action) =>
action
-> [(Text, Text)]
-> Html
-> Html
form action hidden children =
H.form ! A.action (toValue action) ! A.method "POST" ! A.enctype "multipart/form-data" $
((mconcat $ map mkHidden hidden) <> children)
where
mkHidden (nm, val) =
H.input ! type_ "hidden" ! name (toValue nm) ! value (toValue val)
setAttr :: (Monad m, Functor m) =>
Form m input error Html proof a
-> H.Attribute
-> Form m input error Html proof a
setAttr form attr = mapView (\e -> e ! attr) form