{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards, UndecidableInstances #-}

module TreeTest where

import Init


-- mpsGeneric = False is due to a bug or at least lack of a feature in
-- mkKeyTypeDec TH.hs
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, SafeToInsert record) =>
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, SafeToInsert record) =>
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, SafeToInsert record) =>
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")
                  )
                ]