From 1c6f8fb46cbc5e5148e280644014a29a7d8223be Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 26 Jul 2010 12:01:18 +0300 Subject: [PATCH] FormFieldSettings --- Yesod/Form.hs | 343 ++++++++++++++++++++----------------------------- hellowidget.hs | 9 +- yesod.cabal | 4 +- 3 files changed, 145 insertions(+), 211 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 5ce22c39..ec4a0911 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -44,6 +44,7 @@ module Yesod.Form , timeFieldProfile , htmlFieldProfile , emailFieldProfile + , FormFieldSettings (..) -- * Pre-built fields , stringField , maybeStringField @@ -88,7 +89,7 @@ import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (UTCTime(..), Day, TimeOfDay(..)) import Data.Time.LocalTime (timeOfDayToTime, timeToTimeOfDay) -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<), liftM, join) import Data.Monoid (Monoid (..)) @@ -160,6 +161,7 @@ data FieldInfo sub y = FieldInfo { fiLabel :: Html () , fiTooltip :: Html () , fiIdent :: String + , fiName :: String , fiInput :: GWidget sub y () , fiErrors :: Maybe (Html ()) } @@ -207,14 +209,24 @@ fieldsToTable = mapM_ go class ToForm a y where toForm :: Maybe a -> Form sub y a class ToFormField a y where - toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a + toFormField :: FormFieldSettings -> Maybe a -> FormField sub y a + +data FormFieldSettings = FormFieldSettings + { ffsLabel :: Html () + , ffsTooltip :: Html () + , ffsId :: Maybe String + , ffsName :: Maybe String + } -- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'. -requiredFieldHelper :: FieldProfile sub y a -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig = +-- 'FieldProfile'.ngs +requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> Maybe a -> FormField sub y a +requiredFieldHelper + (FieldProfile parse render mkXml w) + (FormFieldSettings label tooltip name' theId') orig = GForm $ \env _ -> do name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' let (res, val) = if null env then (FormMissing, maybe "" render orig) @@ -228,8 +240,9 @@ requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig let fi = FieldInfo { fiLabel = label , fiTooltip = tooltip - , fiIdent = name - , fiInput = w name >> addBody (mkXml (string name) (string val) True) + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val True) , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing @@ -238,12 +251,14 @@ requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig -- | Create an optional field (ie, one that can be blank) from a -- 'FieldProfile'. -optionalFieldHelper :: FieldProfile sub y a -> Maybe (Maybe a) - -> FormField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig' = +optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> FormletField sub y (Maybe a) +optionalFieldHelper + (FieldProfile parse render mkXml w) + (FormFieldSettings label tooltip name' theId') orig' = GForm $ \env _ -> do let orig = join orig' name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' let (res, val) = if null env then (FormSuccess Nothing, maybe "" render orig) @@ -257,8 +272,9 @@ optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig let fi = FieldInfo { fiLabel = label , fiTooltip = tooltip - , fiIdent = name - , fiInput = w name >> addBody (mkXml (string name) (string val) False) + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val False) , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing @@ -271,38 +287,26 @@ optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig data FieldProfile sub y a = FieldProfile { fpParse :: String -> Either String a , fpRender :: a -> String - , fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Route y) + , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) , fpWidget :: String -> GWidget sub y () - , fpName :: Maybe String - , fpLabel :: Html () - , fpTooltip :: Html () } --------------------- Begin prebuilt forms -stringField :: Html () -> Html () -> FormletField sub y String -stringField label tooltip = requiredFieldHelper stringFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +stringField :: FormFieldSettings -> FormletField sub y String +stringField = requiredFieldHelper stringFieldProfile -maybeStringField :: Html () -> Html () -> FormletField sub y (Maybe String) -maybeStringField label tooltip = optionalFieldHelper stringFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeStringField = optionalFieldHelper stringFieldProfile stringFieldProfile :: FieldProfile sub y String stringFieldProfile = FieldProfile { fpParse = Right , fpRender = id - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=text!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } instance ToFormField String y where toFormField = stringField @@ -312,34 +316,22 @@ instance ToFormField (Maybe String) y where intInput :: Integral i => String -> FormInput sub master i intInput n = mapFormXml fieldsToInput $ - requiredFieldHelper intFieldProfile - { fpName = Just n - } Nothing + requiredFieldHelper intFieldProfile (nameSettings n) Nothing -intField :: Integral i => Html () -> Html () -> FormletField sub y i -intField l t = requiredFieldHelper intFieldProfile - { fpLabel = l - , fpTooltip = t - } +intField :: Integral i => FormFieldSettings -> FormletField sub y i +intField = requiredFieldHelper intFieldProfile -maybeIntField :: Integral i => - Html () -> Html () -> FormletField sub y (Maybe i) -maybeIntField l t = optionalFieldHelper intFieldProfile - { fpLabel = l - , fpTooltip = t - } +maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i) +maybeIntField = optionalFieldHelper intFieldProfile intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI , fpRender = showI - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } where showI x = show (fromIntegral x :: Integer) @@ -355,75 +347,51 @@ instance ToFormField Int64 y where instance ToFormField (Maybe Int64) y where toFormField = maybeIntField -doubleField :: Html () -> Html () -> FormletField sub y Double -doubleField l t = requiredFieldHelper doubleFieldProfile - { fpLabel = l - , fpTooltip = t - } +doubleField :: FormFieldSettings -> FormletField sub y Double +doubleField = requiredFieldHelper doubleFieldProfile -maybeDoubleField :: Html () -> Html () -> FormletField sub y (Maybe Double) -maybeDoubleField l t = optionalFieldHelper doubleFieldProfile - { fpLabel = l - , fpTooltip = t - } +maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double) +maybeDoubleField = optionalFieldHelper doubleFieldProfile doubleFieldProfile :: FieldProfile sub y Double doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } instance ToFormField Double y where toFormField = doubleField instance ToFormField (Maybe Double) y where toFormField = maybeDoubleField -dayField :: Html () -> Html () -> FormletField sub y Day -dayField l t = requiredFieldHelper dayFieldProfile - { fpLabel = l - , fpTooltip = t - } +dayField :: FormFieldSettings -> FormletField sub y Day +dayField = requiredFieldHelper dayFieldProfile -maybeDayField :: Html () -> Html () -> FormletField sub y (Maybe Day) -maybeDayField l t = optionalFieldHelper dayFieldProfile - { fpLabel = l - , fpTooltip = t - } +maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day) +maybeDayField = optionalFieldHelper dayFieldProfile dayFieldProfile :: FieldProfile sub y Day dayFieldProfile = FieldProfile { fpParse = parseDate , fpRender = show - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = const $ return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } instance ToFormField Day y where toFormField = dayField instance ToFormField (Maybe Day) y where toFormField = maybeDayField -jqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y Day -jqueryDayField l t = requiredFieldHelper jqueryDayFieldProfile - { fpLabel = l - , fpTooltip = t - } +jqueryDayField :: Yesod y => FormFieldSettings -> FormletField sub y Day +jqueryDayField = requiredFieldHelper jqueryDayFieldProfile -maybeJqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y (Maybe Day) -maybeJqueryDayField l t = optionalFieldHelper jqueryDayFieldProfile - { fpLabel = l - , fpTooltip = t - } +maybeJqueryDayField :: Yesod y => FormFieldSettings -> FormletField sub y (Maybe Day) +maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile jqueryDayFieldProfile :: Yesod y => FieldProfile sub y Day jqueryDayFieldProfile = FieldProfile @@ -432,8 +400,8 @@ jqueryDayFieldProfile = FieldProfile Right . readMay , fpRender = show - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = \name -> do addScript' urlJqueryJs @@ -442,9 +410,6 @@ jqueryDayFieldProfile = FieldProfile addJavaScript [$hamlet| $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); |] - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } -- | Replaces all instances of a value in a list by another value. @@ -469,9 +434,8 @@ parseUTCTime s = Right date -> ifRight (parseTime timeS) (\time -> UTCTime date (timeOfDayToTime time)) -jqueryDayTimeField :: Yesod y => Html () -> Html () -> FormletField sub y UTCTime -jqueryDayTimeField l t = requiredFieldHelper jqueryDayTimeFieldProfile - { fpLabel = l , fpTooltip = t } +jqueryDayTimeField :: Yesod y => FormFieldSettings -> FormletField sub y UTCTime +jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile parseDate :: String -> Either String Day parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right @@ -492,8 +456,8 @@ jqueryDayTimeFieldProfile :: Yesod y => FieldProfile sub y UTCTime jqueryDayTimeFieldProfile = FieldProfile { fpParse = parseUTCTime , fpRender = jqueryDayTimeUTCTime - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = \name -> do addScript' urlJqueryJs @@ -503,9 +467,6 @@ jqueryDayTimeFieldProfile = FieldProfile addJavaScript [$hamlet| $$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } parseTime :: String -> Either String TimeOfDay @@ -532,38 +493,32 @@ parseTimeHelper (h1, h2, m1, m2, s1, s2) m = read [m1, m2] s = fromInteger $ read [s1, s2] -timeField :: Html () -> Html () -> FormletField sub y TimeOfDay -timeField label tooltip = requiredFieldHelper timeFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +timeField :: FormFieldSettings -> FormletField sub y TimeOfDay +timeField = requiredFieldHelper timeFieldProfile -maybeTimeField :: Html () -> Html () -> FormletField sub y (Maybe TimeOfDay) -maybeTimeField label tooltip = optionalFieldHelper timeFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay) +maybeTimeField = optionalFieldHelper timeFieldProfile timeFieldProfile :: FieldProfile sub y TimeOfDay timeFieldProfile = FieldProfile { fpParse = parseTime , fpRender = show - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!:isReq:required!value=$val$ |] , fpWidget = const $ return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } instance ToFormField TimeOfDay y where toFormField = timeField instance ToFormField (Maybe TimeOfDay) y where toFormField = maybeTimeField -boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool -boolField label tooltip orig = GForm $ \env _ -> do - name <- newFormIdent +boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool +boolField ffs orig = GForm $ \env _ -> do + 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) @@ -573,9 +528,10 @@ boolField label tooltip orig = GForm $ \env _ -> do let fi = FieldInfo { fiLabel = label , fiTooltip = tooltip - , fiIdent = name + , fiIdent = theId + , fiName = name , fiInput = addBody [$hamlet| -%input#$name$!type=checkbox!name=$name$!:val:checked +%input#$theId$!type=checkbox!name=$name$!:val:checked |] , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -585,29 +541,20 @@ boolField label tooltip orig = GForm $ \env _ -> do instance ToFormField Bool y where toFormField = boolField -htmlField :: Html () -> Html () -> FormletField sub y (Html ()) -htmlField label tooltip = requiredFieldHelper htmlFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +htmlField :: FormFieldSettings -> FormletField sub y (Html ()) +htmlField = requiredFieldHelper htmlFieldProfile -maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ())) -maybeHtmlField label tooltip = optionalFieldHelper htmlFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe (Html ())) +maybeHtmlField = optionalFieldHelper htmlFieldProfile htmlFieldProfile :: FieldProfile sub y (Html ()) htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml - , fpHamlet = \name val _isReq -> [$hamlet| -%textarea.html#$name$!name=$name$ $val$ + , fpHamlet = \theId name val _isReq -> [$hamlet| +%textarea.html#$theId$!name=$name$ $val$ |] , fpWidget = const $ return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } instance ToFormField (Html ()) y where toFormField = htmlField @@ -616,31 +563,22 @@ instance ToFormField (Maybe (Html ())) y where type Html' = Html () -nicHtmlField :: Yesod y => Html () -> Html () -> FormletField sub y (Html ()) -nicHtmlField label tooltip = requiredFieldHelper nicHtmlFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +nicHtmlField :: Yesod y => FormFieldSettings -> FormletField sub y (Html ()) +nicHtmlField = requiredFieldHelper nicHtmlFieldProfile -maybeNicHtmlField :: Yesod y => Html () -> Html () -> FormletField sub y (Maybe (Html ())) -maybeNicHtmlField label tooltip = optionalFieldHelper nicHtmlFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +maybeNicHtmlField :: Yesod y => FormFieldSettings -> FormletField sub y (Maybe (Html ())) +maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile nicHtmlFieldProfile :: Yesod y => FieldProfile sub y (Html ()) nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml - , fpHamlet = \name val _isReq -> [$hamlet| -%textarea.html#$name$!name=$name$ $val$ + , fpHamlet = \theId name val _isReq -> [$hamlet| +%textarea.html#$theId$!name=$name$ $val$ |] , fpWidget = \name -> do addScript' urlNicEdit addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } readMay :: Read a => String -> Maybe a @@ -678,6 +616,7 @@ selectField pairs label tooltip initial = GForm $ \env _ -> do { fiLabel = label , fiTooltip = tooltip , fiIdent = i + , fiName = i , fiInput = addBody input , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -715,6 +654,7 @@ maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do { fiLabel = label , fiTooltip = tooltip , fiIdent = i + , fiName = i , fiInput = addBody input , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -729,16 +669,12 @@ maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do stringInput :: String -> FormInput sub master String stringInput n = mapFormXml fieldsToInput $ - requiredFieldHelper stringFieldProfile - { fpName = Just n - } Nothing + requiredFieldHelper stringFieldProfile (nameSettings n) Nothing maybeStringInput :: String -> FormInput sub master (Maybe String) maybeStringInput n = mapFormXml fieldsToInput $ - optionalFieldHelper stringFieldProfile - { fpName = Just n - } Nothing + optionalFieldHelper stringFieldProfile (nameSettings n) Nothing boolInput :: String -> FormInput sub master Bool boolInput n = GForm $ \env _ -> return @@ -749,16 +685,12 @@ boolInput n = GForm $ \env _ -> return dayInput :: String -> FormInput sub master Day dayInput n = mapFormXml fieldsToInput $ - requiredFieldHelper dayFieldProfile - { fpName = Just n - } Nothing + requiredFieldHelper dayFieldProfile (nameSettings n) Nothing maybeDayInput :: String -> FormInput sub master (Maybe Day) maybeDayInput n = mapFormXml fieldsToInput $ - optionalFieldHelper dayFieldProfile - { fpName = Just n - } Nothing + optionalFieldHelper dayFieldProfile (nameSettings n) Nothing --------------------- End prebuilt inputs @@ -822,9 +754,17 @@ mkToForm name = mapM derive getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x getTooltip' (_:x) = getTooltip' x getTooltip' [] = Nothing + getId (_, _, z) = fromMaybe "" $ getId' z + getId' (('i':'d':'=':x):_) = Just x + getId' (_:x) = getId' x + getId' [] = Nothing + getName (_, _, z) = fromMaybe "" $ getName' z + getName' (('n':'a':'m':'e':'=':x):_) = Just x + getName' (_:x) = getName' x + getName' [] = Nothing derive :: EntityDef -> Q Dec derive t = do - let cols = map ((getLabel &&& getTooltip) &&& getTFF) $ entityColumns t + let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t ap <- [|(<*>)|] just <- [|pure|] nothing <- [|Nothing|] @@ -832,7 +772,10 @@ mkToForm name = mapM derive string' <- [|string|] mfx <- [|mapFormXml|] ftt <- [|fieldsToTable|] - let go_ = go ap just' string' mfx ftt + ffs' <- [|FormFieldSettings|] + let stm "" = nothing + stm x = just `AppE` LitE (StringL x) + let go_ = go ap just' ffs' stm string' mfx ftt let c1 = Clause [ ConP (mkName "Nothing") [] ] (NormalB $ go_ $ zip cols $ map (const nothing) cols) @@ -847,14 +790,18 @@ mkToForm name = mapM derive `AppT` ConT (mkName $ entityName t) `AppT` ConT (mkName name)) [FunD (mkName "toForm") [c1, c2]] - go ap just' string' mfx ftt a = - let x = foldl (ap' ap) just' $ map (go' string') a + go ap just' ffs' stm string' mfx ftt a = + let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a in mfx `AppE` ftt `AppE` x - go' string' (((label, tooltip), tff), ex) = + go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) = let label' = string' `AppE` LitE (StringL label) tooltip' = string' `AppE` LitE (StringL tooltip) - in VarE (mkName tff) `AppE` label' - `AppE` tooltip' `AppE` ex + ffs = ffs' `AppE` + label' `AppE` + tooltip' `AppE` + (stm theId) `AppE` + (stm name) + in VarE (mkName tff) `AppE` ffs `AppE` ex ap' ap x y = InfixE (Just x) ap (Just y) toLabel :: String -> String @@ -867,27 +814,20 @@ toLabel (x:rest) = toUpper x : go rest | otherwise = c : go cs jqueryAutocompleteField :: Yesod y => - Route y -> Html () -> Html () -> FormletField sub y String -jqueryAutocompleteField src l t = - requiredFieldHelper $ (jqueryAutocompleteFieldProfile src) - { fpLabel = l - , fpTooltip = t - } + Route y -> FormFieldSettings -> FormletField sub y String +jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile maybeJqueryAutocompleteField :: Yesod y => - Route y -> Html () -> Html () -> FormletField sub y (Maybe String) -maybeJqueryAutocompleteField src l t = - optionalFieldHelper $ (jqueryAutocompleteFieldProfile src) - { fpLabel = l - , fpTooltip = t - } + Route y -> FormFieldSettings -> FormletField sub y (Maybe String) +maybeJqueryAutocompleteField src = + optionalFieldHelper $ jqueryAutocompleteFieldProfile src jqueryAutocompleteFieldProfile :: Yesod y => Route y -> FieldProfile sub y String jqueryAutocompleteFieldProfile src = FieldProfile { fpParse = Right , fpRender = id - , fpHamlet = \name val isReq -> [$hamlet| -%input.autocomplete#$name$!name=$name$!type=text!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] , fpWidget = \name -> do addScript' urlJqueryJs @@ -896,9 +836,6 @@ jqueryAutocompleteFieldProfile src = FieldProfile addJavaScript [$hamlet| $$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})}); |] - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } emailFieldProfile :: FieldProfile s y String @@ -907,33 +844,25 @@ emailFieldProfile = FieldProfile then Right s else Left "Invalid e-mail address" , fpRender = id - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=email!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ |] , fpWidget = const $ return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } -emailField :: Html () -> Html () -> FormletField sub y String -emailField label tooltip = requiredFieldHelper emailFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +emailField :: FormFieldSettings -> FormletField sub y String +emailField = requiredFieldHelper emailFieldProfile -maybeEmailField :: Html () -> Html () -> FormletField sub y (Maybe String) -maybeEmailField label tooltip = optionalFieldHelper emailFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeEmailField = optionalFieldHelper emailFieldProfile emailInput :: String -> FormInput sub master String emailInput n = mapFormXml fieldsToInput $ - requiredFieldHelper emailFieldProfile - { fpName = Just n - } Nothing + requiredFieldHelper emailFieldProfile (nameSettings n) Nothing + +nameSettings :: String -> FormFieldSettings +nameSettings = FormFieldSettings mempty mempty Nothing . Just addScript' :: (y -> Either (Route y) String) -> GWidget sub y () addScript' f = do diff --git a/hellowidget.hs b/hellowidget.hs index 844a66c5..7afe4641 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-} import Yesod import Yesod.Widget import Yesod.Helpers.Static @@ -41,7 +41,12 @@ handleFormR = do <*> intField (string "A number field") (string "some nums") (Just 5) <*> jqueryDayField (string "A day field") (string "") Nothing <*> timeField (string "A time field") (string "") Nothing - <*> boolField (string "A checkbox") (string "") (Just False) + <*> boolField FormFieldSettings + { ffsLabel = "A checkbox" + , ffsTooltip = "" + , ffsId = Nothing + , ffsName = Nothing + } (Just False) <*> jqueryAutocompleteField AutoCompleteR (string "Autocomplete") (string "Try it!") Nothing <*> nicHtmlField (string "HTML") (string "") diff --git a/yesod.cabal b/yesod.cabal index 25372373..6471a351 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -32,7 +32,7 @@ library template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.5 && < 0.6, - hamlet >= 0.4.0 && < 0.5, + hamlet >= 0.4.1 && < 0.5, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, pureMD5 >= 1.1.0.0 && < 1.2, @@ -61,7 +61,7 @@ library Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static - ghc-options: -Wall + ghc-options: -Wall -Werror executable yesod build-depends: parsec >= 2.1 && < 4