diff --git a/Yesod/Form.hs b/Yesod/Form.hs index ec4a0911..2aac29bf 100644 --- a/Yesod/Form.hs +++ b/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 name = mapM derive +mkToForm :: [EntityDef] -> Q [Dec] +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 diff --git a/blog2.hs b/blog2.hs new file mode 100644 index 00000000..7c46e706 --- /dev/null +++ b/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