SealedForm keeps list of errors
This commit is contained in:
parent
3708445f7a
commit
2ba7dc6780
@ -12,7 +12,7 @@ import Control.Arrow (second)
|
||||
import Data.Monoid (mempty)
|
||||
|
||||
runForm :: SealedForm (Routes y) a
|
||||
-> GHandler sub y (Maybe a, Hamlet (Routes y))
|
||||
-> GHandler sub y (Either [String] a, Hamlet (Routes y))
|
||||
runForm f = do
|
||||
req <- getRequest
|
||||
(pp, _) <- liftIO $ reqRequestBody req
|
||||
@ -130,7 +130,7 @@ crudHelper title me isPost = do
|
||||
(errs, form) <- runForm $ formable $ fmap snd me
|
||||
toMaster <- getRouteToMaster
|
||||
case (isPost, errs) of
|
||||
(True, Just a) -> do
|
||||
(True, Right a) -> do
|
||||
eid <- case me of
|
||||
Just (eid, _) -> do
|
||||
crudReplace crud eid a
|
||||
|
||||
@ -45,26 +45,31 @@ newtype Form url a = Form
|
||||
type Formlet url a = Maybe a -> Form url a
|
||||
|
||||
newtype SealedForm url a = SealedForm
|
||||
{ runSealedForm :: Env -> Incr (Maybe a, Hamlet url)
|
||||
{ runSealedForm :: Env -> Incr (Either [String] a, Hamlet url)
|
||||
}
|
||||
type SealedFormlet url a = Maybe a -> SealedForm url a
|
||||
instance Functor (SealedForm url) where
|
||||
fmap f (SealedForm g) = SealedForm
|
||||
$ \env -> liftM (first $ fmap f) (g env)
|
||||
instance Applicative (SealedForm url) where
|
||||
pure a = SealedForm $ const $ return (Just a, mempty)
|
||||
pure a = SealedForm $ const $ return (Right a, mempty)
|
||||
(SealedForm f) <*> (SealedForm g) = SealedForm $ \env -> do
|
||||
(f1, f2) <- f env
|
||||
(g1, g2) <- g env
|
||||
return (f1 <*> g1, f2 `mappend` g2)
|
||||
return (f1 `apE` g1, f2 `mappend` g2)
|
||||
where
|
||||
apE (Left x) (Left y) = Left $ x ++ y
|
||||
apE (Left x) _ = Left x
|
||||
apE _ (Left y) = Left y
|
||||
apE (Right x) (Right y) = Right $ x y
|
||||
|
||||
sealForm :: ([String] -> Hamlet url -> Hamlet url)
|
||||
-> Form url a -> SealedForm url a
|
||||
sealForm wrapper (Form form) = SealedForm $ \env -> liftM go (form env)
|
||||
where
|
||||
go (FormSuccess a, xml) = (Just a, wrapper [] xml)
|
||||
go (FormFailure errs, xml) = (Nothing, wrapper errs xml)
|
||||
go (FormMissing, xml) = (Nothing, wrapper [] xml)
|
||||
go (FormSuccess a, xml) = (Right a, wrapper [] xml)
|
||||
go (FormFailure errs, xml) = (Left errs, wrapper errs xml)
|
||||
go (FormMissing, xml) = (Left [], wrapper [] xml)
|
||||
|
||||
sealFormlet :: ([String] -> Hamlet url -> Hamlet url)
|
||||
-> Formlet url a -> SealedFormlet url a
|
||||
|
||||
Loading…
Reference in New Issue
Block a user