haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Some convenience functions and bugfixes

Browse Source
This commit is contained in:
Michael Snoyman 2010-07-26 12:47:42 +03:00
parent 74e1c8cbf9
commit 50fa02953e
1 changed files with 27 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
Yesod/Form.hs
View File

@ -45,6 +45,7 @@ module Yesod.Form
, htmlFieldProfile , htmlFieldProfile
, emailFieldProfile , emailFieldProfile
, FormFieldSettings (..) , FormFieldSettings (..)
, labelSettings
-- * Pre-built fields -- * Pre-built fields
, stringField , stringField
, maybeStringField , maybeStringField
@ -587,12 +588,15 @@ readMay s = case reads s of
[] -> Nothing [] -> Nothing
selectField :: Eq x => [(x, String)] selectField :: Eq x => [(x, String)]
-> Html () -> Html () -> FormFieldSettings
-> Maybe x -> FormField sub master x -> Maybe x -> FormField sub master x
selectField pairs label tooltip initial = GForm $ \env _ -> do selectField pairs ffs initial = GForm $ \env _ -> do
i <- newFormIdent 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 pairs' = zip [1 :: Int ..] pairs
let res = case lookup i env of let res = case lookup name env of
Nothing -> FormMissing Nothing -> FormMissing
Just "none" -> FormFailure ["Field is required"] Just "none" -> FormFailure ["Field is required"]
Just x -> Just x ->
@ -607,7 +611,7 @@ selectField pairs label tooltip initial = GForm $ \env _ -> do
FormSuccess y -> x == y FormSuccess y -> x == y
_ -> Just x == initial _ -> Just x == initial
let input = [$hamlet| let input = [$hamlet|
%select#$i$!name=$i$ %select#$theId$!name=$name$
%option!value=none %option!value=none
$forall pairs' pair $forall pairs' pair
%option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
@ -615,8 +619,8 @@ selectField pairs label tooltip initial = GForm $ \env _ -> do
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = label { fiLabel = label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = i , fiIdent = theId
, fiName = i , fiName = name
, fiInput = addBody input , fiInput = addBody input
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> Just $ string x FormFailure [x] -> Just $ string x
@ -625,12 +629,16 @@ selectField pairs label tooltip initial = GForm $ \env _ -> do
return (res, [fi], UrlEncoded) return (res, [fi], UrlEncoded)
maybeSelectField :: Eq x => [(x, String)] maybeSelectField :: Eq x => [(x, String)]
-> Html () -> Html () -> FormFieldSettings
-> Maybe x -> FormField sub master (Maybe x) -> FormletField sub master (Maybe x)
maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do maybeSelectField pairs ffs initial' = GForm $ \env _ -> do
i <- newFormIdent 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 pairs' = zip [1 :: Int ..] pairs
let res = case lookup i env of let res = case lookup name env of
Nothing -> FormMissing Nothing -> FormMissing
Just "none" -> FormSuccess Nothing Just "none" -> FormSuccess Nothing
Just x -> Just x ->
@ -645,7 +653,7 @@ maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do
FormSuccess y -> Just x == y FormSuccess y -> Just x == y
_ -> Just x == initial _ -> Just x == initial
let input = [$hamlet| let input = [$hamlet|
%select#$i$!name=$i$ %select#$theId$!name=$name$
%option!value=none %option!value=none
$forall pairs' pair $forall pairs' pair
%option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
@ -653,8 +661,8 @@ maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do
let fi = FieldInfo let fi = FieldInfo
{ fiLabel = label { fiLabel = label
, fiTooltip = tooltip , fiTooltip = tooltip
, fiIdent = i , fiIdent = theId
, fiName = i , fiName = name
, fiInput = addBody input , fiInput = addBody input
, fiErrors = case res of , fiErrors = case res of
FormFailure [x] -> Just $ string x FormFailure [x] -> Just $ string x
@ -869,7 +877,7 @@ emailInput n =
requiredFieldHelper emailFieldProfile (nameSettings n) Nothing requiredFieldHelper emailFieldProfile (nameSettings n) Nothing
nameSettings :: String -> FormFieldSettings nameSettings :: String -> FormFieldSettings
nameSettings = FormFieldSettings mempty mempty Nothing . Just nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)
addScript' :: (y -> Either (Route y) String) -> GWidget sub y () addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()
addScript' f = do addScript' f = do
@ -880,3 +888,6 @@ addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y ()
addStylesheet' f = do addStylesheet' f = do
y <- liftHandler getYesod y <- liftHandler getYesod
addStylesheetEither $ f y addStylesheetEither $ f y
labelSettings :: String -> FormFieldSettings
labelSettings l = FormFieldSettings (string l) mempty Nothing Nothing