superclass in mkToForm

Yesod/Form.hs

@@ -89,7 +89,7 @@ import Yesod.Handler
 import Control.Applicative hiding (optional)
 import Data.Time (UTCTime(..), Day, TimeOfDay(..))
 import Data.Time.LocalTime (timeOfDayToTime, timeToTimeOfDay)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
 import "transformers" Control.Monad.IO.Class
 import Control.Monad ((<=<), liftM, join)
 import Data.Monoid (Monoid (..))
@@ -739,8 +739,8 @@ runFormGet f = do
     runFormGeneric gs [] f
 
 -- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=.
-mkToForm :: String -> [EntityDef] -> Q [Dec]
+mkToForm :: [EntityDef] -> Q [Dec]
-mkToForm name = mapM derive
+mkToForm = mapM derive
   where
     getTFF (_, _, z) = fromMaybe "toFormField" $ getTFF' z
     getTFF' [] = Nothing
@@ -762,6 +762,8 @@ mkToForm name = mapM derive
     getName' (('n':'a':'m':'e':'=':x):_) = Just x
     getName' (_:x) = getName' x
     getName' [] = Nothing
+    getSuperclass ('s':'u':'p':'e':'r':'c':'l':'a':'s':'s':'=':s) = Just s
+    getSuperclass _ = Nothing
     derive :: EntityDef -> Q Dec
     derive t = do
         let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t
@@ -786,9 +788,14 @@ mkToForm name = mapM derive
                             $ map VarP xs]]
                         (NormalB $ go_ $ zip cols xs')
                         []
-        return $ InstanceD [] (ConT ''ToForm
+        let y = mkName "y"
+        let ctx = map (\x -> ClassP (mkName x) [VarT y])
+                $ mapMaybe getSuperclass
+                $ concatMap (\(_, _, z) -> z)
+                $ entityColumns t
+        return $ InstanceD ctx ( ConT ''ToForm
                               `AppT` ConT (mkName $ entityName t)
-                              `AppT` ConT (mkName name))
+                              `AppT` VarT y)
             [FunD (mkName "toForm") [c1, c2]]
     go ap just' ffs' stm string' mfx ftt a =
         let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a

blog2.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+import Yesod
+import Yesod.Helpers.Crud
+import Database.Persist.Sqlite
+import Database.Persist.TH
+import Data.Time (Day)
+
+share2 mkToForm mkPersist [$persist|
+Entry
+    title String id=thetitle
+    day Day Desc toFormField=jqueryDayField name=day superclass=Yesod
+    content Html' toFormField=nicHtmlField
+    deriving
+|]
+
+instance Item Entry where
+    itemTitle = entryTitle
+
+data Blog = Blog { pool :: Pool Connection }
+
+type EntryCrud = Crud Blog Entry
+
+mkYesod "Blog" [$parseRoutes|
+/ RootR GET
+/entry/#EntryId EntryR GET
+/admin AdminR EntryCrud defaultCrud
+|]
+
+instance Yesod Blog where
+    approot _ = "http://localhost:3000"
+
+instance YesodPersist Blog where
+    type YesodDB Blog = SqliteReader
+    runDB db = fmap pool getYesod>>= runSqlite db
+
+getRootR = do
+    entries <- runDB $ selectList [] [EntryDayDesc] 0 0
+    applyLayoutW $ do
+        setTitle $ string "Yesod Blog Tutorial Homepage"
+        addBody [$hamlet|
+%h1 Archive
+%ul
+    $forall entries entry
+        %li
+            %a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$
+%p
+    %a!href=@AdminR.CrudListR@ Admin
+|]
+
+getEntryR entryid = do
+    entry <- runDB $ get404 entryid
+    applyLayoutW $ do
+        setTitle $ string $ entryTitle entry
+        addBody [$hamlet|
+%h1 $entryTitle.entry$
+%h2 $show.entryDay.entry$
+$entryContent.entry$
+|]
+
+withBlog f = withSqlite ":memory:" 8 $ \p -> do
+    flip runSqlite p $ do
+        initialize (undefined :: Entry)
+    f $ Blog p
+
+main = withBlog $ basicHandler 3000