Merge pull request #3 from mindreader/master
Added multiple select forms to yesod-form.
This commit is contained in:
Michael Snoyman
commit
6aa9622449
@ -17,6 +17,7 @@ module Yesod.Form.Fields
|
||||
, emailField
|
||||
, searchField
|
||||
, selectField
|
||||
, multiSelectField
|
||||
, AutoFocus
|
||||
, urlField
|
||||
, doubleField
|
||||
@ -40,6 +41,9 @@ import Network.URI (parseURI)
|
||||
import Database.Persist (PersistField)
|
||||
import Text.HTML.SanitizeXSS (sanitizeBalance)
|
||||
import Control.Monad (when, unless)
|
||||
import Data.List (intersect, nub)
|
||||
import Data.Either (rights)
|
||||
import Data.Maybe (catMaybes)
|
||||
|
||||
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
|
||||
import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
|
||||
@ -104,10 +108,12 @@ defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t
|
||||
defaultFormMessage MsgBoolYes = "Yes"
|
||||
defaultFormMessage MsgBoolNo = "No"
|
||||
|
||||
blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)
|
||||
blank _ Nothing = Right Nothing
|
||||
blank _ (Just "") = Right Nothing
|
||||
blank f (Just t) = either Left (Right . Just) $ f t
|
||||
blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
|
||||
blank _ [] = Right Nothing
|
||||
blank _ ("":_) = Right Nothing
|
||||
blank f (x:_) = either Left (Right . Just) $ f x
|
||||
|
||||
|
||||
|
||||
intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i
|
||||
intField = Field
|
||||
@ -115,13 +121,14 @@ intField = Field
|
||||
case Data.Text.Read.signed Data.Text.Read.decimal s of
|
||||
Right (a, "") -> Right a
|
||||
_ -> Left $ MsgInvalidInteger s
|
||||
, fieldRender = pack . showI
|
||||
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}">
|
||||
<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
}
|
||||
where
|
||||
showVal = either id (pack . showI)
|
||||
showI x = show (fromIntegral x :: Integer)
|
||||
|
||||
doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double
|
||||
@ -130,33 +137,34 @@ doubleField = Field
|
||||
case Data.Text.Read.double s of
|
||||
Right (a, "") -> Right a
|
||||
_ -> Left $ MsgInvalidNumber s
|
||||
, fieldRender = pack . show
|
||||
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
}
|
||||
where showVal = either id (pack . show)
|
||||
|
||||
dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day
|
||||
dayField = Field
|
||||
{ fieldParse = blank $ parseDate . unpack
|
||||
, fieldRender = pack . show
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
|
||||
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
}
|
||||
where showVal = either id (pack . show)
|
||||
|
||||
timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay
|
||||
timeField = Field
|
||||
{ fieldParse = blank $ parseTime . unpack
|
||||
, fieldRender = pack . show . roundFullSeconds
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
|
||||
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
}
|
||||
where
|
||||
showVal = either id (pack . show . roundFullSeconds)
|
||||
roundFullSeconds tod =
|
||||
TimeOfDay (todHour tod) (todMin tod) fullSec
|
||||
where
|
||||
@ -165,12 +173,12 @@ timeField = Field
|
||||
htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html
|
||||
htmlField = Field
|
||||
{ fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
|
||||
, fieldRender = pack . renderHtml
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<textarea id="#{theId}" name="#{name}" .html>#{val}
|
||||
<textarea id="#{theId}" name="#{name}" .html>#{showVal val}
|
||||
|]
|
||||
}
|
||||
where showVal = either id (pack . renderHtml)
|
||||
|
||||
-- | A newtype wrapper around a 'String' that converts newlines to HTML
|
||||
-- br-tags.
|
||||
@ -192,41 +200,37 @@ instance ToHtml Textarea where
|
||||
|
||||
textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea
|
||||
textareaField = Field
|
||||
{ fieldParse = blank $ Right . Textarea
|
||||
, fieldRender = unTextarea
|
||||
{ fieldParse = blank $ Right . Textarea
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<textarea id="#{theId}" name="#{name}">#{val}
|
||||
<textarea id="#{theId}" name="#{name}">#{either id unTextarea val}
|
||||
|]
|
||||
}
|
||||
|
||||
hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
hiddenField = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val _isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input type="hidden" id="#{theId}" name="#{name}" value="#{val}">
|
||||
<input type="hidden" id="#{theId}" name="#{name}" value="#{either id id val}">
|
||||
|]
|
||||
}
|
||||
|
||||
textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
textField = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq ->
|
||||
[WHAMLET|
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{val}">
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{either id id val}">
|
||||
|]
|
||||
}
|
||||
|
||||
passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
|
||||
passwordField = Field
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{val}">
|
||||
<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{either id id val}">
|
||||
|]
|
||||
}
|
||||
|
||||
@ -274,21 +278,19 @@ emailField = Field
|
||||
\s -> if Email.isValid (unpack s)
|
||||
then Right s
|
||||
else Left $ MsgInvalidEmail s
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq -> addHamlet
|
||||
[HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}">
|
||||
<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{either id id val}">
|
||||
|]
|
||||
}
|
||||
|
||||
type AutoFocus = Bool
|
||||
searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text
|
||||
searchField autoFocus = Field
|
||||
{ fieldParse = blank Right
|
||||
, fieldRender = id
|
||||
{ fieldParse = blank Right
|
||||
, fieldView = \theId name val isReq -> do
|
||||
addHtml [HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}">
|
||||
<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|
||||
|]
|
||||
when autoFocus $ do
|
||||
addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script>
|
||||
@ -305,10 +307,9 @@ urlField = Field
|
||||
case parseURI $ unpack s of
|
||||
Nothing -> Left $ MsgInvalidUrl s
|
||||
Just _ -> Right s
|
||||
, fieldRender = id
|
||||
, fieldView = \theId name val isReq -> addHtml
|
||||
[HAMLET|
|
||||
<input ##{theId} name=#{name} type=url :isReq:required value=#{val}>
|
||||
<input ##{theId} name=#{name} type=url :isReq:required value=#{either id id val}>
|
||||
|]
|
||||
}
|
||||
|
||||
@ -318,6 +319,11 @@ selectField = selectFieldHelper
|
||||
(\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|])
|
||||
(\_theId _name value isSel text -> addHtml [HTML|<option value=#{value} :isSel:selected>#{text}|])
|
||||
|
||||
multiSelectField :: (Show a, Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage [a]
|
||||
multiSelectField = multiSelectFieldHelper
|
||||
(\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|])
|
||||
(\_theId _name value isSel text -> addHtml [HTML|<option value=#{value} :isSel:selected>#{text}|])
|
||||
|
||||
radioField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a
|
||||
radioField = selectFieldHelper
|
||||
(\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
|
||||
@ -334,29 +340,52 @@ radioField = selectFieldHelper
|
||||
|
||||
boolField :: (Monad monad, RenderMessage master FormMessage) => Field (GGWidget master (GGHandler sub master monad) ()) FormMessage Bool
|
||||
boolField = Field
|
||||
{ fieldParse = \s ->
|
||||
case s of
|
||||
Nothing -> Right Nothing
|
||||
Just "" -> Right Nothing
|
||||
Just "none" -> Right Nothing
|
||||
Just "yes" -> Right $ Just True
|
||||
Just "no" -> Right $ Just False
|
||||
Just t -> Left $ MsgInvalidBool t
|
||||
, fieldRender = \a -> if a then "yes" else "no"
|
||||
, fieldView = \theId name val isReq -> [WHAMLET|
|
||||
$if not isReq
|
||||
<input id=#{theId}-none type=radio name=#{name} value=none :isNone val:checked>
|
||||
<label for=#{theId}-none>_{MsgSelectNone}
|
||||
{ fieldParse = boolParser
|
||||
, fieldView = \theId name val isReq -> [WHAMLET|
|
||||
$if not isReq
|
||||
<input id=#{theId}-none type=radio name=#{name} value=none checked>
|
||||
<label for=#{theId}-none>_{MsgSelectNone}
|
||||
|
||||
<input id=#{theId}-yes type=radio name=#{name} value=yes :(==) val "yes":checked>
|
||||
|
||||
<input id=#{theId}-yes 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 :(==) val "no":checked>
|
||||
<input id=#{theId}-no type=radio name=#{name} value=no :showVal not val:checked>
|
||||
<label for=#{theId}-no>_{MsgBoolNo}
|
||||
|]
|
||||
}
|
||||
where
|
||||
isNone val = not $ val `elem` ["yes", "no"]
|
||||
boolParser [] = Right Nothing
|
||||
boolParser (x:_) = case x of
|
||||
"" -> Right Nothing
|
||||
"none" -> Right Nothing
|
||||
"yes" -> Right $ Just True
|
||||
"no" -> Right $ Just False
|
||||
t -> Left $ MsgInvalidBool t
|
||||
showVal = either (\_ -> False)
|
||||
|
||||
multiSelectFieldHelper :: (Show a, Eq a, Monad monad)
|
||||
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
|
||||
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage [a]
|
||||
multiSelectFieldHelper outside inside opts = Field
|
||||
{ fieldParse = selectParser
|
||||
, fieldView = \theId name vals _ ->
|
||||
outside theId name $ do
|
||||
flip mapM_ pairs $ \pair -> inside
|
||||
theId
|
||||
name
|
||||
(pack $ show $ fst pair)
|
||||
((fst pair) `elem` (either (\_ -> []) selectedVals vals)) -- We are presuming that select fields can't hold invalid values
|
||||
(fst $ snd pair)
|
||||
}
|
||||
where
|
||||
pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
|
||||
rpairs = zip (map snd opts) [1 :: Int ..]
|
||||
selectedVals vals = map snd $ filter (\y -> fst y `elem` vals) rpairs
|
||||
selectParser [] = Right Nothing
|
||||
selectParser xs | not $ null (["", "none"] `intersect` xs) = Right Nothing
|
||||
| otherwise = (Right . Just . map snd . catMaybes . map (\y -> lookup y pairs) . nub . map fst . rights . map Data.Text.Read.decimal) xs
|
||||
|
||||
selectFieldHelper :: (Eq a, Monad monad)
|
||||
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
|
||||
@ -364,29 +393,29 @@ selectFieldHelper :: (Eq a, Monad monad)
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
|
||||
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
|
||||
selectFieldHelper outside onOpt inside opts = Field
|
||||
{ fieldParse = \s ->
|
||||
case s of
|
||||
Nothing -> Right Nothing
|
||||
Just "" -> Right Nothing
|
||||
Just "none" -> Right Nothing
|
||||
Just x ->
|
||||
case Data.Text.Read.decimal x of
|
||||
Right (a, "") ->
|
||||
case lookup a pairs of
|
||||
Nothing -> Left $ MsgInvalidEntry x
|
||||
Just y -> Right $ Just $ snd y
|
||||
_ -> Left $ MsgInvalidNumber x
|
||||
, fieldRender = \a -> maybe "" (pack . show) $ lookup a rpairs
|
||||
{ fieldParse = selectParser
|
||||
, fieldView = \theId name val isReq ->
|
||||
outside theId name $ do
|
||||
unless isReq $ onOpt theId name $ not $ val `elem` map (pack . show . fst) pairs
|
||||
unless isReq $ onOpt theId name $ not $ (render val) `elem` map (pack . show . fst) pairs
|
||||
flip mapM_ pairs $ \pair -> inside
|
||||
theId
|
||||
name
|
||||
(pack $ show $ fst pair)
|
||||
(val == pack (show $ fst pair))
|
||||
((render val) == pack (show $ fst pair))
|
||||
(fst $ snd pair)
|
||||
}
|
||||
where
|
||||
pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
|
||||
rpairs = zip (map snd opts) [1 :: Int ..]
|
||||
render (Left _) = ""
|
||||
render (Right a) = maybe "" (pack . show) $ lookup a rpairs
|
||||
selectParser [] = Right Nothing
|
||||
selectParser (s:_) = case s of
|
||||
"" -> Right Nothing
|
||||
"none" -> Right Nothing
|
||||
x -> case Data.Text.Read.decimal x of
|
||||
Right (a, "") ->
|
||||
case lookup a pairs of
|
||||
Nothing -> Left $ MsgInvalidEntry x
|
||||
Just y -> Right $ Just $ snd y
|
||||
_ -> Left $ MsgInvalidNumber x
|
||||
|
||||
@ -40,7 +40,7 @@ import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)
|
||||
import Network.Wai (requestMethod)
|
||||
import Text.Hamlet.NonPoly (html)
|
||||
import Data.Monoid (mempty)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
@ -104,6 +104,7 @@ mhelper :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
|
||||
-> (a -> FormResult b) -- ^ on success
|
||||
-> Bool -- ^ is it required?
|
||||
-> Form master (GGHandler sub master m) (FormResult b, FieldView xml)
|
||||
|
||||
mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
|
||||
mp <- askParams
|
||||
name <- maybe newFormIdent return fsName
|
||||
@ -112,16 +113,15 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
|
||||
let mr2 = renderMessage master langs
|
||||
let (res, val) =
|
||||
case mp of
|
||||
Nothing -> (FormMissing, maybe "" fieldRender mdef)
|
||||
Nothing -> (FormMissing, maybe (Left "") Right mdef)
|
||||
Just p ->
|
||||
let mval = lookup name p
|
||||
valB = fromMaybe "" mval
|
||||
in case fieldParse mval of
|
||||
Left e -> (FormFailure [renderMessage master langs e], valB)
|
||||
let mvals = map snd $ filter (\(n,_) -> n == name) p
|
||||
in case fieldParse mvals of
|
||||
Left e -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))
|
||||
Right mx ->
|
||||
case mx of
|
||||
Nothing -> (onMissing master langs, valB)
|
||||
Just x -> (onFound x, valB)
|
||||
Nothing -> (onMissing master langs, Left "")
|
||||
Just x -> (onFound x, Right x)
|
||||
return (res, FieldView
|
||||
{ fvLabel = toHtml $ mr2 fsLabel
|
||||
, fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
|
||||
|
||||
@ -33,14 +33,16 @@ instance Applicative (FormInput master) where
|
||||
|
||||
ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
|
||||
ireq field name = FormInput $ \m l env ->
|
||||
case fieldParse field $ lookup name env of
|
||||
Left e -> Left $ (:) $ renderMessage m l e
|
||||
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
|
||||
Right (Just a) -> Right a
|
||||
let filteredEnv = map snd $ filter (\y -> fst y == name) env
|
||||
in case fieldParse field $ filteredEnv of
|
||||
Left e -> Left $ (:) $ renderMessage m l e
|
||||
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
|
||||
Right (Just a) -> Right a
|
||||
|
||||
iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a)
|
||||
iopt field name = FormInput $ \m l env ->
|
||||
case fieldParse field $ lookup name env of
|
||||
let filteredEnv = map snd $ filter (\y -> fst y == name) env
|
||||
in case fieldParse field $ filteredEnv of
|
||||
Left e -> Left $ (:) $ renderMessage m l e
|
||||
Right x -> Right x
|
||||
|
||||
|
||||
@ -63,10 +63,10 @@ class YesodJquery a where
|
||||
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
|
||||
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
|
||||
|
||||
blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)
|
||||
blank _ Nothing = Right Nothing
|
||||
blank _ (Just "") = Right Nothing
|
||||
blank f (Just t) = either Left (Right . Just) $ f t
|
||||
blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
|
||||
blank _ [] = Right Nothing
|
||||
blank _ ("":_) = Right Nothing
|
||||
blank f (x:_) = either Left (Right . Just) $ f x
|
||||
|
||||
jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day
|
||||
jqueryDayField jds = Field
|
||||
@ -75,10 +75,9 @@ jqueryDayField jds = Field
|
||||
Right
|
||||
. readMay
|
||||
. unpack
|
||||
, fieldRender = pack . show
|
||||
, fieldView = \theId name val isReq -> do
|
||||
addHtml [HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">
|
||||
<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
addScript' urlJqueryJs
|
||||
addScript' urlJqueryUiJs
|
||||
@ -94,6 +93,7 @@ $(function(){$("##{theId}").datepicker({
|
||||
|]
|
||||
}
|
||||
where
|
||||
showVal = either id (pack . show)
|
||||
jsBool True = "true" :: Text
|
||||
jsBool False = "false" :: Text
|
||||
mos (Left i) = show i
|
||||
@ -126,10 +126,9 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
|
||||
jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime
|
||||
jqueryDayTimeField = Field
|
||||
{ fieldParse = blank $ parseUTCTime . unpack
|
||||
, fieldRender = pack . jqueryDayTimeUTCTime
|
||||
, fieldView = \theId name val isReq -> do
|
||||
addHtml [HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">
|
||||
<input id="#{theId}" name="#{name}" :isReq:required="" value="#{showVal val}">
|
||||
|]
|
||||
addScript' urlJqueryJs
|
||||
addScript' urlJqueryUiJs
|
||||
@ -139,6 +138,8 @@ jqueryDayTimeField = Field
|
||||
$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});
|
||||
|]
|
||||
}
|
||||
where
|
||||
showVal = either id (pack . jqueryDayTimeUTCTime)
|
||||
|
||||
parseUTCTime :: String -> Either FormMessage UTCTime
|
||||
parseUTCTime s =
|
||||
@ -152,11 +153,10 @@ parseUTCTime s =
|
||||
|
||||
jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) FormMessage Text
|
||||
jqueryAutocompleteField src = Field
|
||||
{ fieldParse = Right
|
||||
, fieldRender = id
|
||||
{ fieldParse = blank $ Right
|
||||
, fieldView = \theId name val isReq -> do
|
||||
addHtml [HAMLET|\
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}" .autocomplete>
|
||||
<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
|
||||
|]
|
||||
addScript' urlJqueryJs
|
||||
addScript' urlJqueryUiJs
|
||||
|
||||
@ -26,15 +26,16 @@ class YesodNic a where
|
||||
urlNicEdit :: a -> Either (Route a) Text
|
||||
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
|
||||
|
||||
blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)
|
||||
blank _ Nothing = Right Nothing
|
||||
blank _ (Just "") = Right Nothing
|
||||
blank f (Just t) = either Left (Right . Just) $ f t
|
||||
blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
|
||||
blank _ [] = Right Nothing
|
||||
blank _ ("":_) = Right Nothing
|
||||
blank f (x:_) = either Left (Right . Just) $ f x
|
||||
|
||||
|
||||
|
||||
nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html
|
||||
nicHtmlField = Field
|
||||
{ fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME
|
||||
, fieldRender = pack . renderHtml
|
||||
, fieldView = \theId name val _isReq -> do
|
||||
addHtml
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
@ -42,7 +43,7 @@ nicHtmlField = Field
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<textarea id="#{theId}" name="#{name}" .html>#{val}
|
||||
<textarea id="#{theId}" name="#{name}" .html>#{showVal val}
|
||||
|]
|
||||
addScript' urlNicEdit
|
||||
addJulius
|
||||
@ -54,6 +55,8 @@ nicHtmlField = Field
|
||||
bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")});
|
||||
|]
|
||||
}
|
||||
where
|
||||
showVal = either id (pack . renderHtml)
|
||||
|
||||
addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
|
||||
addScript' f = do
|
||||
|
||||
@ -114,11 +114,10 @@ data FieldView xml = FieldView
|
||||
}
|
||||
|
||||
data Field xml msg a = Field
|
||||
{ fieldParse :: Maybe Text -> Either msg (Maybe a)
|
||||
, fieldRender :: a -> Text
|
||||
{ fieldParse :: [Text] -> Either msg (Maybe a)
|
||||
, fieldView :: Text -- ^ ID
|
||||
-> Text -- ^ name
|
||||
-> Text -- ^ value
|
||||
-> Either Text a -- ^ value could be invalid text or a legitimate a
|
||||
-> Bool -- ^ required?
|
||||
-> xml
|
||||
}
|
||||
|
||||
@ -12,12 +12,14 @@ data Fruit = Apple | Banana | Pear
|
||||
fruits :: [(Text, Fruit)]
|
||||
fruits = map (\x -> (pack $ show x, x)) [minBound..maxBound]
|
||||
|
||||
myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,)
|
||||
myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
|
||||
<*> areq boolField "Bool field" Nothing
|
||||
<*> aopt boolField "Opt bool field" Nothing
|
||||
<*> areq textField "Text field" Nothing
|
||||
<*> areq (selectField fruits) "Select field" Nothing
|
||||
<*> aopt (selectField fruits) "Opt select field" Nothing
|
||||
<*> areq (multiSelectField fruits) "Multi select field" Nothing
|
||||
<*> aopt (multiSelectField fruits) "Opt multi select field" Nothing
|
||||
<*> aopt intField "Opt int field" Nothing
|
||||
<*> aopt (radioField fruits) "Opt radio" Nothing
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user