Foundations for multiForm.
Instead of a single integer, we store a list of integers in a form. This allows nesting. Now there are some auxilary functions for nesting level manipulation, as well as a Monoid instance for FormResult.
This commit is contained in:
parent
95392aba0a
commit
280aa5d543
@ -31,6 +31,8 @@ module Yesod.Form
|
|||||||
, optionalFieldHelper
|
, optionalFieldHelper
|
||||||
, mapFormXml
|
, mapFormXml
|
||||||
, newFormIdent
|
, newFormIdent
|
||||||
|
, deeperFormIdent
|
||||||
|
, shallowerFormIdent
|
||||||
, fieldsToTable
|
, fieldsToTable
|
||||||
, fieldsToPlain
|
, fieldsToPlain
|
||||||
, fieldsToInput
|
, fieldsToInput
|
||||||
@ -128,6 +130,9 @@ instance Applicative FormResult where
|
|||||||
(FormFailure x) <*> _ = FormFailure x
|
(FormFailure x) <*> _ = FormFailure x
|
||||||
_ <*> (FormFailure y) = FormFailure y
|
_ <*> (FormFailure y) = FormFailure y
|
||||||
_ <*> _ = FormMissing
|
_ <*> _ = FormMissing
|
||||||
|
instance Monoid m => Monoid (FormResult m) where
|
||||||
|
mempty = pure mempty
|
||||||
|
mappend x y = mappend <$> x <*> y
|
||||||
|
|
||||||
-- | The encoding type required by a form. The 'Show' instance produces values
|
-- | The encoding type required by a form. The 'Show' instance produces values
|
||||||
-- that can be inserted directly into HTML.
|
-- that can be inserted directly into HTML.
|
||||||
@ -140,10 +145,19 @@ instance Monoid Enctype where
|
|||||||
mappend UrlEncoded UrlEncoded = UrlEncoded
|
mappend UrlEncoded UrlEncoded = UrlEncoded
|
||||||
mappend _ _ = Multipart
|
mappend _ _ = Multipart
|
||||||
|
|
||||||
|
data Ints = IntCons Int Ints | IntSingle Int
|
||||||
|
instance Show Ints where
|
||||||
|
show (IntSingle i) = show i
|
||||||
|
show (IntCons i is) = show i ++ '-' : show is
|
||||||
|
|
||||||
|
incrInts :: Ints -> Ints
|
||||||
|
incrInts (IntSingle i) = IntSingle $ i + 1
|
||||||
|
incrInts (IntCons i is) = (i + 1) `IntCons` is
|
||||||
|
|
||||||
-- | A generic form, allowing you to specifying the subsite datatype, master
|
-- | A generic form, allowing you to specifying the subsite datatype, master
|
||||||
-- site datatype, a datatype for the form XML and the return type.
|
-- site datatype, a datatype for the form XML and the return type.
|
||||||
newtype GForm sub y xml a = GForm
|
newtype GForm sub y xml a = GForm
|
||||||
{ deform :: Env -> FileEnv -> StateT Int (GHandler sub y) (FormResult a, xml, Enctype)
|
{ deform :: Env -> FileEnv -> StateT Ints (GHandler sub y) (FormResult a, xml, Enctype)
|
||||||
}
|
}
|
||||||
type Form sub y = GForm sub y (GWidget sub y ())
|
type Form sub y = GForm sub y (GWidget sub y ())
|
||||||
type Formlet sub y a = Maybe a -> Form sub y a
|
type Formlet sub y a = Maybe a -> Form sub y a
|
||||||
@ -614,18 +628,29 @@ maybeDayInput n =
|
|||||||
--------------------- End prebuilt inputs
|
--------------------- End prebuilt inputs
|
||||||
|
|
||||||
-- | Get a unique identifier.
|
-- | Get a unique identifier.
|
||||||
newFormIdent :: Monad m => StateT Int m String
|
newFormIdent :: Monad m => StateT Ints m String
|
||||||
newFormIdent = do
|
newFormIdent = do
|
||||||
i <- get
|
i <- get
|
||||||
let i' = i + 1
|
let i' = incrInts i
|
||||||
put i'
|
put i'
|
||||||
return $ "f" ++ show i'
|
return $ 'f' : show i'
|
||||||
|
|
||||||
|
deeperFormIdent :: Monad m => StateT Ints m ()
|
||||||
|
deeperFormIdent = do
|
||||||
|
i <- get
|
||||||
|
let i' = 1 `IntCons` incrInts i
|
||||||
|
put i'
|
||||||
|
|
||||||
|
shallowerFormIdent :: Monad m => StateT Ints m ()
|
||||||
|
shallowerFormIdent = do
|
||||||
|
IntCons _ i <- get
|
||||||
|
put i
|
||||||
|
|
||||||
runFormGeneric :: Env
|
runFormGeneric :: Env
|
||||||
-> FileEnv
|
-> FileEnv
|
||||||
-> GForm sub y xml a
|
-> GForm sub y xml a
|
||||||
-> GHandler sub y (FormResult a, xml, Enctype)
|
-> GHandler sub y (FormResult a, xml, Enctype)
|
||||||
runFormGeneric env fe f = evalStateT (deform f env fe) 1
|
runFormGeneric env fe f = evalStateT (deform f env fe) $ IntSingle 1
|
||||||
|
|
||||||
-- | Run a form against POST parameters.
|
-- | Run a form against POST parameters.
|
||||||
runFormPost :: GForm sub y xml a
|
runFormPost :: GForm sub y xml a
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user