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:
Fintan Halpenny 2017-07-17 21:37:15 +01:00
parent 743ab2a92b
commit 93e861cd1b
2 changed files with 45 additions and 11 deletions

View File

@ -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 "==============================================="

View File

@ -15,6 +15,7 @@ dependencies:
- persistent-template - persistent-template
- persistent-sqlite - persistent-sqlite
- text - text
- microlens
ghc-options: ghc-options:
- -Wall - -Wall
- -threaded - -threaded