From 1421bacd49d1ee09c7cd3069da2f1a6ff97540b3 Mon Sep 17 00:00:00 2001
From: DavidM <david.dmcbride@moxune.com>
Date: Tue, 21 Jun 2011 18:26:59 -0400
Subject: [PATCH] Invalid input into a field would not repopulate.

Like if you put "asdf" into an int field, the page would not refresh
with the errant "asdf" in it, because asdf can't be represented as an
int.
---
 Yesod/Form/Fields.hs    | 35 ++++++++++++++++++-----------------
 Yesod/Form/Functions.hs |  9 +++++----
 Yesod/Form/Jquery.hs    |  6 +++---
 Yesod/Form/Nic.hs       |  2 +-
 Yesod/Form/Types.hs     |  2 +-
 5 files changed, 28 insertions(+), 26 deletions(-)

diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs
index b9ed0e39..741ecbb9 100644
--- a/Yesod/Form/Fields.hs
+++ b/Yesod/Form/Fields.hs
@@ -128,7 +128,7 @@ intField = Field
 |]
     }
   where
-    showVal = maybe "" (pack . showI)
+    showVal = either id (pack . showI)
     showI x = show (fromIntegral x :: Integer)
 
 doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double
@@ -143,7 +143,7 @@ doubleField = Field
 <input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{showVal val}">
 |]
     }
-  where showVal = maybe "" (pack . show)
+  where showVal = either id (pack . show)
 
 dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day
 dayField = Field
@@ -153,7 +153,7 @@ dayField = Field
 <input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{showVal val}">
 |]
     }
-  where showVal = maybe "" (pack . show)
+  where showVal = either id (pack . show)
 
 timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay
 timeField = Field
@@ -164,7 +164,7 @@ timeField = Field
 |]
     }
   where
-    showVal = maybe "" (pack . show . roundFullSeconds)
+    showVal = either id (pack . show . roundFullSeconds)
     roundFullSeconds tod =
         TimeOfDay (todHour tod) (todMin tod) fullSec
       where
@@ -178,7 +178,7 @@ htmlField = Field
 <textarea id="#{theId}" name="#{name}" .html>#{showVal val}
 |]
     }
-  where showVal = maybe "" (pack . renderHtml)
+  where showVal = either id (pack . renderHtml)
 
 -- | A newtype wrapper around a 'String' that converts newlines to HTML
 -- br-tags.
@@ -203,7 +203,7 @@ textareaField = Field
     { fieldParse =  blank $ Right . Textarea
     , fieldView = \theId name val _isReq -> addHamlet
         [HAMLET|\
-<textarea id="#{theId}" name="#{name}">#{maybe "" unTextarea val}
+<textarea id="#{theId}" name="#{name}">#{either id unTextarea val}
 |]
     }
 
@@ -212,7 +212,7 @@ hiddenField = Field
     { fieldParse = blank $ Right
     , fieldView = \theId name val _isReq -> addHamlet
         [HAMLET|\
-<input type="hidden" id="#{theId}" name="#{name}" value="#{maybe "" id val}">
+<input type="hidden" id="#{theId}" name="#{name}" value="#{either id id val}">
 |]
     }
 
@@ -221,7 +221,7 @@ textField = Field
     { fieldParse = blank $ Right
     , fieldView = \theId name val isReq ->
         [WHAMLET|
-<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{maybe "" id val}">
+<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{either id id val}">
 |]
     }
 
@@ -230,7 +230,7 @@ passwordField = Field
     { fieldParse = blank $ Right
     , fieldView = \theId name val isReq -> addHamlet
         [HAMLET|\
-<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{maybe "" id val}">
+<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{either id id val}">
 |]
     }
 
@@ -280,7 +280,7 @@ emailField = Field
                 else Left $ MsgInvalidEmail s
     , fieldView = \theId name val isReq -> addHamlet
         [HAMLET|\
-<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{maybe "" id val}">
+<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{either id id val}">
 |]
     }
 
@@ -290,7 +290,7 @@ searchField autoFocus = Field
     { fieldParse =  blank Right
     , fieldView = \theId name val isReq -> do
         addHtml [HAMLET|\
-<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{maybe "" id 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> 
@@ -309,7 +309,7 @@ urlField = Field
             Just _ -> Right s
     , fieldView = \theId name val isReq -> addHtml
         [HAMLET|
-<input ##{theId} name=#{name} type=url :isReq:required value=#{maybe "" id val}>
+<input ##{theId} name=#{name} type=url :isReq:required value=#{either id id val}>
 |]
     }
 
@@ -347,10 +347,10 @@ boolField = Field
       <label for=#{theId}-none>_{MsgSelectNone}
 
 
-<input id=#{theId}-yes type=radio name=#{name} value=yes :maybe False id val: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 :maybe False not val:checked>
+<input id=#{theId}-no type=radio name=#{name} value=no :showVal not val:checked>
 <label for=#{theId}-no>_{MsgBoolNo}
 |]
     }
@@ -362,6 +362,7 @@ boolField = Field
       "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 ())
@@ -375,7 +376,7 @@ multiSelectFieldHelper outside inside opts = Field
                 theId
                 name
                 (pack $ show $ fst pair)
-                ((fst pair) `elem` (maybe [] selectedVals vals))
+                ((fst pair) `elem` (either (\_ -> []) selectedVals vals)) -- We are presuming that select fields can't hold invalid values
                 (fst $ snd pair)
     }
   where
@@ -406,8 +407,8 @@ selectFieldHelper outside onOpt inside opts = Field
   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
+    render (Left _) = ""
+    render (Right a) = maybe "" (pack . show) $ lookup a rpairs
     selectParser [] = Right Nothing
     selectParser (s:_) = case s of
             "" -> Right Nothing
diff --git a/Yesod/Form/Functions.hs b/Yesod/Form/Functions.hs
index cb42bdb6..8cae6f62 100644
--- a/Yesod/Form/Functions.hs
+++ b/Yesod/Form/Functions.hs
@@ -40,6 +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 (listToMaybe)
 import Yesod.Message (RenderMessage (..))
 
 #if __GLASGOW_HASKELL__ >= 700
@@ -112,15 +113,15 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
     let mr2 = renderMessage master langs
     let (res, val) =
             case mp of
-                Nothing -> (FormMissing, mdef)
+                Nothing -> (FormMissing, maybe (Left "") Right mdef)
                 Just p ->
                     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
+                            Left e -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))
                             Right mx ->
                                 case mx of
-                                    Nothing -> (onMissing master langs, Nothing)
-                                    Just x -> (onFound x, Just x)
+                                    Nothing -> (onMissing master langs, Left "")
+                                    Just x -> (onFound x, Right x)
     return (res, FieldView
         { fvLabel = toHtml $ mr2 fsLabel
         , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs
index 10c3ff58..8e9e4bf9 100644
--- a/Yesod/Form/Jquery.hs
+++ b/Yesod/Form/Jquery.hs
@@ -93,7 +93,7 @@ $(function(){$("##{theId}").datepicker({
 |]
     }
   where
-    showVal = maybe "" (pack . show)
+    showVal = either id (pack . show)
     jsBool True = "true" :: Text
     jsBool False = "false" :: Text
     mos (Left i) = show i
@@ -139,7 +139,7 @@ $(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}
 |]
     }
   where
-   showVal  = maybe "" (pack . jqueryDayTimeUTCTime)
+   showVal  = either id (pack . jqueryDayTimeUTCTime)
 
 parseUTCTime :: String -> Either FormMessage UTCTime
 parseUTCTime s =
@@ -156,7 +156,7 @@ jqueryAutocompleteField src = Field
     { fieldParse = blank $ Right
     , fieldView = \theId name val isReq -> do
         addHtml [HAMLET|\
-<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{maybe "" id val}" .autocomplete>
+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
 |]
         addScript' urlJqueryJs
         addScript' urlJqueryUiJs
diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs
index 2ca155d5..2b8502d5 100644
--- a/Yesod/Form/Nic.hs
+++ b/Yesod/Form/Nic.hs
@@ -56,7 +56,7 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{th
 |]
     }
   where
-    showVal = maybe "" (pack . renderHtml)
+    showVal = either id (pack . renderHtml)
 
 addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()
 addScript' f = do
diff --git a/Yesod/Form/Types.hs b/Yesod/Form/Types.hs
index a181a75e..874c5f93 100644
--- a/Yesod/Form/Types.hs
+++ b/Yesod/Form/Types.hs
@@ -117,7 +117,7 @@ data Field xml msg a = Field
     { fieldParse :: [Text] -> Either msg (Maybe a)
     , fieldView :: Text -- ^ ID
                 -> Text -- ^ name
-                -> Maybe a -- ^ value
+                -> Either Text a -- ^ value could be invalid text or a legitimate a
                 -> Bool -- ^ required?
                 -> xml
     }