FormFieldSettings

This commit is contained in:
Michael Snoyman 2010-07-26 12:01:18 +03:00
parent 55e4771104
commit 1c6f8fb46c
3 changed files with 145 additions and 211 deletions

View File

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

View File

@ -1,4 +1,4 @@
{-# LANGUAGE TypeFamilies, QuasiQuotes #-} {-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-}
import Yesod import Yesod
import Yesod.Widget import Yesod.Widget
import Yesod.Helpers.Static import Yesod.Helpers.Static
@ -41,7 +41,12 @@ handleFormR = do
<*> intField (string "A number field") (string "some nums") (Just 5) <*> intField (string "A number field") (string "some nums") (Just 5)
<*> jqueryDayField (string "A day field") (string "") Nothing <*> jqueryDayField (string "A day field") (string "") Nothing
<*> timeField (string "A time 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 <*> jqueryAutocompleteField AutoCompleteR
(string "Autocomplete") (string "Try it!") Nothing (string "Autocomplete") (string "Try it!") Nothing
<*> nicHtmlField (string "HTML") (string "") <*> nicHtmlField (string "HTML") (string "")

View File

@ -32,7 +32,7 @@ library
template-haskell >= 2.4 && < 2.5, template-haskell >= 2.4 && < 2.5,
web-routes >= 0.22 && < 0.23, web-routes >= 0.22 && < 0.23,
web-routes-quasi >= 0.5 && < 0.6, web-routes-quasi >= 0.5 && < 0.6,
hamlet >= 0.4.0 && < 0.5, hamlet >= 0.4.1 && < 0.5,
transformers >= 0.2 && < 0.3, transformers >= 0.2 && < 0.3,
clientsession >= 0.4.0 && < 0.5, clientsession >= 0.4.0 && < 0.5,
pureMD5 >= 1.1.0.0 && < 1.2, pureMD5 >= 1.1.0.0 && < 1.2,
@ -61,7 +61,7 @@ library
Yesod.Helpers.Crud Yesod.Helpers.Crud
Yesod.Helpers.Sitemap Yesod.Helpers.Sitemap
Yesod.Helpers.Static Yesod.Helpers.Static
ghc-options: -Wall ghc-options: -Wall -Werror
executable yesod executable yesod
build-depends: parsec >= 2.1 && < 4 build-depends: parsec >= 2.1 && < 4