diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index f1370845..9b0d210b 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.4.14 + +* Added `WForm` to reduce the verbosity using monadic forms. +* Added `wreq` and `wopt` correspondent functions for `WForm`. + ## 1.4.13 * Fixed `textareaField` `writeHtmlEscapedChar` trim "\r" diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index 37d93f13..ab1d613c 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -13,7 +13,12 @@ module Yesod.Form.Functions -- * Applicative/Monadic conversion , formToAForm , aFormToForm + , mFormToWForm + , wFormToAForm + , wFormToMForm -- * Fields to Forms + , wreq + , wopt , mreq , mopt , areq @@ -51,8 +56,9 @@ module Yesod.Form.Functions import Yesod.Form.Types import Data.Text (Text, pack) import Control.Arrow (second) -import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local) import Control.Monad.Trans.Class +import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST) +import Control.Monad.Trans.Writer (runWriterT, writer) import Control.Monad (liftM, join) import Data.Byteable (constEqBytes) import Text.Blaze (Markup, toMarkup) @@ -105,6 +111,58 @@ askFiles = do (x, _, _) <- ask return $ liftM snd x +-- | Converts a form field into monadic form 'WForm'. This field requires a +-- value and will return 'FormFailure' if left empty. +-- +-- @since 1.4.14 +wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -- ^ form field + -> FieldSettings site -- ^ settings for this field + -> Maybe a -- ^ optional default value + -> WForm m (FormResult a) +wreq f fs = mFormToWForm . mreq f fs + +-- | Converts a form field into monadic form 'WForm'. This field is optional, +-- i.e. if filled in, it returns 'Just a', if left empty, it returns +-- 'Nothing'. Arguments are the same as for 'wreq' (apart from type of default +-- value). +-- +-- @since 1.4.14 +wopt :: (MonadHandler m, HandlerSite m ~ site) + => Field m a -- ^ form field + -> FieldSettings site -- ^ settings for this field + -> Maybe (Maybe a) -- ^ optional default value + -> WForm m (FormResult (Maybe a)) +wopt f fs = mFormToWForm . mopt f fs + +-- | Converts a monadic form 'WForm' into an applicative form 'AForm'. +-- +-- @since 1.4.14 +wFormToAForm :: MonadHandler m + => WForm m (FormResult a) -- ^ input form + -> AForm m a -- ^ output form +wFormToAForm = formToAForm . wFormToMForm + +-- | Converts a monadic form 'WForm' into another monadic form 'MForm'. +-- +-- @since 1.4.14 +wFormToMForm :: (MonadHandler m, HandlerSite m ~ site) + => WForm m a -- ^ input form + -> MForm m (a, [FieldView site]) -- ^ output form +wFormToMForm = mapRWST (fmap group . runWriterT) + where + group ((a, ints, enctype), views) = ((a, views), ints, enctype) + +-- | Converts a monadic form 'MForm' into another monadic form 'WForm'. +-- +-- @since 1.4.14 +mFormToWForm :: (MonadHandler m, HandlerSite m ~ site) + => MForm m (a, FieldView site) -- ^ input form + -> WForm m a -- ^ output form +mFormToWForm = mapRWST $ \f -> do + ((a, view), ints, enctype) <- lift f + writer ((a, ints, enctype), [view]) + -- | Converts a form field into monadic form. This field requires a value -- and will return 'FormFailure' if left empty. mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs index c3d367c0..b41c7b1b 100644 --- a/yesod-form/Yesod/Form/Types.hs +++ b/yesod-form/Yesod/Form/Types.hs @@ -12,6 +12,7 @@ module Yesod.Form.Types , FileEnv , Ints (..) -- * Form + , WForm , MForm , AForm (..) -- * Build forms @@ -22,6 +23,7 @@ module Yesod.Form.Types ) where import Control.Monad.Trans.RWS (RWST) +import Control.Monad.Trans.Writer (WriterT) import Data.Text (Text) import Data.Monoid (Monoid (..)) import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue)) @@ -102,6 +104,29 @@ instance Show Ints where type Env = Map.Map Text [Text] type FileEnv = Map.Map Text [FileInfo] +-- | 'MForm' variant stacking a 'WriterT'. The following code example using a +-- monadic form 'MForm': +-- +-- > formToAForm $ do +-- > (field1F, field1V) <- mreq textField MsgField1 Nothing +-- > (field2F, field2V) <- mreq (checkWith field1F textField) MsgField2 Nothing +-- > (field3F, field3V) <- mreq (checkWith field1F textField) MsgField3 Nothing +-- > return +-- > ( MyForm <$> field1F <*> field2F <*> field3F +-- > , [field1V, field2V, field3V] +-- > ) +-- +-- Could be rewritten as follows using 'WForm': +-- +-- > wFormToAForm $ do +-- > field1F <- wreq textField MsgField1 Nothing +-- > field2F <- wreq (checkWith field1F textField) MsgField2 Nothing +-- > field3F <- wreq (checkWith field1F textField) MsgField3 Nothing +-- > return $ MyForm <$> field1F <*> field2F <*> field3F +-- +-- @since 1.4.14 +type WForm m a = MForm (WriterT [FieldView (HandlerSite m)] m) a + type MForm m a = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 177653d9..e9fba0bd 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.4.13 +version: 1.4.14 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 0b2fe611..67511ee9 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -150,6 +150,18 @@ main = hspec $ do addToken statusIs 200 bodyEquals "12345" + yit "labels WForm" $ do + get ("/wform" :: Text) + statusIs 200 + + request $ do + setMethod "POST" + setUrl ("/wform" :: Text) + byLabel "Some WLabel" "12345" + fileByLabel "Some WFile" "test/main.hs" "text/plain" + addToken + statusIs 200 + bodyEquals "12345" yit "finding html" $ do get ("/html" :: Text) statusIs 200 @@ -334,6 +346,15 @@ app = liteApp $ do case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget + onStatic "wform" $ dispatchTo $ do + ((mfoo, widget), _) <- runFormPost $ renderDivs $ wFormToAForm $ do + field1F <- wreq textField "Some WLabel" Nothing + field2F <- wreq fileField "Some WFile" Nothing + + return $ (,) Control.Applicative.<$> field1F <*> field2F + case mfoo of + FormSuccess (foo, _) -> return $ toHtml foo + _ -> defaultLayout widget onStatic "html" $ dispatchTo $ return ("Hello

Hello World

Hello Moon

" :: Text)