Better support for optional fields

Yesod/Form/Fields.hs

@@ -70,6 +70,8 @@ data FormMessage = MsgInvalidInteger Text
                  | MsgInvalidSecond Text
                  | MsgInvalidDay
                  | MsgCsrfWarning
+                 | MsgValueRequired
+                 | MsgInputNotFound Text
 
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t
@@ -83,10 +85,20 @@ defaultFormMessage (MsgInvalidHour t) = "Invalid hour: " `mappend` t
 defaultFormMessage (MsgInvalidMinute t) = "Invalid minute: " `mappend` t
 defaultFormMessage (MsgInvalidSecond t) = "Invalid second: " `mappend` t
 defaultFormMessage MsgCsrfWarning = "As a protection against cross-site request forgery attacks, please confirm your form submission."
+defaultFormMessage MsgValueRequired = "Value is required"
+defaultFormMessage (MsgInputNotFound t) = "Input not found: " `mappend` t
+
+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
 
 intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i
 intField = Field
-    { fieldParse = \s -> maybe (Left $ MsgInvalidInteger s) Right . readMayI $ unpack s -- FIXME Data.Text.Read
+    { fieldParse = blank $ \s ->
+        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|\
@@ -95,13 +107,13 @@ intField = Field
     }
   where
     showI x = show (fromIntegral x :: Integer)
-    readMayI s = case reads s of
-                    (x, _):_ -> Just $ fromInteger x
-                    [] -> Nothing
 
 doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double
 doubleField = Field
-    { fieldParse = \s -> maybe (Left $ MsgInvalidNumber s) Right . readMay $ unpack s -- FIXME use Data.Text.Read
+    { fieldParse = blank $ \s ->
+        case Data.Text.Read.double s of
+            Right (a, "") -> Right a
+            _ -> Left $ MsgInvalidNumber s
     , fieldRender = pack . show
     , fieldView = \theId name val isReq -> addHamlet
         [HAMLET|\
@@ -111,7 +123,7 @@ doubleField = Field
 
 dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day
 dayField = Field
-    { fieldParse = parseDate . unpack
+    { fieldParse = blank $ parseDate . unpack
     , fieldRender = pack . show
     , fieldView = \theId name val isReq -> addHamlet
         [HAMLET|\
@@ -121,7 +133,7 @@ dayField = Field
 
 timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay
 timeField = Field
-    { fieldParse = parseTime . unpack
+    { fieldParse = blank $ parseTime . unpack
     , fieldRender = pack . show . roundFullSeconds
     , fieldView = \theId name val isReq -> addHamlet
         [HAMLET|\
@@ -136,7 +148,7 @@ timeField = Field
 
 htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html
 htmlField = Field
-    { fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
+    { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
     , fieldRender = pack . renderHtml
     , fieldView = \theId name val _isReq -> addHamlet
         [HAMLET|\
@@ -164,7 +176,7 @@ instance ToHtml Textarea where
 
 textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea
 textareaField = Field
-    { fieldParse = Right . Textarea
+    { fieldParse = blank $ Right . Textarea
     , fieldRender = unTextarea
     , fieldView = \theId name val _isReq -> addHamlet
         [HAMLET|\
@@ -174,7 +186,7 @@ textareaField = Field
 
 hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
 hiddenField = Field
-    { fieldParse = Right
+    { fieldParse = blank $ Right
     , fieldRender = id
     , fieldView = \theId name val _isReq -> addHamlet
         [HAMLET|\
@@ -184,7 +196,7 @@ hiddenField = Field
 
 textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
 textField = Field
-    { fieldParse = Right
+    { fieldParse = blank $ Right
     , fieldRender = id
     , fieldView = \theId name val isReq ->
         [WHAMLET|
@@ -194,7 +206,7 @@ textField = Field
 
 passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
 passwordField = Field
-    { fieldParse = Right
+    { fieldParse = blank $ Right
     , fieldRender = id
     , fieldView = \theId name val isReq -> addHamlet
         [HAMLET|\
@@ -242,9 +254,10 @@ parseTimeHelper (h1, h2, m1, m2, s1, s2)
 
 emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
 emailField = Field
-    { fieldParse = \s -> if Email.isValid (unpack s)
+    { fieldParse = blank $
-                        then Right s
+        \s -> if Email.isValid (unpack s)
-                        else Left $ MsgInvalidEmail s
+                then Right s
+                else Left $ MsgInvalidEmail s
     , fieldRender = id
     , fieldView = \theId name val isReq -> addHamlet
         [HAMLET|\
@@ -255,7 +268,7 @@ emailField = Field
 type AutoFocus = Bool
 searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text
 searchField autoFocus = Field
-    { fieldParse = Right
+    { fieldParse = blank Right
     , fieldRender = id
     , fieldView = \theId name val isReq -> do
         addHtml [HAMLET|\
@@ -272,9 +285,10 @@ searchField autoFocus = Field
 
 urlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
 urlField = Field
-    { fieldParse = \s -> case parseURI $ unpack s of
+    { fieldParse = blank $ \s ->
-                        Nothing -> Left $ MsgInvalidUrl s
+        case parseURI $ unpack s of
-                        Just _ -> Right s
+            Nothing -> Left $ MsgInvalidUrl s
+            Just _ -> Right s
     , fieldRender = id
     , fieldView = \theId name val isReq -> addHtml
         [HAMLET|
@@ -283,14 +297,19 @@ urlField = Field
     }
 
 selectField :: (Eq a, Monad monad) => [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
-selectField opts = Field -- FIXME won't work for optional yet
+selectField opts = Field
     { fieldParse = \s ->
-        case Data.Text.Read.decimal s of
+        case s of
-            Right (a, "") ->
+            Nothing -> Right Nothing
-                case lookup a pairs of
+            Just "" -> Right Nothing
-                    Nothing -> Left $ MsgInvalidEntry s
+            Just "none" -> Right Nothing
-                    Just x -> Right $ snd x
+            Just x ->
-            _ -> Left $ MsgInvalidNumber s
+                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
     , fieldView = \theId name val isReq -> [WHAMLET|
 <select id=#{theId} name=#{name}

Yesod/Form/Functions.hs

@@ -27,7 +27,7 @@ module Yesod.Form.Functions
     ) where
 
 import Yesod.Form.Types
-import Yesod.Form.Fields (FormMessage (MsgCsrfWarning))
+import Yesod.Form.Fields (FormMessage (MsgCsrfWarning, MsgValueRequired))
 import Data.Text (Text, pack)
 import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
 import Control.Monad.Trans.Class (lift)
@@ -86,21 +86,21 @@ askFiles = do
     (x, _, _) <- ask
     return $ liftM snd x
 
-mreq :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
+mreq :: (Monad m, RenderMessage master msg, RenderMessage master msg2, RenderMessage master FormMessage)
      => Field xml msg a -> FieldSettings msg2 -> Maybe a
      -> Form master (GGHandler sub master m) (FormResult a, FieldView xml)
-mreq field fs mdef = mhelper field fs mdef (FormFailure ["Value is required"]) FormSuccess True -- TRANS
+mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
 
 mopt :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
      => Field xml msg a -> FieldSettings msg2 -> Maybe (Maybe a)
      -> Form master (GGHandler sub master m) (FormResult (Maybe a), FieldView xml)
-mopt field fs mdef = mhelper field fs (join mdef) (FormSuccess Nothing) (FormSuccess . Just) False
+mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
 
 mhelper :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
         => Field xml msg a
         -> FieldSettings msg2
         -> Maybe a
-        -> FormResult b -- ^ on missing
+        -> (master -> [Text] -> FormResult b) -- ^ on missing
         -> (a -> FormResult b) -- ^ on success
         -> Bool -- ^ is it required?
         -> Form master (GGHandler sub master m) (FormResult b, FieldView xml)
@@ -109,15 +109,19 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
     name <- maybe newFormIdent return fsName
     theId <- lift $ maybe (liftM pack newIdent) return fsId
     (_, master, langs) <- ask
-    let mr = renderMessage master langs
     let mr2 = renderMessage master langs
     let (res, val) =
             case mp of
                 Nothing -> (FormMissing, maybe "" fieldRender mdef)
                 Just p ->
-                    case fromMaybe "" $ lookup name p of
+                    let mval = lookup name p
-                        "" -> (onMissing, "") -- TRANS
+                        valB = fromMaybe "" mval
-                        x -> (either (FormFailure . return . mr) onFound $ fieldParse x, x)
+                     in case fieldParse mval of
+                            Left e -> (FormFailure [renderMessage master langs e], valB)
+                            Right mx ->
+                                case mx of
+                                    Nothing -> (onMissing master langs, valB)
+                                    Just x -> (onFound x, valB)
     return (res, FieldView
         { fvLabel = toHtml $ mr2 fsLabel
         , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
@@ -130,7 +134,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
         , fvRequired = isReq
         })
 
-areq :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)
+areq :: (Monad m, RenderMessage master msg1, RenderMessage master msg2, RenderMessage master FormMessage)
      => Field xml msg1 a -> FieldSettings msg2 -> Maybe a
      -> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) a
 areq a b = formToAForm . mreq a b

Yesod/Form/Input.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Form.Input
     ( FormInput (..)
     , runInputGet
@@ -8,11 +9,11 @@ module Yesod.Form.Input
     ) where
 
 import Yesod.Form.Types
-import Data.Text (Text, append)
+import Yesod.Form.Fields (FormMessage (MsgInputNotFound))
+import Data.Text (Text)
 import Control.Applicative (Applicative (..))
 import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod)
 import Yesod.Request (reqGetParams, languages)
-import Data.Maybe (fromMaybe)
 import Control.Monad (liftM)
 import Yesod.Widget (GWidget)
 import Yesod.Message (RenderMessage (..))
@@ -30,17 +31,18 @@ instance Applicative (FormInput master) where
             (_, Left b) -> Left b
             (Right a, Right b) -> Right $ a b
 
-ireq :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
+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 lookup name env of
+    case fieldParse field $ lookup name env of
-        Nothing -> Left $ (:) $ append "Input not found: " name -- TRANS
+        Left e -> Left $ (:) $ renderMessage m l e
-        Just x -> either (Left . (:) . renderMessage m l) Right $ fieldParse field x
+        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 fromMaybe "" $ lookup name env of
+    case fieldParse field $ lookup name env of
-        "" -> Right Nothing
+        Left e -> Left $ (:) $ renderMessage m l e
-        x -> either (Left . (:) . renderMessage m l) (Right . Just) $ fieldParse field x
+        Right x -> Right x
 
 runInputGet :: Monad monad => FormInput master a -> GGHandler sub master monad a
 runInputGet (FormInput f) = do

Yesod/Form/Jquery.hs

@@ -63,9 +63,14 @@ 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
+
 jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day
 jqueryDayField jds = Field
-    { fieldParse = maybe
+    { fieldParse = blank $ maybe
                   (Left MsgInvalidDay)
                   Right
               . readMay
@@ -120,7 +125,7 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =
 
 jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime
 jqueryDayTimeField = Field
-    { fieldParse  = parseUTCTime . unpack
+    { fieldParse  = blank $ parseUTCTime . unpack
     , fieldRender = pack . jqueryDayTimeUTCTime
     , fieldView = \theId name val isReq -> do
         addHtml [HAMLET|\

Yesod/Form/Nic.hs

@@ -26,9 +26,14 @@ 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
+
 nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html
 nicHtmlField = Field
-    { fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME
+    { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME
     , fieldRender = pack . renderHtml
     , fieldView = \theId name val _isReq -> do
         addHtml

Yesod/Form/Types.hs

@@ -113,7 +113,7 @@ data FieldView xml = FieldView
     }
 
 data Field xml msg a = Field
-    { fieldParse :: Text -> Either msg a -- FIXME probably want to make this more sophisticated, handle no form, no field
+    { fieldParse :: Maybe Text -> Either msg (Maybe a)
     , fieldRender :: a -> Text
     , fieldView :: Text -- ^ ID
                 -> Text -- ^ name