{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies #-}
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 -- ^ cols
-> Int -- ^ rows
-> text -- ^ initial 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
-- | Create an @\@ element
--
-- This control may succeed even if the user does not actually select a file to upload. In that case the uploaded name will likely be \"\" and the file contents will be empty as well.
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)
-- | Create a @\