Support for free-forms

This adds a whole bunch of polymorphism to the forms library, and opens
up a monad approach which exposes the FieldInfos generated. This allows
you to layout your form however you want without mucking around with
guessing the location of the fieldinfos in a list.

Yesod/Form.hs

@@ -11,6 +11,7 @@ module Yesod.Form
     , Enctype (..)
     , FormFieldSettings (..)
     , Textarea (..)
+    , FieldInfo (..)
       -- * Type synonyms
     , Form
     , Formlet
@@ -19,7 +20,9 @@ module Yesod.Form
     , FormInput
       -- * Unwrapping functions
     , runFormGet
+    , runFormMonadGet
     , runFormPost
+    , runFormMonadPost
     , runFormGet'
     , runFormPost'
       -- * Field/form helpers
@@ -46,8 +49,6 @@ import Control.Applicative hiding (optional)
 import Data.Maybe (fromMaybe, mapMaybe)
 import "transformers" Control.Monad.IO.Class
 import Control.Monad ((<=<))
-import Control.Monad.Trans.State
-import Control.Monad.Trans.Reader
 import Language.Haskell.TH.Syntax
 import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef))
 import Data.Char (toUpper, isUpper)
@@ -89,17 +90,16 @@ fieldsToDivs = mapFormXml $ mapM_ go
 |]
     clazz fi = if fiRequired fi then "required" else "optional"
 
-runFormGeneric :: Env
+-- | Run a form against POST parameters.
-               -> FileEnv
+runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
-               -> GForm sub y xml a
+runFormPost f = do
-               -> GHandler sub y (FormResult a, xml, Enctype)
+    rr <- getRequest
-runFormGeneric env fe (GForm f) =
+    (pp, files) <- liftIO $ reqRequestBody rr
-    runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe
+    runFormGeneric pp files f
 
 -- | Run a form against POST parameters.
-runFormPost :: GForm sub y xml a
+runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)
-            -> GHandler sub y (FormResult a, xml, Enctype)
+runFormMonadPost f = do
-runFormPost f = do
     rr <- getRequest
     (pp, files) <- liftIO $ reqRequestBody rr
     runFormGeneric pp files f
@@ -120,12 +120,16 @@ helper (FormFailure e, _, _) = invalidArgs e
 helper (FormMissing, _, _) = invalidArgs ["No input found"]
 
 -- | Run a form against GET parameters.
-runFormGet :: GForm sub y xml a
+runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
-           -> GHandler sub y (FormResult a, xml, Enctype)
 runFormGet f = do
     gs <- reqGetParams `fmap` getRequest
     runFormGeneric gs [] f
 
+runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype)
+runFormMonadGet f = do
+    gs <- reqGetParams `fmap` getRequest
+    runFormGeneric gs [] f
+
 -- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=.
 mkToForm :: PersistEntity v => v -> Q [Dec]
 mkToForm =

Yesod/Form/Core.hs

@@ -1,4 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 module Yesod.Form.Core
     ( FormResult (..)
     , GForm (..)
@@ -18,6 +21,9 @@ module Yesod.Form.Core
     , askParams
     , askFiles
     , liftForm
+    , IsForm (..)
+    , RunForm (..)
+    , GFormMonad
       -- * Data types
     , FieldInfo (..)
     , FormFieldSettings (..)
@@ -32,6 +38,7 @@ module Yesod.Form.Core
 
 import Control.Monad.Trans.State
 import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Writer
 import Control.Monad.Trans.Class (lift)
 import Yesod.Handler
 import Yesod.Widget
@@ -90,14 +97,19 @@ incrInts (IntCons i is) = (i + 1) `IntCons` is
 
 -- | A generic form, allowing you to specifying the subsite datatype, master
 -- site datatype, a datatype for the form XML and the return type.
-newtype GForm sub y xml a = GForm
+newtype GForm s m xml a = GForm
-    { deform :: StateT Ints (
+    { deform :: FormInner s m (FormResult a, xml, Enctype)
-                ReaderT Env (
-                ReaderT FileEnv (
-                (GHandler sub y)
-                ))) (FormResult a, xml, Enctype)
     }
 
+type GFormMonad s m a = WriterT Enctype (FormInner s m) a
+
+type FormInner s m =
+    StateT Ints (
+    ReaderT Env (
+    ReaderT FileEnv (
+    GHandler s m
+    )))
+
 type Env = [(String, String)]
 type FileEnv = [(String, FileInfo)]
 
@@ -134,10 +146,14 @@ instance Monoid xml => Applicative (GForm sub url xml) where
         return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3)
 
 -- | Create a required field (ie, one that cannot be blank) from a
--- 'FieldProfile'.ngs
+-- 'FieldProfile'.
-requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings
+requiredFieldHelper
-                    -> Maybe a -> FormField sub y a
+    :: IsForm f
-requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do
+    => FieldProfile (FormSub f) (FormMaster f) (FormType f)
+    -> FormFieldSettings
+    -> Maybe (FormType f)
+    -> f
+requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do
     env <- lift ask
     let (FormFieldSettings label tooltip theId' name') = ffs
     name <- maybe newFormIdent return name'
@@ -153,7 +169,7 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do
                                 Left e -> (FormFailure [e], x)
                                 Right y -> (FormSuccess y, x)
     let fi = FieldInfo
-            { fiLabel = label
+            { fiLabel = string label
             , fiTooltip = tooltip
             , fiIdent = theId
             , fiInput = mkWidget theId name val True
@@ -162,13 +178,70 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do
                             _ -> Nothing
             , fiRequired = True
             }
-    return (res, [fi], UrlEncoded)
+    let res' = case res of
+                FormFailure [e] -> FormFailure [label ++ ": " ++ e]
+                _ -> res
+    return (res', fi, UrlEncoded)
+
+class IsForm f where
+    type FormSub f
+    type FormMaster f
+    type FormType f
+    toForm :: FormInner
+                (FormSub f)
+                (FormMaster f)
+                (FormResult (FormType f),
+                 FieldInfo (FormSub f) (FormMaster f),
+                 Enctype) -> f
+instance IsForm (FormField s m a) where
+    type FormSub (FormField s m a) = s
+    type FormMaster (FormField s m a) = m
+    type FormType (FormField s m a) = a
+    toForm x = GForm $ do
+        (a, b, c) <- x
+        return (a, [b], c)
+instance IsForm (GFormMonad s m (FormResult a, FieldInfo s m)) where
+    type FormSub (GFormMonad s m (FormResult a, FieldInfo s m)) = s
+    type FormMaster (GFormMonad s m (FormResult a, FieldInfo s m)) = m
+    type FormType (GFormMonad s m (FormResult a, FieldInfo s m)) = a
+    toForm x = do
+        (res, fi, enctype) <- lift x
+        tell enctype
+        return (res, fi)
+
+class RunForm f where
+    type RunFormSub f
+    type RunFormMaster f
+    type RunFormType f
+    runFormGeneric :: Env -> FileEnv -> f
+                   -> GHandler (RunFormSub f)
+                               (RunFormMaster f)
+                               (RunFormType f)
+
+instance RunForm (GForm s m xml a) where
+    type RunFormSub (GForm s m xml a) = s
+    type RunFormMaster (GForm s m xml a) = m
+    type RunFormType (GForm s m xml a) =
+        (FormResult a, xml, Enctype)
+    runFormGeneric env fe (GForm f) =
+        runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe
+
+instance RunForm (GFormMonad s m a) where
+    type RunFormSub (GFormMonad s m a) = s
+    type RunFormMaster (GFormMonad s m a) = m
+    type RunFormType (GFormMonad s m a) = (a, Enctype)
+    runFormGeneric e fe f =
+        runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe
 
 -- | Create an optional field (ie, one that can be blank) from a
 -- 'FieldProfile'.
-optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings
+optionalFieldHelper
-                    -> FormletField sub y (Maybe a)
+    :: (IsForm f, Maybe b ~ FormType f)
-optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do
+    => FieldProfile (FormSub f) (FormMaster f) b
+    -> FormFieldSettings
+    -> Maybe (Maybe b)
+    -> f
+optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do
     env <- lift ask
     let (FormFieldSettings label tooltip theId' name') = ffs
     let orig = join orig'
@@ -185,7 +258,7 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do
                                 Left e -> (FormFailure [e], x)
                                 Right y -> (FormSuccess $ Just y, x)
     let fi = FieldInfo
-            { fiLabel = label
+            { fiLabel = string label
             , fiTooltip = tooltip
             , fiIdent = theId
             , fiInput = mkWidget theId name val False
@@ -194,7 +267,10 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do
                             _ -> Nothing
             , fiRequired = False
             }
-    return (res, [fi], UrlEncoded)
+    let res' = case res of
+                FormFailure [e] -> FormFailure [label ++ ": " ++ e]
+                _ -> res
+    return (res', fi, UrlEncoded)
 
 fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()]
 fieldsToInput = map fiInput
@@ -218,13 +294,13 @@ data FieldInfo sub y = FieldInfo
     }
 
 data FormFieldSettings = FormFieldSettings
-    { ffsLabel :: Html
+    { ffsLabel :: String
     , ffsTooltip :: Html
     , ffsId :: Maybe String
     , ffsName :: Maybe String
     }
 instance IsString FormFieldSettings where
-    fromString s = FormFieldSettings (string s) mempty Nothing Nothing
+    fromString s = FormFieldSettings s mempty Nothing Nothing
 
 -- | A generic definition of a form field that can be used for generating both
 -- required and optional fields. See 'requiredFieldHelper and

Yesod/Form/Fields.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Form.Fields
     ( -- * Fields
       -- ** Required
@@ -49,10 +51,12 @@ import Data.Monoid
 import Control.Monad (join)
 import Data.Maybe (fromMaybe)
 
-stringField :: FormFieldSettings -> FormletField sub y String
+stringField :: (IsForm f, FormType f ~ String)
+            => FormFieldSettings -> Maybe String -> f
 stringField = requiredFieldHelper stringFieldProfile
 
-maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String)
+maybeStringField :: (IsForm f, FormType f ~ Maybe String)
+                 => FormFieldSettings -> Maybe (Maybe String) -> f
 maybeStringField = optionalFieldHelper stringFieldProfile
 
 intInput :: Integral i => String -> FormInput sub master i
@@ -65,32 +69,41 @@ maybeIntInput n =
     mapFormXml fieldsToInput $
     optionalFieldHelper intFieldProfile (nameSettings n) Nothing
 
-intField :: Integral i => FormFieldSettings -> FormletField sub y i
+intField :: (Integral (FormType f), IsForm f)
+         => FormFieldSettings -> Maybe (FormType f) -> f
 intField = requiredFieldHelper intFieldProfile
 
-maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i)
+maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f)
+              => FormFieldSettings -> Maybe (FormType f) -> f
 maybeIntField = optionalFieldHelper intFieldProfile
 
-doubleField :: FormFieldSettings -> FormletField sub y Double
+doubleField :: (IsForm f, FormType f ~ Double)
+            => FormFieldSettings -> Maybe Double -> f
 doubleField = requiredFieldHelper doubleFieldProfile
 
-maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double)
+maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double)
+                 => FormFieldSettings -> Maybe (Maybe Double) -> f
 maybeDoubleField = optionalFieldHelper doubleFieldProfile
 
-dayField :: FormFieldSettings -> FormletField sub y Day
+dayField :: (IsForm f, FormType f ~ Day)
+         => FormFieldSettings -> Maybe Day -> f
 dayField = requiredFieldHelper dayFieldProfile
 
-maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day)
+maybeDayField :: (IsForm f, FormType f ~ Maybe Day)
+              => FormFieldSettings -> Maybe (Maybe Day) -> f
 maybeDayField = optionalFieldHelper dayFieldProfile
 
-timeField :: FormFieldSettings -> FormletField sub y TimeOfDay
+timeField :: (IsForm f, FormType f ~ TimeOfDay)
+          => FormFieldSettings -> Maybe TimeOfDay -> f
 timeField = requiredFieldHelper timeFieldProfile
 
-maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay)
+maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay)
+               => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f
 maybeTimeField = optionalFieldHelper timeFieldProfile
 
-boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool
+boolField :: (IsForm f, FormType f ~ Bool)
-boolField ffs orig = GForm $ do
+          => FormFieldSettings -> Maybe Bool -> f
+boolField ffs orig = toForm $ do
     env <- askParams
     let label = ffsLabel ffs
         tooltip = ffsTooltip ffs
@@ -105,7 +118,7 @@ boolField ffs orig = GForm $ do
                         Just "false" -> (FormSuccess False, False)
                         Just _ -> (FormSuccess True, True)
     let fi = FieldInfo
-            { fiLabel = label
+            { fiLabel = string label
             , fiTooltip = tooltip
             , fiIdent = theId
             , fiInput = addBody [$hamlet|
@@ -116,18 +129,22 @@ boolField ffs orig = GForm $ do
                             _ -> Nothing
             , fiRequired = True
             }
-    return (res, [fi], UrlEncoded)
+    return (res, fi, UrlEncoded)
 
-htmlField :: FormFieldSettings -> FormletField sub y Html
+htmlField :: (IsForm f, FormType f ~ Html)
+          => FormFieldSettings -> Maybe Html -> f
 htmlField = requiredFieldHelper htmlFieldProfile
 
-maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html)
+maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html)
+               => FormFieldSettings -> Maybe (Maybe Html) -> f
 maybeHtmlField = optionalFieldHelper htmlFieldProfile
 
-selectField :: Eq x => [(x, String)]
+selectField :: (Eq x, IsForm f, FormType f ~ x)
+            => [(x, String)]
             -> FormFieldSettings
-            -> Maybe x -> FormField sub master x
+            -> Maybe x
-selectField pairs ffs initial = GForm $ do
+            -> f
+selectField pairs ffs initial = toForm $ do
     env <- askParams
     let label = ffsLabel ffs
         tooltip = ffsTooltip ffs
@@ -155,7 +172,7 @@ selectField pairs ffs initial = GForm $ do
         %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
 |]
     let fi = FieldInfo
-            { fiLabel = label
+            { fiLabel = string label
             , fiTooltip = tooltip
             , fiIdent = theId
             , fiInput = addBody input
@@ -164,12 +181,14 @@ selectField pairs ffs initial = GForm $ do
                             _ -> Nothing
             , fiRequired = True
             }
-    return (res, [fi], UrlEncoded)
+    return (res, fi, UrlEncoded)
 
-maybeSelectField :: Eq x => [(x, String)]
+maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f)
+                 => [(x, String)]
                  -> FormFieldSettings
-                 -> FormletField sub master (Maybe x)
+                 -> Maybe (FormType f)
-maybeSelectField pairs ffs initial' = GForm $ do
+                 -> f
+maybeSelectField pairs ffs initial' = toForm $ do
     env <- askParams
     let initial = join initial'
         label = ffsLabel ffs
@@ -198,7 +217,7 @@ maybeSelectField pairs ffs initial' = GForm $ do
         %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$
 |]
     let fi = FieldInfo
-            { fiLabel = label
+            { fiLabel = string label
             , fiTooltip = tooltip
             , fiIdent = theId
             , fiInput = addBody input
@@ -207,7 +226,7 @@ maybeSelectField pairs ffs initial' = GForm $ do
                             _ -> Nothing
             , fiRequired = False
             }
-    return (res, [fi], UrlEncoded)
+    return (res, fi, UrlEncoded)
 
 stringInput :: String -> FormInput sub master String
 stringInput n =
@@ -245,10 +264,12 @@ maybeDayInput n =
 nameSettings :: String -> FormFieldSettings
 nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n)
 
-urlField :: FormFieldSettings -> FormletField sub y String
+urlField :: (IsForm f, FormType f ~ String)
+         => FormFieldSettings -> Maybe String -> f
 urlField = requiredFieldHelper urlFieldProfile
 
-maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String)
+maybeUrlField :: (IsForm f, FormType f ~ Maybe String)
+               => FormFieldSettings -> Maybe (Maybe String) -> f
 maybeUrlField = optionalFieldHelper urlFieldProfile
 
 urlInput :: String -> FormInput sub master String
@@ -256,10 +277,12 @@ urlInput n =
     mapFormXml fieldsToInput $
     requiredFieldHelper urlFieldProfile (nameSettings n) Nothing
 
-emailField :: FormFieldSettings -> FormletField sub y String
+emailField :: (IsForm f, FormType f ~ String)
+           => FormFieldSettings -> Maybe String -> f
 emailField = requiredFieldHelper emailFieldProfile
 
-maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String)
+maybeEmailField :: (IsForm f, FormType f ~ Maybe String)
+                => FormFieldSettings -> Maybe (Maybe String) -> f
 maybeEmailField = optionalFieldHelper emailFieldProfile
 
 emailInput :: String -> FormInput sub master String
@@ -267,14 +290,17 @@ emailInput n =
     mapFormXml fieldsToInput $
     requiredFieldHelper emailFieldProfile (nameSettings n) Nothing
 
-textareaField :: FormFieldSettings -> FormletField sub y Textarea
+textareaField :: (IsForm f, FormType f ~ Textarea)
+              => FormFieldSettings -> Maybe Textarea -> f
 textareaField = requiredFieldHelper textareaFieldProfile
 
 maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea)
 maybeTextareaField = optionalFieldHelper textareaFieldProfile
 
-hiddenField :: FormFieldSettings -> FormletField sub y String
+hiddenField :: (IsForm f, FormType f ~ String)
+            => FormFieldSettings -> Maybe String -> f
 hiddenField = requiredFieldHelper hiddenFieldProfile
 
-maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String)
+maybeHiddenField :: (IsForm f, FormType f ~ Maybe String)
+                 => FormFieldSettings -> Maybe (Maybe String) -> f
 maybeHiddenField = optionalFieldHelper hiddenFieldProfile

freeform.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-}
+import Yesod
+import Control.Applicative
+
+data FreeForm = FreeForm
+mkYesod "FreeForm" [$parseRoutes|
+/ RootR GET
+|]
+instance Yesod FreeForm where approot _ = ""
+
+data Person = Person String Int String
+    deriving Show
+
+getRootR = do
+    ((merr, mperson, form), enctype) <- runFormMonadGet $ do
+        (name, namef) <- stringField "Name" Nothing
+        (age, agef) <- intField "Age" $ Just 25
+        (color, colorf) <- stringField "Color" Nothing
+        let (merr, mperson) =
+                case Person <$> name <*> age <*> color of
+                    FormSuccess p -> (Nothing, Just p)
+                    FormFailure e -> (Just e, Nothing)
+                    FormMissing -> (Nothing, Nothing)
+        let form = [$hamlet|
+Hey, my name is ^fiInput.namef^ and I'm ^fiInput.agef^ years old and my favorite color is ^fiInput.colorf^.
+|]
+        return (merr, mperson, form)
+    defaultLayout [$hamlet|
+$maybe merr err
+    %ul!style=color:red
+        $forall err e
+            %li $e$
+$maybe mperson person
+    %p Last person: $show.person$
+%form!method=get!action=@RootR@!enctype=$enctype$
+    %p ^form^
+    %input!type=submit!value=Submit
+|]
+
+main = basicHandler 3000 FreeForm