diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index bf04b9c8..47463201 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -45,6 +45,7 @@ module Yesod.Form.Fields , selectFieldHelper , selectField , selectFieldList + , selectFieldListGrouped , radioField , radioFieldList , checkboxesField @@ -54,6 +55,7 @@ module Yesod.Form.Fields , Option (..) , OptionList (..) , mkOptionList + , mkOptionListGrouped , optionsPersist , optionsPersistKey , optionsPairs @@ -427,7 +429,13 @@ selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg -> Field (HandlerFor site) a selectFieldList = selectField . optionsPairs --- | Creates a @\@ tag with @\@s for selecting one option. +selectFieldListGrouped :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) + => [(msg, [(msg, a)])] + -> Field (HandlerFor site) a +selectFieldListGrouped = selectField . optionsPairsGrouped + +-- | Creates a @\@ tag for selecting multiple options. multiSelectFieldList :: (Eq a, RenderMessage site msg) @@ -531,6 +542,7 @@ $newline never \#{text} |]) + Nothing -- | Creates a group of radio buttons to answer the question given in the message. Radio buttons are used to allow differentiating between an empty response (@Nothing@) and a no response (@Just False@). Consider using the simpler 'checkBoxField' if you don't need to make this distinction. -- @@ -598,10 +610,20 @@ $newline never showVal = either (\_ -> False) -- | A structure holding a list of options. Typically you can use a convenience function like 'mkOptionList' or 'optionsPairs' instead of creating this directly. -data OptionList a = OptionList +data OptionList a + = OptionList { olOptions :: [Option a] , olReadExternal :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue'). } + | OptionListGrouped + { olOptionsGrouped :: [(Text, [Option a])] + , olReadExternalGrouped :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue'). + } + +-- | Convert grouped 'OptionList' to a normal one. +flattenOptionList :: OptionList a -> OptionList a +flattenOptionList (OptionListGrouped os re) = OptionList (concatMap snd os) re +flattenOptionList ol = ol -- | Since 1.4.6 instance Functor OptionList where @@ -615,6 +637,13 @@ mkOptionList os = OptionList , olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os } +-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternalGrouped' function. +mkOptionListGrouped :: [(Text, [Option a])] -> OptionList a +mkOptionListGrouped os = OptionListGrouped + { olOptionsGrouped = os + , olReadExternalGrouped = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) $ concatMap snd os + } + data Option a = Option { optionDisplay :: Text -- ^ The user-facing label. , optionInternalValue :: a -- ^ The Haskell value being selected. @@ -637,6 +666,28 @@ optionsPairs opts = do } return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts) +-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs. +optionsPairsGrouped + :: (MonadHandler m, RenderMessage (HandlerSite m) msg) + => [(msg, [(msg, a)])] -> m (OptionList a) +optionsPairsGrouped opts = do + mr <- getMessageRender + let mkOption (external, (display, internal)) = + Option { optionDisplay = mr display + , optionInternalValue = internal + , optionExternalValue = pack $ show external + } + opts' = enumerateSublists opts -- :: [(grp, [(Int, (msg, a))])] + opts'' = map (\(x, ys) -> (mr x, map mkOption ys)) opts' + return $ mkOptionListGrouped opts'' + +-- | Helper to enumerate sublists with one consecutive index. +enumerateSublists :: [(a, [b])] -> [(a, [(Int, b)])] +enumerateSublists xss = + let --yss :: [(Int, (a, [b]))] + yss = snd $ foldl (\(i, res) xs -> (i + (length.snd) xs, res ++ [(i, xs)])) (1, []) xss + in map (\(i, (x, ys)) -> (x, zip [i :: Int ..] ys)) yss + -- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value. optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a) optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] @@ -731,7 +782,7 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do }) pairs -- | --- A helper function for constucting 'selectField's. You may want to use this when you define your custom 'selectField's or 'radioField's. +-- A helper function for constucting 'selectField's with optional option groups. You may want to use this when you define your custom 'selectField's or 'radioField's. -- -- @since 1.6.2 selectFieldHelper @@ -739,23 +790,26 @@ selectFieldHelper => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options + -> (Maybe (Text -> WidgetFor site ())) -- ^ Group headers placed inbetween options -> HandlerFor site (OptionList a) -> Field (HandlerFor site) a -selectFieldHelper outside onOpt inside opts' = Field +selectFieldHelper outside onOpt inside grpHdr opts' = Field { fieldParse = \x _ -> do - opts <- opts' + opts <- fmap flattenOptionList opts' return $ selectParser opts x , fieldView = \theId name attrs val isReq -> do - opts <- fmap olOptions $ handlerToWidget opts' outside theId name attrs $ do - unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts - forM_ opts $ \opt -> inside - theId - name - ((if isReq then (("required", "required"):) else id) attrs) - (optionExternalValue opt) - ((render opts val) == optionExternalValue opt) - (optionDisplay opt) + optsFlat <- fmap (olOptions.flattenOptionList) $ handlerToWidget opts' + unless isReq $ onOpt theId name $ not $ render optsFlat val `elem` map optionExternalValue optsFlat + opts'' <- handlerToWidget opts' + case opts'' of + (OptionList{}) -> constructOptions theId name attrs val isReq optsFlat + (OptionListGrouped{olOptionsGrouped=grps}) -> do + forM_ grps $ \(grp, opts) -> do + case grpHdr of + Just hdr -> hdr grp + Nothing -> return () + constructOptions theId name attrs val isReq opts , fieldEnctype = UrlEncoded } where @@ -768,6 +822,14 @@ selectFieldHelper outside onOpt inside opts' = Field x -> case olReadExternal opts x of Nothing -> Left $ SomeMessage $ MsgInvalidEntry x Just y -> Right $ Just y + constructOptions theId name attrs val isReq opts = + forM_ opts $ \opt -> inside + theId + name + ((if isReq then (("required", "required"):) else id) attrs) + (optionExternalValue opt) + ((render opts val) == optionExternalValue opt) + (optionDisplay opt) -- | Creates an input with @type="file"@. fileField :: Monad m