diff --git a/Yesod/Form.hs b/Yesod/Form.hs index aa231410..490b3ff4 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -29,7 +29,7 @@ module Yesod.Form , Formable (..) , deriveFormable , share2 - -- * Pre-built formlets + -- * Pre-built form , optionalField , requiredField , notEmptyField @@ -54,6 +54,7 @@ import Data.Maybe (isJust) import Web.Routes.Quasi (SinglePiece) import Data.Int (Int64) import qualified Data.ByteString.Lazy.UTF8 +import Yesod.Widget data FormResult a = FormMissing | FormFailure [String] @@ -71,7 +72,7 @@ instance Applicative FormResult where _ <*> _ = FormMissing newtype Form sub y a = Form - { deform :: Env -> FileEnv -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y)) + { deform :: Env -> FileEnv -> Incr (GHandler sub y) (FormResult a, Widget sub y ()) } type Formlet sub y a = Maybe a -> Form sub y a @@ -91,12 +92,12 @@ instance Applicative (Form sub url) where runFormGeneric :: Env -> FileEnv -> Form sub y a - -> GHandler sub y (FormResult a, Hamlet (Routes y)) + -> GHandler sub y (FormResult a, Widget sub y ()) runFormGeneric env fe f = evalStateT (deform f env fe) 1 -- | Run a form against POST parameters. runFormPost :: Form sub y a - -> GHandler sub y (FormResult a, Hamlet (Routes y)) + -> GHandler sub y (FormResult a, Widget sub y ()) runFormPost f = do rr <- getRequest (pp, files) <- liftIO $ reqRequestBody rr @@ -112,26 +113,26 @@ runFormPost' = helper <=< runFormPost runFormGet' :: Form sub y a -> GHandler sub y a runFormGet' = helper <=< runFormGet -helper :: (FormResult a, Hamlet (Routes y)) -> GHandler sub y a +helper :: (FormResult a, Widget sub y ()) -> GHandler sub y a helper (FormSuccess a, _) = return a helper (FormFailure e, _) = invalidArgs e helper (FormMissing, _) = invalidArgs ["No input found"] -- | Run a form against GET parameters. runFormGet :: Form sub y a - -> GHandler sub y (FormResult a, Hamlet (Routes y)) + -> GHandler sub y (FormResult a, Widget sub y ()) runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f type Incr = StateT Int -incr :: Monad m => Incr m Int +incr :: Monad m => Incr m String incr = do i <- get let i' = i + 1 put i' - return i' + return $ "f" ++ show i' input :: (String -> String -> Hamlet (Routes y)) -> Maybe String @@ -141,7 +142,7 @@ input mkXml val = Form $ \env _ -> do let i' = show i let param = lookup i' env let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param - return (maybe FormMissing FormSuccess param, xml) + return (maybe FormMissing FormSuccess param, addBody xml) -- FIXME check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b check (Form form) f = Form $ \env fe -> liftM (first go) (form env fe) @@ -171,11 +172,11 @@ sealRow label getVal val = sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) -> Form sub y a -> Form sub y a -sealForm wrapper (Form form) = Form $ \env fe -> liftM go (form env fe) +sealForm wrapper (Form form) = error "FIXME" {-Form $ \env fe -> liftM go (form env fe) where go (res, xml) = (res, wrapper (toList res) xml) toList (FormFailure errs) = errs - toList _ = [] + toList _ = []-} sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) -> Formlet sub y a -> Formlet sub y a @@ -303,12 +304,11 @@ instance Formable (Maybe Int64) where instance Formable Bool where formable x = Form $ \env _ -> do i <- incr - let i' = show i - let param = lookup i' env + let param = lookup i env let def = if null env then fromMaybe False x else isJust param - return (FormSuccess $ isJust param, go i' def) + return (FormSuccess $ isJust param, go i def) where - go name val = [$hamlet| + go name val = addBody [$hamlet| %input!type=checkbox!name=$string.name$!:val:checked |] diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 9ebd8290..d777494d 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -11,6 +11,7 @@ module Yesod.Helpers.Crud ) where import Yesod.Yesod +import Yesod.Widget import Yesod.Dispatch import Yesod.Content import Yesod.Handler @@ -33,6 +34,7 @@ mkYesodSub "Crud master item" [ ("master", [''Yesod]) , ("item", [''Item]) , ("Key item", [''SinglePiece]) + , ("Routes master", [''Eq]) ] [$parseRoutes| / CrudListR GET /add CrudAddR GET POST @@ -56,21 +58,24 @@ getCrudListR = do %a!href=@toMaster.CrudAddR@ Add new item |] -getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) +getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), + Eq (Routes master)) => GHandler (Crud master item) master RepHtml getCrudAddR = crudHelper "Add new" (Nothing :: Maybe (Key item, item)) False -postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) +postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), + Eq (Routes master)) => GHandler (Crud master item) master RepHtml postCrudAddR = crudHelper "Add new" (Nothing :: Maybe (Key item, item)) True -getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) +getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), + Eq (Routes master)) => String -> GHandler (Crud master item) master RepHtml getCrudEditR s = do itemId <- maybe notFound return $ itemReadId s @@ -81,7 +86,8 @@ getCrudEditR s = do (Just (itemId, item)) False -postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) +postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), + Eq (Routes master)) => String -> GHandler (Crud master item) master RepHtml postCrudEditR s = do itemId <- maybe notFound return $ itemReadId s @@ -105,7 +111,7 @@ getCrudDeleteR s = do %p Do you really want to delete $string.itemTitle.item$? %p %input!type=submit!value=Yes - \ + \ $ %a!href=@toMaster.CrudListR@ No |] @@ -122,7 +128,7 @@ itemReadId :: SinglePiece x => String -> Maybe x itemReadId = either (const Nothing) Just . fromSinglePiece crudHelper - :: (Item a, Yesod master, SinglePiece (Key a)) + :: (Item a, Yesod master, SinglePiece (Key a), Eq (Routes master)) => String -> Maybe (Key a, a) -> Bool -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do @@ -139,7 +145,11 @@ crudHelper title me isPost = do redirect RedirectTemporary $ toMaster $ CrudEditR $ toSinglePiece eid _ -> return () - applyLayout title mempty [$hamlet| + applyLayoutW $ do + wrapWidget (wrapForm toMaster) form + setTitle $ string title + where + wrapForm toMaster form = [$hamlet| %p %a!href=@toMaster.CrudListR@ Return to list %h1 $string.title$ diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 767a2b5d..21fa4891 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -2,6 +2,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleInstances #-} module Yesod.Widget ( -- * Datatype Widget @@ -74,6 +75,9 @@ newtype Widget sub master a = Widget ( GHandler sub master ))))))) a) deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) +instance Monoid (Widget sub master ()) where + mempty = return () + mappend x y = x >> y setTitle :: Html () -> Widget sub master () setTitle = Widget . lift . tell . Last . Just . Title