persistent changes

This commit is contained in:
Michael Snoyman 2010-06-20 10:33:55 +03:00
parent 08ad4709c0
commit 72aad8659d
3 changed files with 15 additions and 12 deletions

View File

@ -25,7 +25,8 @@ module Yesod.Formable
import Text.Hamlet import Text.Hamlet
import Data.Time (Day) import Data.Time (Day)
import Control.Applicative import Control.Applicative
import Database.Persist (Persistable, Table (..)) import Database.Persist (PersistField)
import Database.Persist.Helper (EntityDef (..))
import Data.Char (isAlphaNum, toUpper, isUpper) import Data.Char (isAlphaNum, toUpper, isUpper)
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Control.Monad (liftM, join) import Control.Monad (liftM, join)
@ -159,7 +160,7 @@ instance Formable (Maybe String) where
| null s = Right Nothing | null s = Right Nothing
| otherwise = Right $ Just s | otherwise = Right $ Just s
instance Formable Html where instance Formable (Html ()) where
formable = fmap preEscapedString formable = fmap preEscapedString
. input' go . input' go
. fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)
@ -257,7 +258,7 @@ instance Formable Int where
[] -> Left ["Invalid integer"] [] -> Left ["Invalid integer"]
newtype Slug = Slug { unSlug :: String } newtype Slug = Slug { unSlug :: String }
deriving (Read, Eq, Show, SinglePiece, Persistable) deriving (Read, Eq, Show, SinglePiece, PersistField)
instance Formable Slug where instance Formable Slug where
formable x = input' go (fmap unSlug x) `check` asSlug formable x = input' go (fmap unSlug x) `check` asSlug
@ -277,28 +278,29 @@ share2 f g a = do
g' <- g a g' <- g a
return $ f' ++ g' return $ f' ++ g'
deriveFormable :: [Table] -> Q [Dec] deriveFormable :: [EntityDef] -> Q [Dec]
deriveFormable = mapM derive deriveFormable = mapM derive
where where
derive :: Table -> Q Dec derive :: EntityDef -> Q Dec
derive t = do derive t = do
let cols = map (toLabel . fst) $ tableColumns t let fst3 (x, _, _) = x
let cols = map (toLabel . fst3) $ entityColumns t
ap <- [|(<*>)|] ap <- [|(<*>)|]
just <- [|pure|] just <- [|pure|]
nothing <- [|Nothing|] nothing <- [|Nothing|]
let just' = just `AppE` ConE (mkName $ tableName t) let just' = just `AppE` ConE (mkName $ entityName t)
let c1 = Clause [ ConP (mkName "Nothing") [] let c1 = Clause [ ConP (mkName "Nothing") []
] ]
(NormalB $ go ap just' $ zip cols $ map (const nothing) cols) (NormalB $ go ap just' $ zip cols $ map (const nothing) cols)
[] []
xs <- mapM (const $ newName "x") cols xs <- mapM (const $ newName "x") cols
let xs' = map (AppE just . VarE) xs let xs' = map (AppE just . VarE) xs
let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ tableName t) let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)
$ map VarP xs]] $ map VarP xs]]
(NormalB $ go ap just' $ zip cols xs') (NormalB $ go ap just' $ zip cols xs')
[] []
return $ InstanceD [] (ConT ''Formable return $ InstanceD [] (ConT ''Formable
`AppT` ConT (mkName $ tableName t)) `AppT` ConT (mkName $ entityName t))
[FunD (mkName "formable") [c1, c2]] [FunD (mkName "formable") [c1, c2]]
go ap just' = foldl (ap' ap) just' . map go' go ap just' = foldl (ap' ap) just' . map go'
go' (label, ex) = go' (label, ex) =

View File

@ -153,7 +153,8 @@ crudHelper title me isPost = do
%a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete
|] |]
defaultCrud :: (Persist i (YesodDB a (GHandler (Crud a i) a)), YesodPersist a) defaultCrud :: (PersistEntity i, YesodPersist a,
PersistMonad i ~ YesodDB a (GHandler (Crud a i) a))
=> a -> Crud a i => a -> Crud a i
defaultCrud = const Crud defaultCrud = const Crud
{ crudSelect = runDB $ select [] [] { crudSelect = runDB $ select [] []

View File

@ -8,7 +8,7 @@ module Yesod.Yesod
, YesodSite (..) , YesodSite (..)
-- ** Persistence -- ** Persistence
, YesodPersist (..) , YesodPersist (..)
, Persist (..) , PersistEntity (..)
-- * Convenience functions -- * Convenience functions
, applyLayout , applyLayout
, applyLayoutJson , applyLayoutJson
@ -27,7 +27,7 @@ import Web.ClientSession (getKey, defaultKeyFile)
import qualified Web.ClientSession as CS import qualified Web.ClientSession as CS
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.ByteString.UTF8 (toString) import Data.ByteString.UTF8 (toString)
import Database.Persist (Persist (..)) import Database.Persist (PersistEntity (..))
import Web.Routes.Quasi (QuasiSite (..), Routes) import Web.Routes.Quasi (QuasiSite (..), Routes)