From 4d5c12393520d41e4adaf8e7c1a083b207d6e748 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 17 Jan 2012 14:13:07 +0200
Subject: [PATCH] Better multiSelectField (#183)

---
 yesod-core/Yesod/Widget.hs      |  3 +-
 yesod-form/Yesod/Form/Fields.hs | 83 +++++++++++++++++----------------
 yesod-form/hello-forms.hs       | 10 ++--
 3 files changed, 49 insertions(+), 47 deletions(-)

diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs
index 4291218d..da40e1f3 100644
--- a/yesod-core/Yesod/Widget.hs
+++ b/yesod-core/Yesod/Widget.hs
@@ -86,6 +86,7 @@ import qualified Text.Hamlet as NP
 import Data.Text.Lazy.Builder (fromLazyText)
 import Text.Blaze (toHtml, preEscapedLazyText)
 import Control.Monad.Base (MonadBase (liftBase))
+import Control.Arrow (first)
 
 -- | A generic widget, allowing specification of both the subsite and master
 -- site datatypes. While this is simply a @WriterT@, we define a newtype for
@@ -320,7 +321,7 @@ liftW = lift
 
 -- Instances for GWidget
 instance Functor (GWidget sub master) where
-    fmap f (GWidget x) = GWidget (fmap (\(a, w) -> (f a, w)) x)
+    fmap f (GWidget x) = GWidget (fmap (first f) x)
 instance Applicative (GWidget sub master) where
     pure a = GWidget $ pure (a, mempty)
     GWidget f <*> GWidget v =
diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs
index 7b11cc9a..14fc175d 100644
--- a/yesod-form/Yesod/Form/Fields.hs
+++ b/yesod-form/Yesod/Form/Fields.hs
@@ -18,22 +18,23 @@ module Yesod.Form.Fields
     , htmlField
     , emailField
     , searchField
-    , selectField
-    , multiSelectField
     , AutoFocus
     , urlField
     , doubleField
     , parseDate
     , parseTime
     , Textarea (..)
-    , radioField
     , boolField
       -- * File 'AForm's
     , fileAFormReq
     , fileAFormOpt
       -- * Options
-    , selectField'
-    , radioField'
+    , selectField
+    , selectFieldList
+    , radioField
+    , radioFieldList
+    , multiSelectField
+    , multiSelectFieldList
     , Option (..)
     , OptionList (..)
     , mkOptionList
@@ -93,6 +94,7 @@ import Control.Arrow ((&&&))
 #define HTML $html
 #endif
 
+import Control.Applicative ((<$>))
 
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
@@ -303,25 +305,48 @@ urlField = Field
 |]
     }
 
-selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
-selectField = selectField' . optionsPairs
+selectFieldList :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
+selectFieldList = selectField . optionsPairs
 
-selectField' :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
-selectField' = selectFieldHelper
+selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
+selectField = selectFieldHelper
     (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside
     (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
     (\_theId _name theClass value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected :not (null theClass):class="#{T.intercalate " " theClass}">#{text}|]) -- inside
 
-multiSelectField :: (Show a, Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master [a]
-multiSelectField = multiSelectFieldHelper
-    (\theId name inside -> [WHAMLET|<select ##{theId} multiple name=#{name}>^{inside}|])
-    (\_theId _name theClass value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected :not (null theClass):class="#{T.intercalate " " theClass}">#{text}|])
+multiSelectFieldList :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master [a]
+multiSelectFieldList = multiSelectField . optionsPairs
 
-radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
-radioField = radioField' . optionsPairs
+multiSelectField :: (Eq a, RenderMessage master FormMessage)
+                 => GHandler sub master (OptionList a)
+                 -> Field sub master [a]
+multiSelectField ioptlist =
+    Field parse view
+  where
+    parse [] = return $ Right Nothing
+    parse optlist = do
+        mapopt <- olReadExternal <$> ioptlist
+        case mapM mapopt optlist of
+             Nothing -> return $ Left "Error parsing values"
+             Just res -> return $ Right $ Just res
 
-radioField' :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
-radioField' = selectFieldHelper
+    view theId name theClass val isReq = do
+        opts <- fmap olOptions $ lift ioptlist
+        let selOpts = map (id &&& (optselected val)) opts
+        [whamlet|
+            <select ##{theId} name=#{name} :isReq:required multiple :not (null theClass):class=#{T.intercalate " " theClass}>
+                $forall (opt, optsel) <- selOpts
+                    <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}
+                |]
+        where
+            optselected (Left _) _ = False
+            optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
+
+radioFieldList :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
+radioFieldList = radioField . optionsPairs
+
+radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
+radioField = selectFieldHelper
     (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
     (\theId name isSel -> [WHAMLET|
 <div>
@@ -360,30 +385,6 @@ boolField = Field
       t -> Left $ SomeMessage $ MsgInvalidBool t
     showVal = either (\_ -> False)
 
-multiSelectFieldHelper :: (Show a, Eq a)
-        => (Text -> Text -> GWidget sub master () -> GWidget sub master ())
-        -> (Text -> Text -> [Text] -> Text -> Bool -> Text -> GWidget sub master ())
-        -> [(Text, a)] -> Field sub master [a]
-multiSelectFieldHelper outside inside opts = Field
-    { fieldParse = return . selectParser
-    , fieldView = \theId name theClass vals _ ->
-        outside theId name $ do
-            flip mapM_ pairs $ \pair -> inside
-                theId
-                name
-                theClass
-                (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
-
 data OptionList a = OptionList
     { olOptions :: [Option a]
     , olReadExternal :: Text -> Maybe a
diff --git a/yesod-form/hello-forms.hs b/yesod-form/hello-forms.hs
index ff7b94a1..d33b5938 100644
--- a/yesod-form/hello-forms.hs
+++ b/yesod-form/hello-forms.hs
@@ -27,12 +27,12 @@ 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
+    <*> areq (selectFieldList fruits) "Select field" Nothing
+    <*> aopt (selectFieldList fruits) "Opt select field" Nothing
+    <*> areq (multiSelectFieldList fruits) "Multi select field" Nothing
+    <*> aopt (multiSelectFieldList fruits) "Opt multi select field" Nothing
     <*> aopt intField "Opt int field" Nothing
-    <*> aopt (radioField fruits) "Opt radio" Nothing
+    <*> aopt (radioFieldList fruits) "Opt radio" Nothing
 
 data HelloForms = HelloForms