persistent changes
This commit is contained in:
parent
08ad4709c0
commit
72aad8659d
@ -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) =
|
||||||
|
|||||||
@ -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 [] []
|
||||||
|
|||||||
@ -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)
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user