diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 9fedf1b2..b9ed0e39 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -17,6 +17,7 @@ module Yesod.Form.Fields , emailField , searchField , selectField + , multiSelectField , AutoFocus , urlField , doubleField @@ -40,6 +41,9 @@ import Network.URI (parseURI) import Database.Persist (PersistField) import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless) +import Data.List (intersect, nub) +import Data.Either (rights) +import Data.Maybe (catMaybes) import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString) @@ -315,6 +319,11 @@ selectField = selectFieldHelper (\_theId _name isSel -> [WHAMLET|_{MsgSelectNone}|]) (\_theId _name value isSel text -> addHtml [HTML|#{text}|]) +multiSelectField :: (Show a, Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage [a] +multiSelectField = multiSelectFieldHelper + (\theId name inside -> [WHAMLET|^{inside}|]) + (\_theId _name value isSel text -> addHtml [HTML|#{text}|]) + radioField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a radioField = selectFieldHelper (\theId _name inside -> [WHAMLET|^{inside}|]) @@ -354,6 +363,28 @@ boolField = Field "no" -> Right $ Just False t -> Left $ MsgInvalidBool t +multiSelectFieldHelper :: (Show a, Eq a, Monad monad) + => (Text -> Text -> GGWidget master monad () -> GGWidget master monad ()) + -> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ()) + -> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage [a] +multiSelectFieldHelper outside inside opts = Field + { fieldParse = selectParser + , fieldView = \theId name vals _ -> + outside theId name $ do + flip mapM_ pairs $ \pair -> inside + theId + name + (pack $ show $ fst pair) + ((fst pair) `elem` (maybe [] selectedVals vals)) + (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 selectFieldHelper :: (Eq a, Monad monad) => (Text -> Text -> GGWidget master monad () -> GGWidget master monad ()) diff --git a/Yesod/Form/Functions.hs b/Yesod/Form/Functions.hs index 49277705..cb42bdb6 100644 --- a/Yesod/Form/Functions.hs +++ b/Yesod/Form/Functions.hs @@ -103,6 +103,7 @@ mhelper :: (Monad m, RenderMessage master msg, RenderMessage master msg2) -> (a -> FormResult b) -- ^ on success -> Bool -- ^ is it required? -> Form master (GGHandler sub master m) (FormResult b, FieldView xml) + mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do mp <- askParams name <- maybe newFormIdent return fsName diff --git a/hello-forms.hs b/hello-forms.hs index ccab8f77..cd10b635 100644 --- a/hello-forms.hs +++ b/hello-forms.hs @@ -12,12 +12,14 @@ 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 + <*> areq (multiSelectField fruits) "Multi select field" Nothing + <*> aopt (multiSelectField fruits) "Opt multi select field" Nothing <*> aopt intField "Opt int field" Nothing <*> aopt (radioField fruits) "Opt radio" Nothing