diff --git a/demo/subsite/WikiRoutes.hs b/demo/subsite/WikiRoutes.hs index f22c0222..0e340449 100644 --- a/demo/subsite/WikiRoutes.hs +++ b/demo/subsite/WikiRoutes.hs @@ -21,7 +21,7 @@ data Wiki = Wiki } -- | A typeclass that all master sites that want a Wiki must implement. A --- master must be able to render form messages, as we use yesod-forms for +-- master must be able to render form messages, as we use yesod-form for -- processing user input. class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where -- | Write protection. By default, no protection. diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index 8c1ee7f4..3a3f5ce6 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -22,7 +22,7 @@ library , unliftio , yesod-auth >= 1.6 && < 1.7 , yesod-core >= 1.6 && < 1.7 - , yesod-form >= 1.6 && < 1.7 + , yesod-form >= 1.6 && < 1.8 exposed-modules: Yesod.Auth.OAuth ghc-options: -Wall diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index b6be336c..039051f1 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -57,7 +57,7 @@ library , unordered-containers , wai >= 1.4 , yesod-core >= 1.6 && < 1.7 - , yesod-form >= 1.6 && < 1.7 + , yesod-form >= 1.6 && < 1.8 , yesod-persistent >= 1.6 if flag(network-uri) diff --git a/yesod-form-multi/yesod-form-multi.cabal b/yesod-form-multi/yesod-form-multi.cabal index 7e576ead..f8b7c983 100644 --- a/yesod-form-multi/yesod-form-multi.cabal +++ b/yesod-form-multi/yesod-form-multi.cabal @@ -26,7 +26,7 @@ library , text >= 0.9 , transformers >= 0.2.2 , yesod-core >= 1.6 && < 1.7 - , yesod-form >= 1.6 && < 1.7 + , yesod-form >= 1.6 && < 1.8 if flag(network-uri) build-depends: network-uri >= 2.6 diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index c38a49dc..5d37f2f8 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/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) @@ -446,6 +458,9 @@ $newline never $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 @@ $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 +-- +-- 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 @@ mkOptionList os = OptionList , 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 @@ optionsPairs opts = do } 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 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do -- | 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 @@ 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 +804,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 - 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 @@ 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 @@ -864,7 +940,7 @@ prependZero t0 = if T.null t1 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/yesod-form.cabal b/yesod-form/yesod-form.cabal index c66cd7b0..1fb100b1 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.6.7 +version: 1.7.0 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 42e36729..21e51b95 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -38,7 +38,7 @@ library , warp >= 1.3 , yaml >= 0.8.17 , yesod-core >= 1.6 && < 1.7 - , yesod-form >= 1.6 && < 1.7 + , yesod-form >= 1.6 && < 1.8 , yesod-persistent >= 1.6 && < 1.7 exposed-modules: Yesod