From 0db163aea86ff923b9ab5ca5fca0aa840a8fb127 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 22 Jul 2010 12:27:26 +0300 Subject: [PATCH] ToForm and ToFormField take master site param --- Yesod/Dispatch.hs | 10 +++------- Yesod/Form.hs | 42 ++++++++++++++++++++++-------------------- Yesod/Helpers/Crud.hs | 24 +++++++++++++++--------- 3 files changed, 40 insertions(+), 36 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 0e3dfe36..bc9b64d2 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -93,7 +93,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False -- executable by itself, but instead provides functionality to -- be embedded in other sites. mkYesodSub :: String -- ^ name of the argument datatype - -> [(String, [Name])] + -> Cxt -> [Resource] -> Q [Dec] mkYesodSub name clazzes = @@ -130,7 +130,7 @@ typeHelper = mkYesodGeneral :: String -- ^ argument name -> [String] -- ^ parameters for site argument - -> [(String, [Name])] -- ^ classes + -> Cxt -- ^ classes -> Bool -- ^ is subsite? -> [Resource] -> Q ([Dec], [Dec]) @@ -138,10 +138,6 @@ mkYesodGeneral name args clazzes isSub res = do let name' = mkName name args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args' - let clazzes' = map (\(x, y) -> ClassP x [typeHelper y]) - $ concatMap (\(x, y) -> zip y $ repeat x) - $ compact - $ map (\x -> (x, [])) ("master" : args) ++ clazzes th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites w' <- createRoutes th let routesName = mkName $ name ++ "Route" @@ -166,7 +162,7 @@ mkYesodGeneral name args clazzes isSub res = do let site' = site `AppE` dispatch `AppE` render `AppE` parse let (ctx, ytyp, yfunc) = if isSub - then (clazzes', ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") + then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") else ([], ConT ''YesodSite `AppT` arg, "getSite") let y = InstanceD ctx ytyp [ FunD (mkName yfunc) [Clause [] (NormalB site') []] diff --git a/Yesod/Form.hs b/Yesod/Form.hs index b9323ff9..b75cf36d 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | Parse forms (and query strings). module Yesod.Form ( -- * Data types @@ -204,9 +205,9 @@ fieldsToTable = mapM_ go %td.errors $err$ |] -class ToForm a where +class ToForm a y where toForm :: Maybe a -> Form sub y a -class ToFormField a where +class ToFormField a y where toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a -- | Create a required field (ie, one that cannot be blank) from a @@ -304,9 +305,9 @@ stringFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField String where +instance ToFormField String y where toFormField = stringField -instance ToFormField (Maybe String) where +instance ToFormField (Maybe String) y where toFormField = maybeStringField intInput :: Integral i => String -> FormInput sub master i @@ -346,13 +347,13 @@ intFieldProfile = FieldProfile readMayI s = case reads s of (x, _):_ -> Just $ fromInteger x [] -> Nothing -instance ToFormField Int where +instance ToFormField Int y where toFormField = intField -instance ToFormField (Maybe Int) where +instance ToFormField (Maybe Int) y where toFormField = maybeIntField -instance ToFormField Int64 where +instance ToFormField Int64 y where toFormField = intField -instance ToFormField (Maybe Int64) where +instance ToFormField (Maybe Int64) y where toFormField = maybeIntField doubleField :: Html () -> Html () -> FormletField sub y Double @@ -379,9 +380,9 @@ doubleFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField Double where +instance ToFormField Double y where toFormField = doubleField -instance ToFormField (Maybe Double) where +instance ToFormField (Maybe Double) y where toFormField = maybeDoubleField dayField :: Html () -> Html () -> FormletField sub y Day @@ -408,9 +409,9 @@ dayFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField Day where +instance ToFormField Day y where toFormField = dayField -instance ToFormField (Maybe Day) where +instance ToFormField (Maybe Day) y where toFormField = maybeDayField jqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y Day @@ -556,9 +557,9 @@ timeFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField TimeOfDay where +instance ToFormField TimeOfDay y where toFormField = timeField -instance ToFormField (Maybe TimeOfDay) where +instance ToFormField (Maybe TimeOfDay) y where toFormField = maybeTimeField boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool @@ -582,7 +583,7 @@ boolField label tooltip orig = GForm $ \env _ -> do _ -> Nothing } return (res, [fi], UrlEncoded) -instance ToFormField Bool where +instance ToFormField Bool y where toFormField = boolField htmlField :: Html () -> Html () -> FormletField sub y (Html ()) @@ -609,9 +610,9 @@ htmlFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField (Html ()) where +instance ToFormField (Html ()) y where toFormField = htmlField -instance ToFormField (Maybe (Html ())) where +instance ToFormField (Maybe (Html ())) y where toFormField = maybeHtmlField type Html' = Html () @@ -816,8 +817,8 @@ share2 f g a = do return $ f' ++ g' -- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. -mkToForm :: [EntityDef] -> Q [Dec] -mkToForm = mapM derive +mkToForm :: String -> [EntityDef] -> Q [Dec] +mkToForm name = mapM derive where getTFF (_, _, z) = fromMaybe "toFormField" $ getTFF' z getTFF' [] = Nothing @@ -853,7 +854,8 @@ mkToForm = mapM derive (NormalB $ go_ $ zip cols xs') [] return $ InstanceD [] (ConT ''ToForm - `AppT` ConT (mkName $ entityName t)) + `AppT` ConT (mkName $ entityName t) + `AppT` ConT (mkName name)) [FunD (mkName "toForm") [c1, c2]] go ap just' string' mfx ftt a = let x = foldl (ap' ap) just' $ map (go' string') a diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index e3d718c8..446526c1 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -18,9 +18,10 @@ import Yesod.Handler import Text.Hamlet import Yesod.Form import Data.Monoid (mempty) +import Language.Haskell.TH.Syntax -- | An entity which can be displayed by the Crud subsite. -class ToForm a => Item a where +class Item a where -- | The title of an entity, to be displayed in the list of all entities. itemTitle :: a -> String @@ -36,9 +37,10 @@ data Crud master item = Crud } mkYesodSub "Crud master item" - [ ("master", [''Yesod]) - , ("item", [''Item]) - , ("Key item", [''SinglePiece]) + [ ClassP ''Yesod [VarT $ mkName "master"] + , ClassP ''Item [VarT $ mkName "item"] + , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")] + , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"] ] [$parseRoutes| / CrudListR GET /add CrudAddR GET POST @@ -62,21 +64,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), + ToForm item 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), + ToForm item 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), + ToForm item master) => String -> GHandler (Crud master item) master RepHtml getCrudEditR s = do itemId <- maybe notFound return $ itemReadId s @@ -87,7 +92,8 @@ getCrudEditR s = do (Just (itemId, item)) False -postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) +postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), + ToForm item master) => String -> GHandler (Crud master item) master RepHtml postCrudEditR s = do itemId <- maybe notFound return $ itemReadId s @@ -128,7 +134,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), ToForm a master) => String -> Maybe (Key a, a) -> Bool -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do