diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-form +## 1.7.0 + +* Extended `OptionList` by `OptionListGrouped` and implemented grouped select fields (`@ tag for selecting one option. Example usage: +-- | Creates a @\@ tag with optional @\@s for selecting one option. Example usage: +-- -- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing selectField :: (Eq a, RenderMessage site FormMessage) => HandlerFor site (OptionList a) @@ -446,6 +458,9 @@ $newline never +|]) -- group label -- | Creates a @\ \#{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,15 +614,31 @@ 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 +-- +-- Extended by 'OptionListGrouped' in 1.7.0. +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'). + } --- | Since 1.4.6 +-- | Convert grouped 'OptionList' to a normal one. +-- +-- @since 1.7.0 +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 - fmap f (OptionList options readExternal) = + fmap f (OptionList options readExternal) = OptionList ((fmap.fmap) f options) (fmap f . readExternal) + fmap f (OptionListGrouped options readExternal) = + OptionListGrouped (map (\(g, os) -> (g, (fmap.fmap) f os)) options) (fmap f . readExternal) -- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternal' function. mkOptionList :: [Option a] -> OptionList a @@ -615,13 +647,22 @@ , olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os } +-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternalGrouped' function. +-- +-- @since 1.7.0 +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. , optionExternalValue :: Text -- ^ The representation of this value stored in the form. } --- | Since 1.4.6 +-- | @since 1.4.6 instance Functor Option where fmap f (Option display internal external) = Option display (f internal) external @@ -637,6 +678,30 @@ } return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts) +-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs. +-- +-- @since 1.7.0 +optionsPairsGrouped + :: forall m msg a. (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 :: [(msg, [(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 :: forall a b. [(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] @@ -692,7 +757,7 @@ -- | An alternative to 'optionsPersist' which returns just the 'Key' instead of -- the entire 'Entity'. -- --- Since 1.3.2 +-- @since 1.3.2 #if MIN_VERSION_persistent(2,5,0) optionsPersistKey :: (YesodPersist site @@ -731,7 +796,7 @@ }) 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 +804,26 @@ => (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 - flip mapM_ 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 $ render optsFlat val `notElem` 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 +836,14 @@ 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 @@ -864,7 +940,7 @@ then "-0." `T.append` (T.drop 2 t1) else t1 - where t1 = T.dropWhile ((==) ' ') t0 + where t1 = T.dropWhile (==' ') t0 -- $optionsOverview -- These functions create inputs where one or more options can be selected from a list. diff --git a/yesod-form.cabal b/yesod-form.cabal --- a/yesod-form.cabal +++ b/yesod-form.cabal @@ -1,5 +1,6 @@ +cabal-version: >= 1.10 name: yesod-form -version: 1.6.7 +version: 1.7.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -7,7 +8,6 @@ synopsis: Form handling support for Yesod Web Framework category: Web, Yesod stability: Stable -cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/ description: API docs and the README are available at . Third-party packages which you can find useful: - richtext form fields (currntly it provides only Summernote support). @@ -19,7 +19,8 @@ default: True library - build-depends: base >= 4 && < 5 + default-language: Haskell2010 + build-depends: base >= 4.10 && < 5 , aeson , attoparsec >= 0.10 , blaze-builder >= 0.2.1.4 @@ -32,7 +33,6 @@ , email-validate >= 1.0 , persistent , resourcet - , semigroups , shakespeare >= 2.0 , text >= 0.9 , time >= 1.1.4 @@ -71,6 +71,7 @@ ghc-options: -Wall test-suite test + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test