Preparing type changes for multiple select inputs.

This commit is contained in:
DavidM 2011-06-20 20:41:43 -04:00
parent 9ec28d5544
commit 64e2082049
6 changed files with 98 additions and 94 deletions

View File

@ -104,10 +104,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 +117,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 = maybe "" (pack . showI)
showI x = show (fromIntegral x :: Integer)
doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double
@ -130,33 +133,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 = maybe "" (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 = maybe "" (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 = maybe "" (pack . show . roundFullSeconds)
roundFullSeconds tod =
TimeOfDay (todHour tod) (todMin tod) fullSec
where
@ -165,12 +169,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 = maybe "" (pack . renderHtml)
-- | A newtype wrapper around a 'String' that converts newlines to HTML
-- br-tags.
@ -192,41 +196,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}">#{maybe "" 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="#{maybe "" 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="#{maybe "" 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="#{maybe "" id val}">
|]
}
@ -274,21 +274,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="#{maybe "" 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="#{maybe "" id val}">
|]
when autoFocus $ do
addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script>
@ -305,10 +303,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=#{maybe "" id val}>
|]
}
@ -334,29 +331,29 @@ 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 :maybe False 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 :maybe False 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
selectFieldHelper :: (Eq a, Monad monad)
=> (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
@ -364,29 +361,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 Nothing = ""
render (Just 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

View File

@ -40,7 +40,6 @@ 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 Yesod.Message (RenderMessage (..))
#if __GLASGOW_HASKELL__ >= 700
@ -112,16 +111,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, 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], Nothing) -- There is no way to retain the wrong value
Right mx ->
case mx of
Nothing -> (onMissing master langs, valB)
Just x -> (onFound x, valB)
Nothing -> (onMissing master langs, Nothing)
Just x -> (onFound x, Just x)
return (res, FieldView
{ fvLabel = toHtml $ mr2 fsLabel
, fvTooltip = fmap toHtml $ fmap mr2 fsTooltip

View File

@ -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

View File

@ -63,10 +63,15 @@ 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
blankMulti :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)
blankMulti _ Nothing = Right Nothing
blankMulti _ (Just "") = Right Nothing
blankMulti 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 +80,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 +98,7 @@ $(function(){$("##{theId}").datepicker({
|]
}
where
showVal = maybe "" (pack . show)
jsBool True = "true" :: Text
jsBool False = "false" :: Text
mos (Left i) = show i
@ -126,10 +131,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 +143,8 @@ jqueryDayTimeField = Field
$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});
|]
}
where
showVal = maybe "" (pack . jqueryDayTimeUTCTime)
parseUTCTime :: String -> Either FormMessage UTCTime
parseUTCTime s =
@ -152,11 +158,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="#{maybe "" id val}" .autocomplete>
|]
addScript' urlJqueryJs
addScript' urlJqueryUiJs

View File

@ -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 = maybe "" (pack . renderHtml)
addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
addScript' f = do

View File

@ -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
-> Maybe a -- ^ value
-> Bool -- ^ required?
-> xml
}