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

Merge commit '837f796' into beta

Browse Source 
Conflicts:
	yesod-form/Yesod/Form/Fields.hs
	yesod-form/Yesod/Form/Types.hs
This commit is contained in:
Michael Snoyman 2011-12-28 09:11:35 +02:00
commit d2a612a81b
6 changed files with 60 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
yesod-form/Yesod/Form/Fields.hs
View File

@ -67,6 +67,7 @@ import Text.Blaze.Renderer.String (renderHtml)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Text (Text, unpack, pack)
import qualified Data.Text as T (null)
import qualified Data.Text.Read
import Control.Monad.Trans.Class (lift)
@ -110,9 +111,9 @@ intField = Field
Right (a, "") -> Right a
_ -> Left $ MsgInvalidInteger s
, fieldView = \theId name val isReq -> addHamlet
, fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\
<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{showVal val}">
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" type="number" :isReq:required="" value="#{showVal val}">
|]
}
where
@ -126,9 +127,9 @@ doubleField = Field
Right (a, "") -> Right a
_ -> Left $ MsgInvalidNumber s
, fieldView = \theId name val isReq -> addHamlet
, fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{showVal val}">
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" type="text" :isReq:required="" value="#{showVal val}">
|]
}
where showVal = either id (pack . show)
@ -136,9 +137,9 @@ doubleField = Field
dayField :: RenderMessage master FormMessage => Field sub master Day
dayField = Field
{ fieldParse = blank $ parseDate . unpack
, fieldView = \theId name val isReq -> addHamlet
, fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" type="date" :isReq:required="" value="#{showVal val}">
|]
}
where showVal = either id (pack . show)
@ -146,9 +147,9 @@ dayField = Field
timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay
timeField = Field
{ fieldParse = blank $ parseTime . unpack
, fieldView = \theId name val isReq -> addHamlet
, fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" :isReq:required="" value="#{showVal val}">
|]
}
where
@ -161,9 +162,10 @@ timeField = Field
htmlField :: RenderMessage master FormMessage => Field sub master Html
htmlField = Field
{ fieldParse = blank $ Right . preEscapedText . sanitizeBalance
, fieldView = \theId name val _isReq -> addHamlet
, fieldView = \theId name theClass val _isReq -> addHamlet
-- FIXME: There was a class="html" attribute, for what purpose?
[HAMLET|\
<textarea id="#{theId}" name="#{name}" .html>#{showVal val}
<textarea id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}">#{showVal val}
|]
}
where showVal = either id (pack . renderHtml)
@ -189,36 +191,36 @@ instance ToHtml Textarea where
textareaField :: RenderMessage master FormMessage => Field sub master Textarea
textareaField = Field
{ fieldParse = blank $ Right . Textarea
, fieldView = \theId name val _isReq -> addHamlet
, fieldView = \theId name theClass val _isReq -> addHamlet
[HAMLET|\
<textarea id="#{theId}" name="#{name}">#{either id unTextarea val}
<textarea id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}">#{either id unTextarea val}
|]
}
hiddenField :: RenderMessage master FormMessage => Field sub master Text
hiddenField = Field
{ fieldParse = blank $ Right
, fieldView = \theId name val _isReq -> addHamlet
, fieldView = \theId name theClass val _isReq -> addHamlet
[HAMLET|\
<input type="hidden" id="#{theId}" name="#{name}" value="#{either id id val}">
<input type="hidden" id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" value="#{either id id val}">
|]
}
textField :: RenderMessage master FormMessage => Field sub master Text
textField = Field
{ fieldParse = blank $ Right
, fieldView = \theId name val isReq ->
, fieldView = \theId name theClass val isReq ->
[WHAMLET|
<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{either id id val}">
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" type="text" :isReq:required value="#{either id id val}">
|]
}
passwordField :: RenderMessage master FormMessage => Field sub master Text
passwordField = Field
{ fieldParse = blank $ Right
, fieldView = \theId name val isReq -> addHamlet
, fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\
<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{either id id val}">
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" type="password" :isReq:required="" value="#{either id id val}">
|]
}
@ -266,9 +268,9 @@ emailField = Field
\s -> if Email.isValid (unpack s)
then Right s
else Left $ MsgInvalidEmail s
, fieldView = \theId name val isReq -> addHamlet
, fieldView = \theId name theClass val isReq -> addHamlet
[HAMLET|\
<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{either id id val}">
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" type="email" :isReq:required="" value="#{either id id val}">
|]
}
@ -276,9 +278,9 @@ type AutoFocus = Bool
searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text
searchField autoFocus = Field
{ fieldParse = blank Right
, fieldView = \theId name val isReq -> do
, fieldView = \theId name theClass val isReq -> do
[WHAMLET|\
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|]
when autoFocus $ do
-- we want this javascript to be placed immediately after the field
@ -296,9 +298,9 @@ urlField = Field
case parseURI $ unpack s of
Nothing -> Left $ MsgInvalidUrl s
Just _ -> Right s
, fieldView = \theId name val isReq ->
, fieldView = \theId name theClass val isReq ->
[WHAMLET|
<input ##{theId} name=#{name} type=url :isReq:required value=#{either id id val}>
<input ##{theId} name=#{name} :T.null theClass:class="#{theClass}" type=url :isReq:required value=#{either id id val}>
|]
}
@ -309,12 +311,12 @@ selectField' :: (Eq a, RenderMessage master FormMessage) => GHandlerT sub master
selectField' = selectFieldHelper
(\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|]) -- inside
(\_theId _name theClass value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected :T.null theClass:class"#{theClass}">#{text}|]) -- inside
multiSelectField :: (Show a, Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master [a]
multiSelectField = multiSelectFieldHelper
(\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|])
(\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
(\_theId _name theClass value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected :T.null theClass:class="#{theClass}">#{text}|])
radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
radioField = radioField' . optionsPairs
@ -327,25 +329,25 @@ radioField' = selectFieldHelper
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
<label for=#{theId}-none>_{MsgSelectNone}
|])
(\theId name value isSel text -> [WHAMLET|
(\theId name theClass value isSel text -> [WHAMLET|
<div>
<input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked>
<input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked :T.null theClass:class="#{theClass}">
<label for=#{theId}-#{value}>#{text}
|])
boolField :: RenderMessage master FormMessage => Field sub master Bool
boolField = Field
{ fieldParse = return . boolParser
, fieldView = \theId name val isReq -> [WHAMLET|
, fieldView = \theId name theClass val isReq -> [WHAMLET|
$if not isReq
<input id=#{theId}-none type=radio name=#{name} value=none checked>
<input id=#{theId}-none :T.null theClass:class="#{theClass}" type=radio name=#{name} value=none checked>
<label for=#{theId}-none>_{MsgSelectNone}
<input id=#{theId}-yes type=radio name=#{name} value=yes :showVal id val:checked>
<input id=#{theId}-yes :T.null theClass:class="#{theClass}" type=radio name=#{name} value=yes :showVal id val:checked>
<label for=#{theId}-yes>_{MsgBoolYes}
<input id=#{theId}-no type=radio name=#{name} value=no :showVal not val:checked>
<input id=#{theId}-no :T.null theClass:class="#{theClass}" type=radio name=#{name} value=no :showVal not val:checked>
<label for=#{theId}-no>_{MsgBoolNo}
|]
}
@ -361,15 +363,16 @@ boolField = Field
multiSelectFieldHelper :: (Show a, Eq a)
=> (Text -> Text -> GWidget sub master () -> GWidget sub master ())
-> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-> (Text -> Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-> [(Text, a)] -> Field sub master [a]
multiSelectFieldHelper outside inside opts = Field
{ fieldParse = return . selectParser
, fieldView = \theId name vals _ ->
, fieldView = \theId name theClass vals _ ->
outside theId name $ do
flip mapM_ pairs $ \pair -> inside
theId
name
theClass
(pack $ show $ fst pair)
((fst pair) `elem` (either (\_ -> []) selectedVals vals)) -- We are presuming that select fields can't hold invalid values
(fst $ snd pair)
@ -426,19 +429,20 @@ selectFieldHelper
:: (Eq a, RenderMessage master FormMessage)
=> (Text -> Text -> GWidget sub master () -> GWidget sub master ())
-> (Text -> Text -> Bool -> GWidget sub master ())
-> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-> (Text -> Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-> GHandlerT sub master IO (OptionList a) -> Field sub master a
selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x -> do
opts <- opts'
return $ selectParser opts x
, fieldView = \theId name val isReq -> do
, fieldView = \theId name theClass val isReq -> do
opts <- fmap olOptions $ lift $ liftIOHandler opts'
outside theId name $ do
unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
flip mapM_ opts $ \opt -> inside
theId
name
theClass
(optionExternalValue opt)
((render opts val) == optionExternalValue opt)
(optionDisplay opt)
@ -472,12 +476,13 @@ fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
let t = renderMessage master langs MsgValueRequired
in (FormFailure [t], Just $ toHtml t)
Just fi -> (FormSuccess fi, Nothing)
let theClass = fsClass fs
let fv = FieldView
{ fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
, fvId = id'
, fvInput = [WHAMLET|
<input type=file name=#{name} ##{id'}>
<input type=file name=#{name} ##{id'} :T.null theClass:class="#{theClass}">
|]
, fvErrors = errs
, fvRequired = True
@ -500,12 +505,13 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
case Map.lookup name fenv of
Nothing -> (FormSuccess Nothing, Nothing)
Just fi -> (FormSuccess $ Just fi, Nothing)
let theClass = fsClass fs
let fv = FieldView
{ fvLabel = toHtml $ renderMessage master langs $ fsLabel fs
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
, fvId = id'
, fvInput = [WHAMLET|
<input type=file name=#{name} ##{id'}>
<input type=file name=#{name} ##{id'} :T.null theClass:class="#{theClass}">
|]
, fvErrors = errs
, fvRequired = False

2
yesod-form/Yesod/Form/Functions.hs
View File

@ -137,7 +137,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
{ fvLabel = toHtml $ mr2 fsLabel
, fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
, fvId = theId
, fvInput = fieldView theId name val isReq
, fvInput = fieldView theId name fsClass val isReq
, fvErrors =
case res of
FormFailure [e] -> Just $ toHtml e

13
yesod-form/Yesod/Form/Jquery.hs
View File

@ -20,6 +20,7 @@ import Yesod.Form
import Yesod.Widget
import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
timeToTimeOfDay)
import qualified Data.Text as T (null)
import Data.Char (isSpace)
import Data.Default
import Text.Hamlet (shamlet)
@ -78,9 +79,9 @@ jqueryDayField jds = Field
Right
. readMay
. unpack
, fieldView = \theId name val isReq -> do
, fieldView = \theId name theClass val isReq -> do
addHtml [HTML|\
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" type="date" :isReq:required="" value="#{showVal val}">
|]
addScript' urlJqueryJs
addScript' urlJqueryUiJs
@ -129,9 +130,9 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
jqueryDayTimeField :: (RenderMessage master FormMessage, YesodJquery master) => Field sub master UTCTime
jqueryDayTimeField = Field
{ fieldParse = blank $ parseUTCTime . unpack
, fieldView = \theId name val isReq -> do
, fieldView = \theId name theClass val isReq -> do
addHtml [HTML|\
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" :isReq:required="" value="#{showVal val}">
|]
addScript' urlJqueryJs
addScript' urlJqueryUiJs
@ -159,9 +160,9 @@ jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master
=> Route master -> Field sub master Text
jqueryAutocompleteField src = Field
{ fieldParse = blank $ Right
, fieldView = \theId name val isReq -> do
, fieldView = \theId name theClass val isReq -> do
addHtml [HTML|\
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
<input id="#{theId}" name="#{name}" :T.null theClass:class="#{theClass}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
|]
addScript' urlJqueryJs
addScript' urlJqueryUiJs

1
yesod-form/Yesod/Form/MassInput.hs
View File

@ -111,6 +111,7 @@ withDelete af = do
, fsTooltip = Nothing
, fsName = Just deleteName
, fsId = Nothing
, fsClass = ""
} $ Just False
(res, xml) <- aFormToForm af
return $ Right (res, xml $ xml2 [])

5
yesod-form/Yesod/Form/Nic.hs
View File

@ -20,6 +20,7 @@ import Text.Blaze.Renderer.String (renderHtml)
import Text.Blaze (preEscapedText)
import Control.Monad.Trans.Class (lift)
import Data.Text (Text, pack)
import qualified Data.Text as T (null)
import Data.Maybe (listToMaybe)
class YesodNic a where
@ -30,14 +31,14 @@ class YesodNic a where
nicHtmlField :: YesodNic master => Field sub master Html
nicHtmlField = Field
{ fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe
, fieldView = \theId name val _isReq -> do
, fieldView = \theId name theClass val _isReq -> do
addHtml
#if __GLASGOW_HASKELL__ >= 700
[shamlet|
#else
[$shamlet|
#endif
<textarea id="#{theId}" name="#{name}" .html>#{showVal val}
<textarea id="#{theId}" :T.null theClass:class="#{theClass}" name="#{name}" .html>#{showVal val}
|]
addScript' urlNicEdit
addJulius

6
yesod-form/Yesod/Form/Types.hs
View File

@ -102,10 +102,11 @@ data FieldSettings msg = FieldSettings
, fsTooltip :: Maybe msg
, fsId :: Maybe Text
, fsName :: Maybe Text
, fsClass :: Text
}
instance (a ~ Text) => IsString (FieldSettings a) where
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing ""
data FieldView sub master = FieldView
{ fvLabel :: Html
@ -118,8 +119,9 @@ data FieldView sub master = FieldView
data Field sub master a = Field
{ fieldParse :: [Text] -> GHandlerT sub master IO (Either (SomeMessage master) (Maybe a))
-- | ID, name, (invalid text OR legimiate result), required?
-- | ID, name, class, (invalid text OR legimiate result), required?
, fieldView :: Text
-> Text
-> Text
-> Either Text a
-> Bool