{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards, UndecidableInstances #-}
module TreeTest where
import Init
share
[ mkPersist persistSettings { mpsGeneric = False }
, mkMigrate "treeMigrate"
] [persistLowerCase|
Tree sql=trees
name Text
parent Text Maybe
Primary name
Foreign Tree fkparent parent
|]
cleanDB
:: (PersistQuery backend, PersistEntityBackend Tree ~ backend, MonadIO m)
=> ReaderT backend m ()
cleanDB :: ReaderT backend m ()
cleanDB = do
[Filter Tree] -> ReaderT backend m ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter Tree])
specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec
specsWith :: RunDb SqlBackend m -> Spec
specsWith RunDb SqlBackend m
runDb = String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"tree" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Tree relationships" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ RunDb SqlBackend m
runDb RunDb SqlBackend m -> RunDb SqlBackend m
forall a b. (a -> b) -> a -> b
$ do
kgp :: Key Tree
kgp@(TreeKey gpt) <- Tree -> ReaderT SqlBackend m (Key Tree)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend) =>
record -> ReaderT backend m (Key record)
insert (Tree -> ReaderT SqlBackend m (Key Tree))
-> Tree -> ReaderT SqlBackend m (Key Tree)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Tree
Tree Text
"grandpa" Maybe Text
forall a. Maybe a
Nothing
kdad :: Key Tree
kdad@(TreeKey dadt) <- Tree -> ReaderT SqlBackend m (Key Tree)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend) =>
record -> ReaderT backend m (Key record)
insert (Tree -> ReaderT SqlBackend m (Key Tree))
-> Tree -> ReaderT SqlBackend m (Key Tree)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Tree
Tree Text
"dad" (Maybe Text -> Tree) -> Maybe Text -> Tree
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
gpt
Key Tree
kc <- Tree -> ReaderT SqlBackend m (Key Tree)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend) =>
record -> ReaderT backend m (Key record)
insert (Tree -> ReaderT SqlBackend m (Key Tree))
-> Tree -> ReaderT SqlBackend m (Key Tree)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Tree
Tree Text
"child" (Maybe Text -> Tree) -> Maybe Text -> Tree
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
dadt
Tree
c <- Key Tree -> ReaderT SqlBackend m Tree
forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key Tree
kc
Tree -> Maybe (Key Tree)
treeFkparent Tree
c Maybe (Key Tree) -> Maybe (Key Tree) -> ReaderT SqlBackend m ()
forall a (m :: * -> *).
(HasCallStack, Eq a, Show a, MonadIO m) =>
a -> a -> m ()
@== Key Tree -> Maybe (Key Tree)
forall a. a -> Maybe a
Just Key Tree
kdad
Tree
dad <- Key Tree -> ReaderT SqlBackend m Tree
forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key Tree
kdad
Tree -> Maybe (Key Tree)
treeFkparent Tree
dad Maybe (Key Tree) -> Maybe (Key Tree) -> ReaderT SqlBackend m ()
forall a (m :: * -> *).
(HasCallStack, Eq a, Show a, MonadIO m) =>
a -> a -> m ()
@== Key Tree -> Maybe (Key Tree)
forall a. a -> Maybe a
Just Key Tree
kgp
Tree
gp <- Key Tree -> ReaderT SqlBackend m Tree
forall record backend (m :: * -> *).
(PersistStoreRead backend, PersistRecordBackend record backend,
MonadIO m) =>
Key record -> ReaderT backend m record
getJust Key Tree
kgp
Tree -> Maybe (Key Tree)
treeFkparent Tree
gp Maybe (Key Tree) -> Maybe (Key Tree) -> ReaderT SqlBackend m ()
forall a (m :: * -> *).
(HasCallStack, Eq a, Show a, MonadIO m) =>
a -> a -> m ()
@== Maybe (Key Tree)
forall a. Maybe a
Nothing
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"entityDef" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
let ed :: EntityDef
ed = Proxy Tree -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Proxy Tree
forall k (t :: k). Proxy t
Proxy :: Proxy Tree)
String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has the right haskell name" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
EntityDef -> EntityNameHS
getEntityHaskellName EntityDef
ed EntityNameHS -> EntityNameHS -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> EntityNameHS
EntityNameHS Text
"Tree"
String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has the right DB name" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
EntityDef -> EntityNameDB
getEntityDBName EntityDef
ed EntityNameDB -> EntityNameDB -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> EntityNameDB
EntityNameDB Text
"trees"
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"foreign ref" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
let [ForeignDef{Bool
[((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
[Text]
FieldCascade
EntityNameHS
EntityNameDB
ConstraintNameDB
ConstraintNameHS
foreignRefTableHaskell :: ForeignDef -> EntityNameHS
foreignRefTableDBName :: ForeignDef -> EntityNameDB
foreignConstraintNameHaskell :: ForeignDef -> ConstraintNameHS
foreignConstraintNameDBName :: ForeignDef -> ConstraintNameDB
foreignFieldCascade :: ForeignDef -> FieldCascade
foreignFields :: ForeignDef
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignAttrs :: ForeignDef -> [Text]
foreignNullable :: ForeignDef -> Bool
foreignToPrimary :: ForeignDef -> Bool
foreignToPrimary :: Bool
foreignNullable :: Bool
foreignAttrs :: [Text]
foreignFields :: [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFieldCascade :: FieldCascade
foreignConstraintNameDBName :: ConstraintNameDB
foreignConstraintNameHaskell :: ConstraintNameHS
foreignRefTableDBName :: EntityNameDB
foreignRefTableHaskell :: EntityNameHS
..}] = EntityDef -> [ForeignDef]
getEntityForeignDefs (Proxy Tree -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Proxy Tree
forall k (t :: k). Proxy t
Proxy :: Proxy Tree))
String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has the right haskell name" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
EntityNameHS
foreignRefTableHaskell EntityNameHS -> EntityNameHS -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe`
Text -> EntityNameHS
EntityNameHS Text
"Tree"
String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has the right db name" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
EntityNameDB
foreignRefTableDBName EntityNameDB -> EntityNameDB -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe`
Text -> EntityNameDB
EntityNameDB Text
"trees"
String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has the right constraint name" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
ConstraintNameHS
foreignConstraintNameHaskell ConstraintNameHS -> ConstraintNameHS -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe`
Text -> ConstraintNameHS
ConstraintNameHS Text
"fkparent"
String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has the right DB constraint name" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
ConstraintNameDB
foreignConstraintNameDBName ConstraintNameDB -> ConstraintNameDB -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe`
Text -> ConstraintNameDB
ConstraintNameDB Text
"treefkparent"
String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has the right fields" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
[((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
foreignFields [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> [((FieldNameHS, FieldNameDB), (FieldNameHS, FieldNameDB))]
-> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe`
[ ( (Text -> FieldNameHS
FieldNameHS Text
"parent", Text -> FieldNameDB
FieldNameDB Text
"parent")
, (Text -> FieldNameHS
FieldNameHS Text
"name", Text -> FieldNameDB
FieldNameDB Text
"name")
)
]