haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Support for free-forms

Browse Source 
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.
This commit is contained in:
Michael Snoyman 2010-10-18 23:19:35 +02:00
parent b930bcbf62
commit c29f5af95c
4 changed files with 211 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
Yesod/Form.hs
View File

@ -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
-> FileEnv
-> GForm sub y xml a
-> GHandler sub y (FormResult a, xml, Enctype)
runFormGeneric env fe (GForm f) =
runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe
-- | Run a form against POST parameters.
runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
runFormPost f = do
rr <- getRequest
(pp, files) <- liftIO $ reqRequestBody rr
runFormGeneric pp files f
-- | Run a form against POST parameters.
runFormPost :: GForm sub y xml a
-> GHandler sub y (FormResult a, xml, Enctype)
runFormPost f = do
runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)
runFormMonadPost 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
-> GHandler sub y (FormResult a, xml, Enctype)
runFormGet :: GForm s m xml a -> GHandler s m (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 =

114
Yesod/Form/Core.hs
View File

@ -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
{ deform :: StateT Ints (
ReaderT Env (
ReaderT FileEnv (
(GHandler sub y)
))) (FormResult a, xml, Enctype)
newtype GForm s m xml a = GForm
{ deform :: FormInner s m (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
requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings
-> Maybe a -> FormField sub y a
requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do
-- 'FieldProfile'.
requiredFieldHelper
:: IsForm f
=> 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
-> FormletField sub y (Maybe a)
optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do
optionalFieldHelper
:: (IsForm f, Maybe b ~ FormType f)
=> 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

92
Yesod/Form/Fields.hs
View File

@ -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 ffs orig = GForm $ do
boolField :: (IsForm f, FormType f ~ Bool)
=> 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
selectField pairs ffs initial = GForm $ do
-> Maybe x
-> 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)
maybeSelectField pairs ffs initial' = GForm $ do
-> Maybe (FormType f)
-> 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

40
freeform.hs Normal file
View File

@ -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