From 1236bbeb407746606421c2afc262922db2bc30fa Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 8 Jun 2010 22:43:51 +0300 Subject: [PATCH] Local formlet implementation with inline error messages --- Yesod/Contrib.hs | 2 +- Yesod/Contrib/Crud.hs | 38 +++++------- Yesod/Contrib/Formable.hs | 124 +++++++++++++++++++++++++++++++++----- 3 files changed, 126 insertions(+), 38 deletions(-) diff --git a/Yesod/Contrib.hs b/Yesod/Contrib.hs index bfbca604..a14027c0 100644 --- a/Yesod/Contrib.hs +++ b/Yesod/Contrib.hs @@ -4,6 +4,6 @@ module Yesod.Contrib , module Yesod.Contrib.Persist ) where -import Yesod.Contrib.Formable +import Yesod.Contrib.Formable hiding (runForm) import Yesod.Contrib.Crud import Yesod.Contrib.Persist diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Contrib/Crud.hs index 0dea88d0..e9007167 100644 --- a/Yesod/Contrib/Crud.hs +++ b/Yesod/Contrib/Crud.hs @@ -6,20 +6,17 @@ module Yesod.Contrib.Crud where import Yesod hiding (Form) import Database.Persist import Control.Applicative.Error -import Yesod.Contrib.Formable +import Yesod.Contrib.Formable hiding (runForm) import Yesod.Contrib.Persist -import Text.Formlets import Control.Arrow (second) import Data.Monoid (mempty) -runForm :: Form xml (GHandler sub y) a -> GHandler sub y (Failing a, xml) +runForm :: SealedForm (Routes y) a + -> GHandler sub y (Maybe a, Hamlet (Routes y)) runForm f = do req <- getRequest (pp, _) <- liftIO $ reqRequestBody req - let env = map (second Left) pp - let (a, b, _) = runFormState env f - a' <- a - return (a', b) + return $ fst $ runIncr (runSealedForm f pp) 1 class Formable a => Item a where itemTitle :: a -> String @@ -100,7 +97,7 @@ getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) getCrudDeleteR s = do itemId <- maybe notFound return $ itemReadId s crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return + item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists toMaster <- getRouteToMaster applyLayout "Confirm delete" mempty [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ @@ -132,25 +129,20 @@ crudHelper title me isPost = do crud <- getYesodSub (errs, form) <- runForm $ formable $ fmap snd me toMaster <- getRouteToMaster - errs' <- case (isPost, errs) of - (True, Success a) -> do - eid <- case me of - Just (eid, _) -> do - crudReplace crud eid a - return eid - Nothing -> crudInsert crud a - redirect RedirectTemporary $ toMaster $ CrudEditR - $ toSinglePiece eid - (True, Failure e) -> return $ Just e - (False, _) -> return Nothing + case (isPost, errs) of + (True, Just a) -> do + eid <- case me of + Just (eid, _) -> do + crudReplace crud eid a + return eid + Nothing -> crudInsert crud a + redirect RedirectTemporary $ toMaster $ CrudEditR + $ toSinglePiece eid + _ -> return () applyLayout title mempty [$hamlet| %p %a!href=@toMaster.CrudListR@ Return to list %h1 $cs.title$ -$maybe errs' es - %ul - $forall es e - %li $cs.e$ %form!method=post %table ^form^ diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Contrib/Formable.hs index 8e0dbeea..b28a61df 100644 --- a/Yesod/Contrib/Formable.hs +++ b/Yesod/Contrib/Formable.hs @@ -5,7 +5,6 @@ {-# LANGUAGE TypeSynonymInstances #-} module Yesod.Contrib.Formable where -import Text.Formlets import Text.Hamlet import Data.Time (Day) import Control.Applicative @@ -17,23 +16,101 @@ import Language.Haskell.TH.Syntax import Database.Persist (Table (..)) import Database.Persist.Helper (upperFirst) import Data.Convertible.Text (cs) +import Control.Monad (liftM) +import Control.Arrow (first) +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty, mappend) + +type Env = [(String, String)] + +newtype Incr a = Incr { runIncr :: Int -> (a, Int) } +incr :: Incr Int +incr = Incr $ \i -> (i + 1, i + 1) +instance Monad Incr where + return a = Incr $ \i -> (a, i) + Incr x >>= f = Incr $ \i -> + let (x', i') = x i + in runIncr (f x') i' + +data FormResult a = FormMissing + | FormFailure [String] + | FormSuccess a +instance Functor FormResult where + fmap _ FormMissing = FormMissing + fmap _ (FormFailure errs) = FormFailure errs + fmap f (FormSuccess a) = FormSuccess $ f a + +newtype Form url a = Form + { runForm :: Env -> Incr (FormResult a, [String] -> Hamlet url) + } +type Formlet url a = Maybe a -> Form url a + +newtype SealedForm url a = SealedForm + { runSealedForm :: Env -> Incr (Maybe 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) + (SealedForm f) <*> (SealedForm g) = SealedForm $ \env -> do + (f1, f2) <- f env + (g1, g2) <- g env + return (f1 <*> g1, f2 `mappend` g2) + +sealForm :: Form url a -> SealedForm url a +sealForm (Form form) = SealedForm $ \env -> liftM go (form env) + where + go (FormSuccess a, xml) = (Just a, xml []) + go (FormFailure errs, xml) = (Nothing, xml errs) + go (FormMissing, xml) = (Nothing, xml []) + +sealFormlet :: Formlet url a -> SealedFormlet url a +sealFormlet formlet initVal = sealForm $ formlet initVal + +instance Functor (Form url) where + fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env) + +input' :: (String -> String -> [String] -> Hamlet url) + -> Maybe String + -> Form url String +input' mkXml val = Form $ \env -> do + i <- incr + let i' = show i + let param = lookup i' env + let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param + return (maybe FormMissing FormSuccess param, xml) + +check :: Form url a -> (a -> Either [String] b) -> Form url b +check (Form form) f = Form $ \env -> liftM (first go) (form env) + where + go FormMissing = FormMissing + go (FormFailure x) = FormFailure x + go (FormSuccess a) = + case f a of + Left errs -> FormFailure errs + Right b -> FormSuccess b class Formable a where - formable :: (Functor m, Applicative m, Monad m) - => Formlet (Hamlet url) m a + formable :: SealedFormlet url a class Fieldable a where - fieldable :: (Functor m, Applicative m, Monad m) - => String -> Formlet (Hamlet url) m a + fieldable :: String -> Formlet url a instance Fieldable [Char] where fieldable label = input' go where - go name val = [$hamlet| + go name val errs = [$hamlet| %tr %th $string.label$ %td %input!type=text!name=$string.name$!value=$string.val$ + $if not.null.errs + %td.errors + %ul + $forall errs err + %li $string.err$ |] instance Fieldable Html where @@ -42,24 +119,36 @@ instance Fieldable Html where . input' go . fmap (cs . renderHtml) where - go name val = [$hamlet| + go name val errs = [$hamlet| %tr %th $string.label$ %td %textarea!name=$string.name$ $string.val$ + $if not.null.errs + %td.errors + %ul + $forall errs err + %li $string.err$ |] instance Fieldable Day where fieldable label x = input' go (fmap show x) `check` asDay where - go name val = [$hamlet| + go name val errs = [$hamlet| %tr %th $string.label$ %td %input!type=date!name=$string.name$!value=$string.val$ + $if not.null.errs + %td.errors + %ul + $forall errs err + %li $string.err$ |] - asDay s = maybeRead' s "Invalid day" + asDay s = case reads s of + (x, _):_ -> Right x + [] -> Left ["Invalid day"] newtype Slug = Slug { unSlug :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) @@ -67,17 +156,22 @@ newtype Slug = Slug { unSlug :: String } instance Fieldable Slug where fieldable label x = input' go (fmap unSlug x) `check` asSlug where - go name val = [$hamlet| + go name val errs = [$hamlet| %tr %th $string.label$ %td %input!type=text!name=$string.name$!value=$string.val$ + $if not.null.errs + %td.errors + %ul + $forall errs err + %li $string.err$ |] - asSlug [] = Failure ["Slug must be non-empty"] + asSlug [] = Left ["Slug must be non-empty"] asSlug x' | all (\c -> c `elem` "-_" || isAlphaNum c) x' = - Success $ Slug x' - | otherwise = Failure ["Slug must be alphanumeric, - and _"] + Right $ Slug x' + | otherwise = Left ["Slug must be alphanumeric, - and _"] share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] share2 f g a = do @@ -107,5 +201,7 @@ deriveFormable = mapM derive return $ InstanceD [] (ConT ''Formable `AppT` ConT (mkName $ tableName t)) [FunD (mkName "formable") [c1, c2]] go ap just' = foldl (ap' ap) just' . map go' - go' (label, ex) = VarE (mkName "fieldable") `AppE` LitE (StringL label) `AppE` ex + go' (label, ex) = VarE (mkName "sealForm") `AppE` + (VarE (mkName "fieldable") + `AppE` LitE (StringL label) `AppE` ex) ap' ap x y = InfixE (Just x) ap (Just y)