Trying to figure out why deleteYoungsters is throwing an ErrorConstraint. Been trying Cascade Deletes but it doesn't seem to help
This commit is contained in:
parent
743ab2a92b
commit
93e861cd1b
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
@ -6,16 +7,24 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
module Main
|
||||||
|
( main
|
||||||
|
) where
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
import Control.Monad (void)
|
import Control.Monad (void)
|
||||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Database.Esqueleto
|
import Database.Esqueleto
|
||||||
import Database.Persist.Sqlite (runMigration, runSqlite)
|
import Database.Persist.Sqlite (fkEnabled, mkSqliteConnectionInfo,
|
||||||
import Database.Persist.TH (mkMigrate, mkPersist,
|
runMigration, runSqliteInfo)
|
||||||
|
import Database.Persist.TH (mkDeleteCascade, mkMigrate, mkPersist,
|
||||||
persistLowerCase, share, sqlSettings)
|
persistLowerCase, share, sqlSettings)
|
||||||
|
import Lens.Micro ((&), (.~))
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
|
|
||||||
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
|
||||||
|
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
||||||
Person
|
Person
|
||||||
name String
|
name String
|
||||||
age Int Maybe
|
age Int Maybe
|
||||||
@ -30,14 +39,18 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
|||||||
deriving Eq Show
|
deriving Eq Show
|
||||||
|]
|
|]
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
putPersons :: (MonadIO m)
|
putPersons :: (MonadIO m)
|
||||||
=> SqlPersistT m ()
|
=> SqlPersistT m ()
|
||||||
putPersons = do
|
putPersons = do
|
||||||
people <- select $
|
people <- select $
|
||||||
from $ \person -> do
|
from $ \person -> do
|
||||||
return person
|
return person
|
||||||
liftIO $ mapM_ (putStrLn . personName . entityVal) people
|
liftIO $ mapM_ (putStrLn . ("Name: " ++) . personName . entityVal) people
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
getJohns :: (MonadIO m)
|
getJohns :: (MonadIO m)
|
||||||
=> SqlReadT m [Entity Person]
|
=> SqlReadT m [Entity Person]
|
||||||
getJohns =
|
getJohns =
|
||||||
@ -46,6 +59,8 @@ getJohns =
|
|||||||
where_ (p ^. PersonName ==. val "John")
|
where_ (p ^. PersonName ==. val "John")
|
||||||
return p
|
return p
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
getJaoas :: (MonadIO m)
|
getJaoas :: (MonadIO m)
|
||||||
=> SqlReadT m [Entity Person]
|
=> SqlReadT m [Entity Person]
|
||||||
getJaoas =
|
getJaoas =
|
||||||
@ -54,6 +69,8 @@ getJaoas =
|
|||||||
where_ (p ^. PersonName ==. val "João" ||. p ^. PersonName ==. val "Joao")
|
where_ (p ^. PersonName ==. val "João" ||. p ^. PersonName ==. val "Joao")
|
||||||
return p
|
return p
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
getAdults :: (MonadIO m)
|
getAdults :: (MonadIO m)
|
||||||
=> SqlReadT m [Entity Person]
|
=> SqlReadT m [Entity Person]
|
||||||
getAdults =
|
getAdults =
|
||||||
@ -62,6 +79,8 @@ getAdults =
|
|||||||
where_ (p ^. PersonAge >=. just (val 18))
|
where_ (p ^. PersonAge >=. just (val 18))
|
||||||
return p
|
return p
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
getBlogPostsByAuthors :: (MonadIO m)
|
getBlogPostsByAuthors :: (MonadIO m)
|
||||||
=> SqlReadT m [(Entity BlogPost, Entity Person)]
|
=> SqlReadT m [(Entity BlogPost, Entity Person)]
|
||||||
getBlogPostsByAuthors =
|
getBlogPostsByAuthors =
|
||||||
@ -71,6 +90,8 @@ getBlogPostsByAuthors =
|
|||||||
orderBy [asc (b ^. BlogPostTitle)]
|
orderBy [asc (b ^. BlogPostTitle)]
|
||||||
return (b, p)
|
return (b, p)
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
getAuthorMaybePosts :: (MonadIO m)
|
getAuthorMaybePosts :: (MonadIO m)
|
||||||
=> SqlReadT m [(Entity Person, Maybe (Entity BlogPost))]
|
=> SqlReadT m [(Entity Person, Maybe (Entity BlogPost))]
|
||||||
getAuthorMaybePosts =
|
getAuthorMaybePosts =
|
||||||
@ -80,6 +101,8 @@ getAuthorMaybePosts =
|
|||||||
orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)]
|
orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)]
|
||||||
return (p, mb)
|
return (p, mb)
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
followers :: (MonadIO m)
|
followers :: (MonadIO m)
|
||||||
=> SqlReadT m [(Entity Person, Entity Follow, Entity Person)]
|
=> SqlReadT m [(Entity Person, Entity Follow, Entity Person)]
|
||||||
followers =
|
followers =
|
||||||
@ -89,6 +112,8 @@ followers =
|
|||||||
on (p1 ^. PersonId ==. f ^. FollowFollower)
|
on (p1 ^. PersonId ==. f ^. FollowFollower)
|
||||||
return (p1, f, p2)
|
return (p1, f, p2)
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
updateJoao :: (MonadIO m)
|
updateJoao :: (MonadIO m)
|
||||||
=> SqlWriteT m ()
|
=> SqlWriteT m ()
|
||||||
updateJoao =
|
updateJoao =
|
||||||
@ -96,19 +121,25 @@ updateJoao =
|
|||||||
set p [ PersonName =. val "João" ]
|
set p [ PersonName =. val "João" ]
|
||||||
where_ (p ^. PersonName ==. val "Joao")
|
where_ (p ^. PersonName ==. val "Joao")
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
deleteYoungsters :: (MonadIO m)
|
deleteYoungsters :: (MonadIO m)
|
||||||
=> SqlWriteT m ()
|
=> SqlWriteT m ()
|
||||||
deleteYoungsters =
|
deleteYoungsters = do
|
||||||
delete $
|
delete $
|
||||||
from $ \p -> do
|
from $ \p -> do
|
||||||
where_ (p ^. PersonAge <. just (val 14))
|
where_ (p ^. PersonAge <. just (val 14))
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
insertBlogPosts :: (MonadIO m)
|
insertBlogPosts :: (MonadIO m)
|
||||||
=> SqlWriteT m ()
|
=> SqlWriteT m ()
|
||||||
insertBlogPosts =
|
insertBlogPosts =
|
||||||
insertSelect $ from $ \p ->
|
insertSelect $ from $ \p ->
|
||||||
return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId)
|
return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId)
|
||||||
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
testDb :: (MonadIO m)
|
testDb :: (MonadIO m)
|
||||||
=> SqlWriteT m ()
|
=> SqlWriteT m ()
|
||||||
testDb = do
|
testDb = do
|
||||||
@ -122,18 +153,20 @@ testDb = do
|
|||||||
void $ insert $ Follow sean john
|
void $ insert $ Follow sean john
|
||||||
void $ insert $ Follow joao sean
|
void $ insert $ Follow joao sean
|
||||||
|
|
||||||
arith :: Num b => (a -> b) -> Integer -> a -> b
|
|
||||||
arith f i a = (f a) + fromInteger i
|
|
||||||
|
|
||||||
|
-------------------------------------------------------------------------------
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = runSqlite ":memory:" $ do
|
main =
|
||||||
|
let conn = (mkSqliteConnectionInfo ":memory:") & fkEnabled .~ True
|
||||||
|
in runSqliteInfo conn $ do
|
||||||
|
-- Run migrations to synchronise the databse
|
||||||
runMigration migrateAll
|
runMigration migrateAll
|
||||||
|
|
||||||
|
-- Initialise our test database
|
||||||
testDb
|
testDb
|
||||||
|
|
||||||
printMessage "Listing all names of the people in the database"
|
-- Print the names of our Persons
|
||||||
printMessage "==============================================="
|
|
||||||
putPersons
|
putPersons
|
||||||
printMessage "==============================================="
|
|
||||||
|
|
||||||
printMessage "Listing all the people with the name John:"
|
printMessage "Listing all the people with the name John:"
|
||||||
printMessage "==============================================="
|
printMessage "==============================================="
|
||||||
|
|||||||
@ -15,6 +15,7 @@ dependencies:
|
|||||||
- persistent-template
|
- persistent-template
|
||||||
- persistent-sqlite
|
- persistent-sqlite
|
||||||
- text
|
- text
|
||||||
|
- microlens
|
||||||
ghc-options:
|
ghc-options:
|
||||||
- -Wall
|
- -Wall
|
||||||
- -threaded
|
- -threaded
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user