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

Generalize formToAForm (fixes issue #213).

Browse Source
This commit is contained in:
Felipe Lessa 2012-01-17 10:15:08 -02:00
parent 4d5c123935
commit 746a3fe5d2
2 changed files with 8 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
yesod-form/Yesod/Form/Functions.hs
View File

@ -39,6 +39,7 @@ module Yesod.Form.Functions
import Yesod.Form.Types import Yesod.Form.Types
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Control.Arrow (second)
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST) import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad (liftM, join) import Control.Monad (liftM, join)
@ -74,10 +75,10 @@ newFormIdent = do
incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntSingle i) = IntSingle $ i + 1
incrInts (IntCons i is) = (i + 1) `IntCons` is incrInts (IntCons i is) = (i + 1) `IntCons` is
formToAForm :: MForm sub master (FormResult a, FieldView sub master) -> AForm sub master a formToAForm :: MForm sub master (FormResult a, [FieldView sub master]) -> AForm sub master a
formToAForm form = AForm $ \(master, langs) env ints -> do formToAForm form = AForm $ \(master, langs) env ints -> do
((a, xml), ints', enc) <- runRWST form (env, master, langs) ints ((a, xmls), ints', enc) <- runRWST form (env, master, langs) ints
return (a, (:) xml, ints', enc) return (a, (++) xmls, ints', enc)
aFormToForm :: AForm sub master a -> MForm sub master (FormResult a, [FieldView sub master] -> [FieldView sub master]) aFormToForm :: AForm sub master a -> MForm sub master (FormResult a, [FieldView sub master] -> [FieldView sub master])
aFormToForm (AForm aform) = do aFormToForm (AForm aform) = do
@ -150,14 +151,14 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
areq :: (RenderMessage master msg, RenderMessage master FormMessage) areq :: (RenderMessage master msg, RenderMessage master FormMessage)
=> Field sub master a -> FieldSettings msg -> Maybe a => Field sub master a -> FieldSettings msg -> Maybe a
-> AForm sub master a -> AForm sub master a
areq a b = formToAForm . mreq a b areq a b = formToAForm . fmap (second return) . mreq a b
aopt :: RenderMessage master msg aopt :: RenderMessage master msg
=> Field sub master a => Field sub master a
-> FieldSettings msg -> FieldSettings msg
-> Maybe (Maybe a) -> Maybe (Maybe a)
-> AForm sub master (Maybe a) -> AForm sub master (Maybe a)
aopt a b = formToAForm . mopt a b aopt a b = formToAForm . fmap (second return) . mopt a b
runFormGeneric :: MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype) runFormGeneric :: MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)
runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1) runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)

4
yesod-form/Yesod/Form/MassInput.hs
View File

@ -78,7 +78,7 @@ inputList label fixXml single mdef = formToAForm $ do
let count = length vals let count = length vals
(res, xmls, views) <- liftM fixme $ mapM (withDelete . single) vals (res, xmls, views) <- liftM fixme $ mapM (withDelete . single) vals
up 1 up 1
return (res, FieldView return (res, [FieldView
{ fvLabel = label { fvLabel = label
, fvTooltip = Nothing , fvTooltip = Nothing
, fvId = theId , fvId = theId
@ -93,7 +93,7 @@ inputList label fixXml single mdef = formToAForm $ do
|] |]
, fvErrors = Nothing , fvErrors = Nothing
, fvRequired = False , fvRequired = False
}) }])
withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage) withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage)
=> AForm sub master a => AForm sub master a