diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index 3a31a9cd..be462ecb 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -6,12 +6,10 @@ module Yesod.Formable ( Form (..) , Formlet - , SealedForm (..) - , SealedFormlet + , FormResult (..) , runForm , runIncr , Formable (..) - , Fieldable (..) , deriveFormable , share2 , wrapperRow @@ -36,12 +34,12 @@ import Yesod.Handler import Control.Monad.IO.Class (liftIO) import Web.Routes.Quasi -runForm :: SealedForm (Routes y) a - -> GHandler sub y (Either [String] a, Hamlet (Routes y)) +runForm :: Form (Routes y) a + -> GHandler sub y (FormResult a, Hamlet (Routes y)) runForm f = do req <- getRequest (pp, _) <- liftIO $ reqRequestBody req - return $ fst $ runIncr (runSealedForm f pp) 1 + return $ fst $ runIncr (deform f pp) 1 type Env = [(String, String)] @@ -61,44 +59,41 @@ instance Functor FormResult where fmap _ FormMissing = FormMissing fmap _ (FormFailure errs) = FormFailure errs fmap f (FormSuccess a) = FormSuccess $ f a +instance Applicative FormResult where + pure = FormSuccess + (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g + (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y + (FormFailure x) <*> _ = FormFailure x + _ <*> (FormFailure y) = FormFailure y + _ <*> _ = FormMissing -newtype Form url a = Form (Env -> Incr (FormResult a, Hamlet url)) -type Formlet url a = Maybe a -> Form url a - -newtype SealedForm url a = SealedForm - { runSealedForm :: Env -> Incr (Either [String] a, Hamlet url) +newtype Form url a = Form + { deform :: Env -> Incr (FormResult 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 (Right a, mempty) - (SealedForm f) <*> (SealedForm g) = SealedForm $ \env -> do - (f1, f2) <- f env - (g1, g2) <- g env - 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) = (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 -sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal +type Formlet url a = Maybe a -> Form url a instance Functor (Form url) where fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env) +instance Applicative (Form url) where + pure a = Form $ const $ return (pure a, mempty) + (Form f) <*> (Form g) = Form $ \env -> do + (f1, f2) <- f env + (g1, g2) <- g env + return (f1 <*> g1, f2 `mappend` g2) + +sealForm :: ([String] -> Hamlet url -> Hamlet url) + -> Form url a -> Form url a +sealForm wrapper (Form form) = Form $ \env -> liftM go (form env) + where + go (res, xml) = (res, wrapper (toList res) xml) + toList (FormFailure errs) = errs + toList _ = [] + +sealFormlet :: ([String] -> Hamlet url -> Hamlet url) + -> Formlet url a -> Formlet url a +sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal + input' :: (String -> String -> Hamlet url) -> Maybe String -> Form url String @@ -120,10 +115,7 @@ check (Form form) f = Form $ \env -> liftM (first go) (form env) Right b -> FormSuccess b class Formable a where - formable :: SealedFormlet url a - -class Fieldable a where - fieldable :: Formlet url a + formable :: Formlet url a wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url wrapperRow label errs control = [$hamlet| @@ -137,22 +129,22 @@ wrapperRow label errs control = [$hamlet| %li $string.err$ |] -instance Fieldable [Char] where - fieldable = input' go +instance Formable [Char] where + formable = input' go where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ |] -instance Fieldable Html where - fieldable = fmap preEscapedString +instance Formable Html where + formable = fmap preEscapedString . input' go . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) where go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] -instance Fieldable Day where - fieldable x = input' go (fmap show x) `check` asDay +instance Formable Day where + formable x = input' go (fmap show x) `check` asDay where go name val = [$hamlet| %input!type=date!name=$string.name$!value=$string.val$ @@ -164,8 +156,8 @@ instance Fieldable Day where newtype Slug = Slug { unSlug :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) -instance Fieldable Slug where - fieldable x = input' go (fmap unSlug x) `check` asSlug +instance Formable Slug where + formable x = input' go (fmap unSlug x) `check` asSlug where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ @@ -178,8 +170,8 @@ instance Fieldable Slug where newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) -instance Fieldable NonEmptyString where - fieldable x = input' go (fmap unNonEmptyString x) `check` notEmpty +instance Formable NonEmptyString where + formable x = input' go (fmap unNonEmptyString x) `check` notEmpty where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ @@ -218,5 +210,5 @@ deriveFormable = mapM derive go' (label, ex) = VarE (mkName "sealForm") `AppE` (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE` - (VarE (mkName "fieldable") `AppE` ex) + (VarE (mkName "formable") `AppE` ex) ap' ap x y = InfixE (Just x) ap (Just y) diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 24ba65ca..2c3e4947 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -128,7 +128,7 @@ crudHelper title me isPost = do (errs, form) <- runForm $ formable $ fmap snd me toMaster <- getRouteToMaster case (isPost, errs) of - (True, Right a) -> do + (True, FormSuccess a) -> do eid <- case me of Just (eid, _) -> do crudReplace crud eid a