From 7d002e5d6437003908d78f9d142a06908519ed96 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 20 May 2011 12:26:37 +0300
Subject: [PATCH] boolField

---
 Yesod/Form/Fields.hs | 33 +++++++++++++++++++++++++++++++++
 hello-forms.hs       |  4 +++-
 2 files changed, 36 insertions(+), 1 deletion(-)

diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs
index 50fce93b..db11563d 100644
--- a/Yesod/Form/Fields.hs
+++ b/Yesod/Form/Fields.hs
@@ -24,6 +24,7 @@ module Yesod.Form.Fields
     , parseTime
     , Textarea (..)
     , radioField
+    , boolField
     ) where
 
 import Yesod.Form.Types
@@ -80,6 +81,9 @@ data FormMessage = MsgInvalidInteger Text
                  | MsgValueRequired
                  | MsgInputNotFound Text
                  | MsgSelectNone
+                 | MsgInvalidBool Text
+                 | MsgBoolYes
+                 | MsgBoolNo
 
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t
@@ -96,6 +100,9 @@ defaultFormMessage MsgCsrfWarning = "As a protection against cross-site request
 defaultFormMessage MsgValueRequired = "Value is required"
 defaultFormMessage (MsgInputNotFound t) = "Input not found: " `mappend` t
 defaultFormMessage MsgSelectNone = "<None>"
+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
@@ -325,6 +332,32 @@ radioField = selectFieldHelper
     <label for=#{theId}-#{value}>#{text}
 |])
 
+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}
+
+<input id=#{theId}-yes type=radio name=#{name} value=yes :(==) val "yes":checked>
+<label for=#{theId}-yes>_{MsgBoolYes}
+
+<input id=#{theId}-no type=radio name=#{name} value=no :(==) val "no":checked>
+<label for=#{theId}-no>_{MsgBoolNo}
+|]
+    }
+  where
+    isNone val = not $ val `elem` ["yes", "no"]
+
 selectFieldHelper :: (Eq a, Monad monad)
         => (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())
         -> (Text -> Text -> Bool -> GGWidget master monad ())
diff --git a/hello-forms.hs b/hello-forms.hs
index 8985b6f5..ccab8f77 100644
--- a/hello-forms.hs
+++ b/hello-forms.hs
@@ -12,7 +12,9 @@ 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