Reduce verbosity using Monadic Forms

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"

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)

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

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 <michael@snoyman.com>

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 ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>" :: Text)