ToForm and ToFormField take master site param

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') []]

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

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