module Yesod.Form.Fields
(
stringField
, passwordField
, textareaField
, hiddenField
, intField
, doubleField
, dayField
, timeField
, htmlField
, selectField
, radioField
, boolField
, emailField
, searchField
, urlField
, fileField
, maybeStringField
, maybePasswordField
, maybeTextareaField
, maybeHiddenField
, maybeIntField
, maybeDoubleField
, maybeDayField
, maybeTimeField
, maybeHtmlField
, maybeSelectField
, maybeRadioField
, maybeEmailField
, maybeSearchField
, maybeUrlField
, maybeFileField
, stringInput
, intInput
, boolInput
, dayInput
, emailInput
, urlInput
, maybeStringInput
, maybeDayInput
, maybeIntInput
) where
import Yesod.Form.Core
import Yesod.Form.Profiles
import Yesod.Request (FileInfo)
import Yesod.Widget (GWidget)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ask)
import Data.Time (Day, TimeOfDay)
import Text.Hamlet
import Data.Monoid
import Control.Monad (join)
import Data.Maybe (fromMaybe, isNothing)
import Data.Text (Text, unpack)
import qualified Data.Text as T
#if __GLASGOW_HASKELL__ >= 700
#define HAMLET hamlet
#else
#define HAMLET $hamlet
#endif
stringField :: (IsForm f, FormType f ~ Text)
=> FormFieldSettings -> Maybe Text -> f
stringField = requiredFieldHelper stringFieldProfile
maybeStringField :: (IsForm f, FormType f ~ Maybe Text)
=> FormFieldSettings -> Maybe (Maybe Text) -> f
maybeStringField = optionalFieldHelper stringFieldProfile
passwordField :: (IsForm f, FormType f ~ Text)
=> FormFieldSettings -> Maybe Text -> f
passwordField = requiredFieldHelper passwordFieldProfile
maybePasswordField :: (IsForm f, FormType f ~ Maybe Text)
=> FormFieldSettings -> Maybe (Maybe Text) -> f
maybePasswordField = optionalFieldHelper passwordFieldProfile
intInput :: Integral i => Text -> FormInput sub master i
intInput n =
mapFormXml fieldsToInput $
requiredFieldHelper intFieldProfile (nameSettings n) Nothing
maybeIntInput :: Integral i => Text -> FormInput sub master (Maybe i)
maybeIntInput n =
mapFormXml fieldsToInput $
optionalFieldHelper intFieldProfile (nameSettings n) Nothing
intField :: (Integral (FormType f), IsForm f)
=> FormFieldSettings -> Maybe (FormType f) -> f
intField = requiredFieldHelper intFieldProfile
maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f)
=> FormFieldSettings -> Maybe (FormType f) -> f
maybeIntField = optionalFieldHelper intFieldProfile
doubleField :: (IsForm f, FormType f ~ Double)
=> FormFieldSettings -> Maybe Double -> f
doubleField = requiredFieldHelper doubleFieldProfile
maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double)
=> FormFieldSettings -> Maybe (Maybe Double) -> f
maybeDoubleField = optionalFieldHelper doubleFieldProfile
dayField :: (IsForm f, FormType f ~ Day)
=> FormFieldSettings -> Maybe Day -> f
dayField = requiredFieldHelper dayFieldProfile
maybeDayField :: (IsForm f, FormType f ~ Maybe Day)
=> FormFieldSettings -> Maybe (Maybe Day) -> f
maybeDayField = optionalFieldHelper dayFieldProfile
timeField :: (IsForm f, FormType f ~ TimeOfDay)
=> FormFieldSettings -> Maybe TimeOfDay -> f
timeField = requiredFieldHelper timeFieldProfile
maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay)
=> FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f
maybeTimeField = optionalFieldHelper timeFieldProfile
boolField :: (IsForm f, FormType f ~ Bool)
=> FormFieldSettings -> Maybe Bool -> f
boolField ffs orig = toForm $ do
env <- askParams
let label = ffsLabel ffs
tooltip = ffsTooltip ffs
name <- maybe newFormIdent return $ ffsName ffs
theId <- maybe newFormIdent return $ ffsId ffs
let (res, val) =
if null env
then (FormMissing, fromMaybe False orig)
else case lookup name env of
Nothing -> (FormSuccess False, False)
Just "" -> (FormSuccess False, False)
Just "false" -> (FormSuccess False, False)
Just _ -> (FormSuccess True, True)
let fi = FieldInfo
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = [HAMLET|
<input id="#{theId}" type="checkbox" name="#{name}" :val:checked="">
|]
, fiErrors = case res of
FormFailure [x] -> Just $ toHtml x
_ -> Nothing
, fiRequired = True
}
return (res, fi, UrlEncoded)
htmlField :: (IsForm f, FormType f ~ Html)
=> FormFieldSettings -> Maybe Html -> f
htmlField = requiredFieldHelper htmlFieldProfile
maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html)
=> FormFieldSettings -> Maybe (Maybe Html) -> f
maybeHtmlField = optionalFieldHelper htmlFieldProfile
selectField :: (Eq x, IsForm f, FormType f ~ x)
=> [(x, Text)]
-> FormFieldSettings
-> Maybe x
-> f
selectField pairs ffs initial = toForm $ do
env <- askParams
let label = ffsLabel ffs
tooltip = ffsTooltip ffs
theId <- maybe newFormIdent return $ ffsId ffs
name <- maybe newFormIdent return $ ffsName ffs
let pairs' = zip [1 :: Int ..] pairs
let res = case lookup name env of
Nothing -> FormMissing
Just "none" -> FormFailure ["Field is required"]
Just x ->
case reads $ unpack x of
(x', _):_ ->
case lookup x' pairs' of
Nothing -> FormFailure ["Invalid entry"]
Just (y, _) -> FormSuccess y
[] -> FormFailure ["Invalid entry"]
let isSelected x =
case res of
FormSuccess y -> x == y
_ -> Just x == initial
let input =
#if __GLASGOW_HASKELL__ >= 700
[hamlet|
#else
[$hamlet|
#endif
<select id="#{theId}" name="#{name}">
<option value="none">
$forall pair <- pairs'
<option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}
|]
let fi = FieldInfo
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = input
, fiErrors = case res of
FormFailure [x] -> Just $ toHtml x
_ -> Nothing
, fiRequired = True
}
return (res, fi, UrlEncoded)
maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f)
=> [(x, Text)]
-> FormFieldSettings
-> Maybe (FormType f)
-> f
maybeSelectField pairs ffs initial' = toForm $ do
env <- askParams
let initial = join initial'
label = ffsLabel ffs
tooltip = ffsTooltip ffs
theId <- maybe newFormIdent return $ ffsId ffs
name <- maybe newFormIdent return $ ffsName ffs
let pairs' = zip [1 :: Int ..] pairs
let res = case lookup name env of
Nothing -> FormMissing
Just "none" -> FormSuccess Nothing
Just x ->
case reads $ unpack x of
(x', _):_ ->
case lookup x' pairs' of
Nothing -> FormFailure ["Invalid entry"]
Just (y, _) -> FormSuccess $ Just y
[] -> FormFailure ["Invalid entry"]
let isSelected x =
case res of
FormSuccess y -> Just x == y
_ -> Just x == initial
let input =
#if __GLASGOW_HASKELL__ >= 700
[hamlet|
#else
[$hamlet|
#endif
<select id="#{theId}" name="#{name}">
<option value="none">
$forall pair <- pairs'
<option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)}
|]
let fi = FieldInfo
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = input
, fiErrors = case res of
FormFailure [x] -> Just $ toHtml x
_ -> Nothing
, fiRequired = False
}
return (res, fi, UrlEncoded)
stringInput :: Text -> FormInput sub master Text
stringInput n =
mapFormXml fieldsToInput $
requiredFieldHelper stringFieldProfile (nameSettings n) Nothing
maybeStringInput :: Text -> FormInput sub master (Maybe Text)
maybeStringInput n =
mapFormXml fieldsToInput $
optionalFieldHelper stringFieldProfile (nameSettings n) Nothing
boolInput :: Text -> FormInput sub master Bool
boolInput n = GForm $ do
env <- askParams
let res = case lookup n env of
Nothing -> FormSuccess False
Just "" -> FormSuccess False
Just "false" -> FormSuccess False
Just _ -> FormSuccess True
let xml = [HAMLET|
<input id="#{n}" type="checkbox" name="#{n}">
|]
return (res, [xml], UrlEncoded)
dayInput :: Text -> FormInput sub master Day
dayInput n =
mapFormXml fieldsToInput $
requiredFieldHelper dayFieldProfile (nameSettings n) Nothing
maybeDayInput :: Text -> FormInput sub master (Maybe Day)
maybeDayInput n =
mapFormXml fieldsToInput $
optionalFieldHelper dayFieldProfile (nameSettings n) Nothing
nameSettings :: Text -> FormFieldSettings
nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)
urlField :: (IsForm f, FormType f ~ Text)
=> FormFieldSettings -> Maybe Text -> f
urlField = requiredFieldHelper urlFieldProfile
maybeUrlField :: (IsForm f, FormType f ~ Maybe Text)
=> FormFieldSettings -> Maybe (Maybe Text) -> f
maybeUrlField = optionalFieldHelper urlFieldProfile
urlInput :: Text -> FormInput sub master Text
urlInput n =
mapFormXml fieldsToInput $
requiredFieldHelper urlFieldProfile (nameSettings n) Nothing
emailField :: (IsForm f, FormType f ~ Text)
=> FormFieldSettings -> Maybe Text -> f
emailField = requiredFieldHelper emailFieldProfile
maybeEmailField :: (IsForm f, FormType f ~ Maybe Text)
=> FormFieldSettings -> Maybe (Maybe Text) -> f
maybeEmailField = optionalFieldHelper emailFieldProfile
emailInput :: Text -> FormInput sub master Text
emailInput n =
mapFormXml fieldsToInput $
requiredFieldHelper emailFieldProfile (nameSettings n) Nothing
searchField :: (IsForm f, FormType f ~ Text)
=> AutoFocus -> FormFieldSettings -> Maybe Text -> f
searchField = requiredFieldHelper . searchFieldProfile
maybeSearchField :: (IsForm f, FormType f ~ Maybe Text)
=> AutoFocus -> FormFieldSettings -> Maybe (Maybe Text) -> f
maybeSearchField = optionalFieldHelper . searchFieldProfile
textareaField :: (IsForm f, FormType f ~ Textarea)
=> FormFieldSettings -> Maybe Textarea -> f
textareaField = requiredFieldHelper textareaFieldProfile
maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea)
maybeTextareaField = optionalFieldHelper textareaFieldProfile
hiddenField :: (IsForm f, FormType f ~ Text)
=> FormFieldSettings -> Maybe Text -> f
hiddenField = requiredFieldHelper hiddenFieldProfile
maybeHiddenField :: (IsForm f, FormType f ~ Maybe Text)
=> FormFieldSettings -> Maybe (Maybe Text) -> f
maybeHiddenField = optionalFieldHelper hiddenFieldProfile
fileField :: (IsForm f, FormType f ~ FileInfo)
=> FormFieldSettings -> f
fileField ffs = toForm $ do
env <- lift ask
fenv <- lift $ lift ask
let (FormFieldSettings label tooltip theId' name') = ffs
name <- maybe newFormIdent return name'
theId <- maybe newFormIdent return theId'
let res =
if null env && null fenv
then FormMissing
else case lookup name fenv of
Nothing -> FormFailure ["File is required"]
Just x -> FormSuccess x
let fi = FieldInfo
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = fileWidget theId name True
, fiErrors = case res of
FormFailure [x] -> Just $ toHtml x
_ -> Nothing
, fiRequired = True
}
let res' = case res of
FormFailure [e] -> FormFailure [T.concat [label, ": ", e]]
_ -> res
return (res', fi, Multipart)
maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo)
=> FormFieldSettings -> f
maybeFileField ffs = toForm $ do
fenv <- lift $ lift ask
let (FormFieldSettings label tooltip theId' name') = ffs
name <- maybe newFormIdent return name'
theId <- maybe newFormIdent return theId'
let res = FormSuccess $ lookup name fenv
let fi = FieldInfo
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = fileWidget theId name False
, fiErrors = Nothing
, fiRequired = True
}
return (res, fi, Multipart)
fileWidget :: Text -> Text -> Bool -> GWidget s m ()
fileWidget theId name isReq = [HAMLET|
<input id="#{theId}" type="file" name="#{name}" :isReq:required="">
|]
radioField :: (Eq x, IsForm f, FormType f ~ x)
=> [(x, Text)]
-> FormFieldSettings
-> Maybe x
-> f
radioField pairs ffs initial = toForm $ do
env <- askParams
let label = ffsLabel ffs
tooltip = ffsTooltip ffs
theId <- maybe newFormIdent return $ ffsId ffs
name <- maybe newFormIdent return $ ffsName ffs
let pairs' = zip [1 :: Int ..] pairs
let res = case lookup name env of
Nothing -> FormMissing
Just "none" -> FormFailure ["Field is required"]
Just x ->
case reads $ unpack x of
(x', _):_ ->
case lookup x' pairs' of
Nothing -> FormFailure ["Invalid entry"]
Just (y, _) -> FormSuccess y
[] -> FormFailure ["Invalid entry"]
let isSelected x =
case res of
FormSuccess y -> x == y
_ -> Just x == initial
let input = [HAMLET|
<div id="#{theId}">
$forall pair <- pairs'
<div>
<input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked="">
<label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}
|]
let fi = FieldInfo
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = input
, fiErrors = case res of
FormFailure [x] -> Just $ toHtml x
_ -> Nothing
, fiRequired = True
}
return (res, fi, UrlEncoded)
maybeRadioField
:: (Eq x, IsForm f, FormType f ~ Maybe x)
=> [(x, Text)]
-> FormFieldSettings
-> Maybe (FormType f)
-> f
maybeRadioField pairs ffs initial' = toForm $ do
env <- askParams
let initial = join initial'
label = ffsLabel ffs
tooltip = ffsTooltip ffs
theId <- maybe newFormIdent return $ ffsId ffs
name <- maybe newFormIdent return $ ffsName ffs
let pairs' = zip [1 :: Int ..] pairs
let res = case lookup name env of
Nothing -> FormMissing
Just "none" -> FormSuccess Nothing
Just x ->
case reads $ unpack x of
(x', _):_ ->
case lookup x' pairs' of
Nothing -> FormFailure ["Invalid entry"]
Just (y, _) -> FormSuccess $ Just y
[] -> FormFailure ["Invalid entry"]
let isSelected x =
case res of
FormSuccess y -> Just x == y
_ -> Just x == initial
let isNone =
case res of
FormSuccess Nothing -> True
FormSuccess Just{} -> False
_ -> isNothing initial
let input =
#if __GLASGOW_HASKELL__ >= 700
[hamlet|
#else
[$hamlet|
#endif
<div id="#{theId}">
$forall pair <- pairs'
<div>
<input id="#{theId}-none" type="radio" name="#{name}" value="none" :isNone:checked="">None
<div>
<input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked="">
<label for="#{name}-#{show (fst pair)}">#{snd (snd pair)}
|]
let fi = FieldInfo
{ fiLabel = toHtml label
, fiTooltip = tooltip
, fiIdent = theId
, fiInput = input
, fiErrors = case res of
FormFailure [x] -> Just $ toHtml x
_ -> Nothing
, fiRequired = False
}
return (res, fi, UrlEncoded)