Option (for selectField)

yesod-form/Yesod/Form/Fields.hs

@@ -31,6 +31,13 @@ module Yesod.Form.Fields
       -- * File 'AForm's
     , fileAFormReq
     , fileAFormOpt
+      -- * Options
+    , selectField'
+    , radioField'
+    , Option (..)
+    , optionsPersist
+    , optionsPairs
+    , optionsEnum
     ) where
 
 import Yesod.Form.Types
@@ -48,7 +55,7 @@ import Text.HTML.SanitizeXSS (sanitizeBalance)
 import Control.Monad (when, unless)
 import Data.List (intersect, nub)
 import Data.Either (rights)
-import Data.Maybe (catMaybes)
+import Data.Maybe (catMaybes, listToMaybe)
 
 import qualified Blaze.ByteString.Builder.Html.Utf8 as B
 import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
@@ -60,12 +67,16 @@ import qualified Data.ByteString.Lazy as L
 import Data.Text (Text, unpack, pack)
 import qualified Data.Text.Read
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Class (lift)
 
 import Control.Applicative ((<$>))
 import qualified Data.Map as Map
-import Yesod.Handler (newIdent)
+import Yesod.Handler (newIdent, liftIOHandler)
 import Yesod.Request (FileInfo)
 
+import Yesod.Core (toSinglePiece, GGHandler, SinglePiece)
+import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistBackend)
+
 #if __GLASGOW_HASKELL__ >= 700
 #define WHAMLET whamlet
 #define HAMLET hamlet
@@ -290,10 +301,13 @@ urlField = Field
     }
 
 selectField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
-selectField = selectFieldHelper
+selectField = selectField' . optionsPairs
-    (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|])
+
-    (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|])
+selectField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO [Option a] -> Field sub master a
-    (\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
+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 value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|]) -- inside
 
 multiSelectField :: (Show a, Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master [a]
 multiSelectField = multiSelectFieldHelper
@@ -301,7 +315,10 @@ multiSelectField = multiSelectFieldHelper
     (\_theId _name value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected>#{text}|])
 
 radioField :: (Eq a, RenderMessage master FormMessage) => [(Text, a)] -> Field sub master a
-radioField = selectFieldHelper
+radioField = radioField' . optionsPairs
+
+radioField' :: (Eq a, RenderMessage master FormMessage) => GGHandler sub master IO [Option a] -> Field sub master a
+radioField' = selectFieldHelper
     (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])
     (\theId name isSel -> [WHAMLET|
 <div>
@@ -363,39 +380,65 @@ multiSelectFieldHelper outside inside opts = Field
     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 Option a = Option
+    { optionDisplay :: Text
+    , optionInternalValue :: a
+    , optionExternalValue :: Text
+    }
+
+optionsPairs :: [(Text, a)] -> GGHandler sub master IO [Option a]
+optionsPairs = return . zipWith (\external (display, internal) -> Option
+    { optionDisplay = display
+    , optionInternalValue = internal
+    , optionExternalValue = pack $ show external
+    }) [1 :: Int ..]
+
+optionsEnum :: (Show a, Enum a, Bounded a) => GGHandler sub master IO [Option a]
+optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
+
+optionsPersist :: ( YesodPersist master, PersistEntity a, PersistBackend (YesodPersistBackend master) (GGHandler sub master IO)
+                  , SinglePiece (Key (YesodPersistBackend master) a)
+                  )
+               => [Filter a] -> [SelectOpt a] -> (a -> Text) -> GGHandler sub master IO [Option (Key (YesodPersistBackend master) a, a)]
+optionsPersist filts ords toDisplay = do
+    pairs <- runDB $ selectList filts ords
+    return $ map (\(key, value) -> Option
+        { optionDisplay = toDisplay value
+        , optionInternalValue = (key, value)
+        , optionExternalValue = toSinglePiece key
+        }) pairs
+
 selectFieldHelper
         :: (Eq a, RenderMessage master FormMessage)
         => (Text -> Text -> GWidget sub master () -> GWidget sub master ())
         -> (Text -> Text -> Bool -> GWidget sub master ())
         -> (Text -> Text -> Text -> Bool -> Text -> GWidget sub master ())
-        -> [(Text, a)] -> Field sub master a
+        -> GGHandler sub master IO [Option a] -> Field sub master a
-selectFieldHelper outside onOpt inside opts = Field
+selectFieldHelper outside onOpt inside opts' = Field
-    { fieldParse = return . selectParser
+    { fieldParse = \x -> do
-    , fieldView = \theId name val isReq ->
+        opts <- opts'
+        return $ selectParser opts x
+    , fieldView = \theId name val isReq -> do
+        opts <- lift $ liftIOHandler opts'
         outside theId name $ do
-            unless isReq $ onOpt theId name $ not $ (render val) `elem` map (pack . show . fst) pairs
+            unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
-            flip mapM_ pairs $ \pair -> inside
+            flip mapM_ opts $ \opt -> inside
                 theId
                 name
-                (pack $ show $ fst pair)
+                (optionExternalValue opt)
-                ((render val) == pack (show $ fst pair))
+                ((render opts val) == optionExternalValue opt)
-                (fst $ snd pair)
+                (optionDisplay opt)
     }
   where
-    pairs = zip [1 :: Int ..] opts -- FIXME use IntMap
+    render _ (Left _) = ""
-    rpairs = zip (map snd opts) [1 :: Int ..]
+    render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts
-    render (Left _) = ""
+    selectParser _ [] = Right Nothing
-    render (Right a) = maybe "" (pack . show) $ lookup a rpairs
+    selectParser opts (s:_) = case s of
-    selectParser [] = Right Nothing
-    selectParser (s:_) = case s of
             "" -> Right Nothing
             "none" -> Right Nothing
-            x -> case Data.Text.Read.decimal x of
+            x -> case listToMaybe $ filter ((== x) . optionExternalValue) opts of
-                    Right (a, "") ->
+                    Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
-                        case lookup a pairs of
+                    Just y -> Right $ Just $ optionInternalValue y
-                            Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
-                            Just y -> Right $ Just $ snd y
-                    _ -> Left $ SomeMessage $ MsgInvalidNumber x
 
 fileAFormReq :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master FileInfo
 fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do

yesod-form/yesod-form.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form
-version:         0.3.2.1
+version:         0.3.3
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -15,6 +15,7 @@ description:     Form handling support for Yesod Web Framework
 library
     build-depends:   base                      >= 4        && < 5
                    , yesod-core                >= 0.9      && < 0.10
+                   , yesod-persistent          >= 0.2      && < 0.3
                    , time                      >= 1.1.4    && < 1.3
                    , hamlet                    >= 0.10     && < 0.11
                    , shakespeare-css           >= 0.10     && < 0.11