module Main
( main
) where
----------------------------------------------------------------------------------------------------
import Control.Exception ( bracket )
import Data.Aeson ( FromJSON, ToJSON, eitherDecode, encode )
import Data.Default.Class ( Default (def) )
import Data.Either ( Either (..) )
import Data.Eq ( Eq, (/=), (==) )
import Data.Function ( ($), (&) )
import Data.Int ( Int32 )
import Data.List ( any, length, null )
import Data.Maybe ( Maybe (..) )
import Data.Ord ( Ord )
import Data.Semigroup ( (<>) )
import Data.String ( String )
import Data.Text ( Text )
import Data.UUID ( UUID )
import qualified Data.UUID
import Data.UUID.V4 ( nextRandom )
import GHC.Generics ( Generic )
import GHC.Show ( Show, show )
import qualified Hasql.Connection
import qualified Hasql.Decoders
import qualified Hasql.Encoders
import Hasql.Generate
( Config (..)
, HasEnum (..)
, HasPrimaryKey (..)
, fromTable
, fromType
, fromView
, generate
, withDerivations
, withholdPk
)
import qualified Hasql.Generate.Class as Q
import qualified Hasql.Session
import qualified Hasql.Statement
import Prelude
( Bool (..)
, IO
, error
, fmap
, not
, otherwise
, pure
, putStrLn
, seq
, (>>)
)
import System.Exit ( die, exitSuccess )
----------------------------------------------------------------------------------------------------
-- Enum type: generates sum type + PgCodec + PgColumn instances.
-- Must appear before any fromTable whose columns reference this enum.
$(generate (def {allowDuplicateRecordFields = True}) (fromType "hg_test" "user_role" & withDerivations [''Show, ''Eq, ''Ord]))
-- Table with enum column: exercises the PgColumn instance generated by fromType above.
$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "with_role" & withDerivations [''Show, ''Eq]))
-- Functional test table: CRUD + derived instances + global type override exercised at runtime
$( generate
(def {allowDuplicateRecordFields = True, globalOverrides = [("text", ''String)]})
( fromTable "hg_test" "users"
& withDerivations [''Show, ''Eq, ''Generic, ''ToJSON, ''FromJSON]
& withholdPk
)
)
-- Single UUID PK: generates data type, decoder, encoder, select, insert, update, delete
$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "with_pk"))
-- No PK: generates data type, decoder, encoder only
$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "no_pk"))
-- Composite PK: generates all CRUD with tuple PK type
$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "composite_pk"))
-- View: generates read-only data type, decoder, SELECT, and HasView instance
$(generate (def {allowDuplicateRecordFields = True}) (fromView "hg_test" "user_emails" & withDerivations [''Show, ''Eq]))
-- Newtype PK (single): generates newtype wrapper, PgCodec, HasPrimaryKey
$( generate
(def {allowDuplicateRecordFields = True, newtypePrimaryKeys = True})
(fromTable "hg_test" "nt_single" & withDerivations [''Show, ''Eq])
)
-- Newtype PK (composite): generates data record wrapper, encoder, HasPrimaryKey
$( generate
(def {allowDuplicateRecordFields = True, newtypePrimaryKeys = True})
(fromTable "hg_test" "nt_composite" & withDerivations [''Show, ''Eq])
)
-- Prefixed fields (default config): field names are prefixed with the type name
$(generate def (fromTable "hg_test" "prefix_demo"))
-- Reserved keyword columns: tests that field names colliding with Haskell keywords
-- get an apostrophe suffix (e.g. "type" -> "type'", "class" -> "class'", "data" -> "data'")
$(generate (def {allowDuplicateRecordFields = True}) (fromTable "hg_test" "keyword_cols" & withDerivations [''Show, ''Eq]))
----------------------------------------------------------------------------------------------------
main :: IO ()
main = do
testGeneratorsGenerate
testPrefixedFields
testKeywordSanitization
testUsersCrud
testUsersDerivation
testEnumUtilities
testEnumRoundTrip
testViewSelect
testNewtypePkCrud
testHasPrimaryKey
testBatchCrud
testBatchTypeclasses
exitSuccess
----------------------------------------------------------------------------------------------------
-- Compile-time generation test
----------------------------------------------------------------------------------------------------
{- If this module compiles, the TH splices produced valid, well-typed code.
We reference every generated binding to ensure nothing was silently omitted.
-}
testGeneratorsGenerate :: IO ()
testGeneratorsGenerate =
_urAdmin
.> _urModerator
.> _urMember
.> _wrDec
.> _wrEnc
.> _wrSel
.> _wrIns
.> _wrUpd
.> _wrDel
.> _wpDec
.> _wpEnc
.> _wpSel
.> _wpIns
.> _wpUpd
.> _wpDel
.> _npDec
.> _npEnc
.> _npIns
.> _cpDec
.> _cpEnc
.> _cpSel
.> _cpIns
.> _cpUpd
.> _cpDel
.> _ueDec
.> _ueSel
.> _nsSel
.> _nsDel
.> _nsIns
.> _ncSel
.> _ncDel
.> _ncIns
.> _urAll
.> _urToText
.> _urFromText
.> _pdDec
.> _pdEnc
.> _pdIns
.> _kwDec
.> _kwEnc
.> _kwIns
.> _smWp
.> _dmWp
.> _imWp
.> _umWp
.> _smCp
.> _dmCp
.> _imNp
.> _imU
.> _smNs
.> _smNc
.> _imCp
.> _umCp
.> _wrSmany
.> _wrDmany
.> _wrImany
.> _wrUmany
.> pure ()
>> putStrLn "Generator test passed ✔"
where
a .> b = a `seq` b
_urAdmin :: UserRole
_urAdmin = Admin
_urModerator :: UserRole
_urModerator = Moderator
_urMember :: UserRole
_urMember = Member
_wrDec :: Hasql.Decoders.Row WithRole
_wrDec = withRoleDecoder
_wrEnc :: Hasql.Encoders.Params WithRole
_wrEnc = withRoleEncoder
_wrSel :: Hasql.Statement.Statement UUID (Maybe WithRole)
_wrSel = selectWithRole
_wrIns :: Hasql.Statement.Statement WithRole WithRole
_wrIns = insertWithRole
_wrUpd :: Hasql.Statement.Statement WithRole (Maybe WithRole)
_wrUpd = updateWithRole
_wrDel :: Hasql.Statement.Statement UUID ()
_wrDel = deleteWithRole
_wpDec :: Hasql.Decoders.Row WithPk
_wpDec = withPkDecoder
_wpEnc :: Hasql.Encoders.Params WithPk
_wpEnc = withPkEncoder
_wpSel :: Hasql.Statement.Statement UUID (Maybe WithPk)
_wpSel = selectWithPk
_wpIns :: Hasql.Statement.Statement WithPk WithPk
_wpIns = insertWithPk
_wpUpd :: Hasql.Statement.Statement WithPk (Maybe WithPk)
_wpUpd = updateWithPk
_wpDel :: Hasql.Statement.Statement UUID ()
_wpDel = deleteWithPk
_npDec :: Hasql.Decoders.Row NoPk
_npDec = noPkDecoder
_npEnc :: Hasql.Encoders.Params NoPk
_npEnc = noPkEncoder
_npIns :: Hasql.Statement.Statement NoPk NoPk
_npIns = insertNoPk
_cpDec :: Hasql.Decoders.Row CompositePk
_cpDec = compositePkDecoder
_cpEnc :: Hasql.Encoders.Params CompositePk
_cpEnc = compositePkEncoder
_cpSel :: Hasql.Statement.Statement (UUID, Int32) (Maybe CompositePk)
_cpSel = selectCompositePk
_cpIns :: Hasql.Statement.Statement CompositePk CompositePk
_cpIns = insertCompositePk
_cpUpd :: Hasql.Statement.Statement CompositePk (Maybe CompositePk)
_cpUpd = updateCompositePk
_cpDel :: Hasql.Statement.Statement (UUID, Int32) ()
_cpDel = deleteCompositePk
_ueDec :: Hasql.Decoders.Row UserEmails
_ueDec = userEmailsDecoder
_ueSel :: Hasql.Statement.Statement () [UserEmails]
_ueSel = selectUserEmails
_urAll :: [UserRole]
_urAll = allValues
_urToText :: UserRole -> Text
_urToText = toText
_urFromText :: Text -> Maybe UserRole
_urFromText = fromText
-- Newtype PK (single) — PK param is NtSinglePk, not raw UUID
_nsSel :: Hasql.Statement.Statement NtSinglePk (Maybe NtSingle)
_nsSel = selectNtSingle
_nsDel :: Hasql.Statement.Statement NtSinglePk ()
_nsDel = deleteNtSingle
_nsIns :: Hasql.Statement.Statement NtSingle NtSingle
_nsIns = insertNtSingle
-- Newtype PK (composite) — PK param is NtCompositePk record, not raw tuple
_ncSel :: Hasql.Statement.Statement NtCompositePk (Maybe NtComposite)
_ncSel = selectNtComposite
_ncDel :: Hasql.Statement.Statement NtCompositePk ()
_ncDel = deleteNtComposite
_ncIns :: Hasql.Statement.Statement NtComposite NtComposite
_ncIns = insertNtComposite
_pdDec :: Hasql.Decoders.Row PrefixDemo
_pdDec = prefixDemoDecoder
_pdEnc :: Hasql.Encoders.Params PrefixDemo
_pdEnc = prefixDemoEncoder
_pdIns :: Hasql.Statement.Statement PrefixDemo PrefixDemo
_pdIns = insertPrefixDemo
_kwDec :: Hasql.Decoders.Row KeywordCols
_kwDec = keywordColsDecoder
_kwEnc :: Hasql.Encoders.Params KeywordCols
_kwEnc = keywordColsEncoder
_kwIns :: Hasql.Statement.Statement KeywordCols KeywordCols
_kwIns = insertKeywordCols
-- Batch with single PK
_smWp :: Hasql.Statement.Statement [UUID] [WithPk]
_smWp = selectManyWithPk
_dmWp :: Hasql.Statement.Statement [UUID] ()
_dmWp = deleteManyWithPk
_imWp :: Hasql.Statement.Statement [WithPk] [WithPk]
_imWp = insertManyWithPk
_umWp :: Hasql.Statement.Statement [WithPk] [WithPk]
_umWp = updateManyWithPk
-- Batch with composite PK
_smCp :: Hasql.Statement.Statement [(UUID, Int32)] [CompositePk]
_smCp = selectManyCompositePk
_dmCp :: Hasql.Statement.Statement [(UUID, Int32)] ()
_dmCp = deleteManyCompositePk
_imCp :: Hasql.Statement.Statement [CompositePk] [CompositePk]
_imCp = insertManyCompositePk
_umCp :: Hasql.Statement.Statement [CompositePk] [CompositePk]
_umCp = updateManyCompositePk
-- Batch insert (always generated, even no-PK tables)
_imNp :: Hasql.Statement.Statement [NoPk] [NoPk]
_imNp = insertManyNoPk
-- Batch with defaulted PK (insert excludes PK columns)
_imU :: Hasql.Statement.Statement [Users] [Users]
_imU = insertManyUsers
-- Batch with newtype PKs
_smNs :: Hasql.Statement.Statement [NtSinglePk] [NtSingle]
_smNs = selectManyNtSingle
_smNc :: Hasql.Statement.Statement [NtCompositePk] [NtComposite]
_smNc = selectManyNtComposite
-- Batch with enum column
_wrSmany :: Hasql.Statement.Statement [UUID] [WithRole]
_wrSmany = selectManyWithRole
_wrDmany :: Hasql.Statement.Statement [UUID] ()
_wrDmany = deleteManyWithRole
_wrImany :: Hasql.Statement.Statement [WithRole] [WithRole]
_wrImany = insertManyWithRole
_wrUmany :: Hasql.Statement.Statement [WithRole] [WithRole]
_wrUmany = updateManyWithRole
----------------------------------------------------------------------------------------------------
-- Prefixed field name test
----------------------------------------------------------------------------------------------------
testPrefixedFields :: IO ()
testPrefixedFields = do
let pd = PrefixDemo {prefixDemoVal = 42}
assertEqual "prefixed field named \"val\"" 42 (prefixDemoVal pd)
putStrLn "Prefixed fields test passed ✔"
----------------------------------------------------------------------------------------------------
-- Keyword sanitization test
----------------------------------------------------------------------------------------------------
{- Verify that PostgreSQL columns named after Haskell reserved keywords get
an apostrophe suffix in the generated record fields. If this function
compiles and the field names are accessible, the sanitization works.
-}
testKeywordSanitization :: IO ()
testKeywordSanitization = withTestConnection $ \conn -> do
let kw =
KeywordCols
{ id = Data.UUID.nil
, type' = "something" :: Text
, class' = Just ("someclass" :: Text)
, data' = 42 :: Int32
}
-- Insert via typeclass — exercises encoder with sanitized field names
inserted <- runSession conn (Q.insert kw)
assertEqual "keyword sanitization > type'" kw.type' inserted.type'
assertEqual "keyword sanitization > class'" kw.class' inserted.class'
assertEqual "keyword sanitization > data'" kw.data' inserted.data'
-- Clean up
runSession conn (Q.delete @KeywordCols inserted.id)
putStrLn "Keyword sanitization test passed ✔"
----------------------------------------------------------------------------------------------------
-- CRUD functional test
----------------------------------------------------------------------------------------------------
testUsersCrud :: IO ()
testUsersCrud = withTestConnection $ \conn -> do
let testUuid = Data.UUID.nil
let user =
Users
{ id = testUuid
, name = "Alice"
, email = Just "alice@example.com"
}
-- Insert via typeclass
inserted <- runSession conn (Q.insert user)
assertNotEqual "insert roundtrip > id" user.id inserted.id
assertEqual "insert roundtrip > name" user.name inserted.name
assertEqual "insert roundtrip > email" user.email inserted.email
-- Select by PK via typeclass
found <- runSession conn (Q.select @Users inserted.id)
assertEqual "select by PK" (Just inserted) found
assertEqual "select by PK > id" (Just inserted.id) (fmap (.id) found)
-- Update via typeclass
let updatedUser =
Users
{ id = inserted.id
, name = "Bob"
, email = Just "bob@example.com"
}
updated <- runSession conn (Q.update updatedUser)
assertEqual "update roundtrip" (Just updatedUser) updated
-- Verify update persisted
found2 <- runSession conn (Q.select @Users inserted.id)
assertEqual "select after update" (Just updatedUser) found2
-- Delete via typeclass
runSession conn (Q.delete @Users inserted.id)
-- Verify deletion
gone <- runSession conn (Q.select @Users inserted.id)
assertEqual "select after delete" (Nothing :: Maybe Users) gone
putStrLn "CRUD test passed ✔"
----------------------------------------------------------------------------------------------------
-- Derivation tests
----------------------------------------------------------------------------------------------------
testUsersDerivation :: IO ()
testUsersDerivation = do
testUuid <- nextRandom
let user =
Users
{ id = testUuid
, name = "Alice"
, email = Just "alice@example.com"
}
encoded = encode user
case eitherDecode encoded of
Left err -> error ("JSON roundtrip failed: " <> err)
Right decoded -> assertEqual "JSON roundtrip" user decoded
-- Also test with a Nothing field
let userNoEmail =
Users
{ id = testUuid
, name = "Bob"
, email = Nothing
}
encodedNoEmail = encode userNoEmail
case eitherDecode encodedNoEmail of
Left err -> error ("JSON roundtrip (null email) failed: " <> err)
Right decoded -> assertEqual "JSON roundtrip (null email)" userNoEmail decoded
assertEqual
"show derivation"
("Users {id = " <> show testUuid <> ", name = \"Alice\", email = Just \"alice@example.com\"}")
(show user)
putStrLn "Derivation test passed ✔"
----------------------------------------------------------------------------------------------------
-- HasEnum utility test
----------------------------------------------------------------------------------------------------
testEnumUtilities :: IO ()
testEnumUtilities = do
assertEqual "allValues length" 3 (length (allValues :: [UserRole]))
assertEqual "allValues order" [Admin, Moderator, Member] (allValues :: [UserRole])
assertEqual "toText Admin" "admin" (toText Admin)
assertEqual "toText Moderator" "moderator" (toText Moderator)
assertEqual "toText Member" "member" (toText Member)
assertEqual "fromText admin" (Just Admin) (fromText "admin")
assertEqual "fromText moderator" (Just Moderator) (fromText "moderator")
assertEqual "fromText member" (Just Member) (fromText "member")
assertEqual "fromText bogus" (Nothing :: Maybe UserRole) (fromText "bogus")
putStrLn "Enum utilities test passed ✔"
----------------------------------------------------------------------------------------------------
-- Enum round-trip test
----------------------------------------------------------------------------------------------------
testEnumRoundTrip :: IO ()
testEnumRoundTrip = withTestConnection $ \conn -> do
let wr =
WithRole
{ id = Data.UUID.nil
, name = "EnumUser"
, role' = Admin
}
-- Insert via typeclass
inserted <- runSession conn (Q.insert wr)
assertEqual "enum roundtrip > role'" Admin inserted.role'
assertEqual "enum roundtrip > name" "EnumUser" inserted.name
-- Select by PK via typeclass
found <- runSession conn (Q.select @WithRole inserted.id)
assertEqual "enum select" (Just inserted) found
-- Update to a different role
let updated = inserted {role' = Member}
result <- runSession conn (Q.update updated)
assertEqual "enum update > role'" (Just Member) (fmap (.role') result)
-- Clean up
runSession conn (Q.delete @WithRole inserted.id)
-- Verify deletion
gone <- runSession conn (Q.select @WithRole inserted.id)
assertEqual "enum delete" (Nothing :: Maybe WithRole) gone
putStrLn "Enum roundtrip test passed ✔"
----------------------------------------------------------------------------------------------------
-- View functional test
----------------------------------------------------------------------------------------------------
testViewSelect :: IO ()
testViewSelect = withTestConnection $ \conn -> do
-- Insert a user with email (appears in user_emails view)
let user =
Users
{ id = Data.UUID.nil
, name = "ViewUser"
, email = Just "view@example.com"
}
inserted <- runSession conn (Q.insert user)
-- Select all from the view via typeclass
rows <- runSession conn (Q.selectView @UserEmails)
assertTrue "view returns rows" (not (null rows))
assertTrue "view contains inserted user" (any (\ue -> ue.id == Just inserted.id) rows)
-- Clean up
runSession conn (Q.delete @Users inserted.id)
putStrLn "View test passed ✔"
----------------------------------------------------------------------------------------------------
-- Newtype PK CRUD test
----------------------------------------------------------------------------------------------------
testNewtypePkCrud :: IO ()
testNewtypePkCrud = withTestConnection $ \conn -> do
testUuid <- nextRandom
let user =
NtSingle
{ id = NtSinglePk testUuid
, name = "NtAlice"
, email = Just "nt@example.com"
}
-- Insert
inserted <- runSession conn (Hasql.Session.statement user insertNtSingle)
assertEqual "nt insert > name" "NtAlice" inserted.name
assertEqual "nt insert > email" (Just "nt@example.com") inserted.email
-- Select by newtype PK
found <- runSession conn (Hasql.Session.statement inserted.id selectNtSingle)
assertEqual "nt select by PK" (Just inserted) found
-- Update
let updatedUser =
NtSingle
{ id = inserted.id
, name = "NtBob"
, email = Just "ntbob@example.com"
}
updated <- runSession conn (Hasql.Session.statement updatedUser updateNtSingle)
assertEqual "nt update" (Just updatedUser) updated
-- Delete by newtype PK
runSession conn (Hasql.Session.statement inserted.id deleteNtSingle)
gone <- runSession conn (Hasql.Session.statement inserted.id selectNtSingle)
assertEqual "nt delete" (Nothing :: Maybe NtSingle) gone
putStrLn "Newtype PK CRUD test passed ✔"
----------------------------------------------------------------------------------------------------
-- HasPrimaryKey test
----------------------------------------------------------------------------------------------------
testHasPrimaryKey :: IO ()
testHasPrimaryKey = do
testUuid <- nextRandom
-- Test HasPrimaryKey on existing table with raw UUID PK (no newtypes)
let wp = WithPk {pkid = testUuid, name = "Test", email = Nothing, age = Nothing}
assertEqual "withPk toPk" testUuid (toPk wp)
assertEqual "withPk wrapPk" testUuid (wrapPk @WithPk testUuid)
assertEqual "withPk unwrapPk" testUuid (unwrapPk @WithPk testUuid)
assertEqual "withPk rawPk" testUuid (rawPk wp)
-- Test HasPrimaryKey on newtype single PK table
let ns = NtSingle {id = NtSinglePk testUuid, name = "NtTest", email = Nothing}
assertEqual "ntSingle toPk" (NtSinglePk testUuid) (toPk ns)
assertEqual "ntSingle wrapPk" (NtSinglePk testUuid) (wrapPk @NtSingle testUuid)
assertEqual "ntSingle unwrapPk" testUuid (unwrapPk @NtSingle (NtSinglePk testUuid))
assertEqual "ntSingle rawPk" testUuid (rawPk ns)
-- Test wrapPk / unwrapPk roundtrip
let pk = NtSinglePk testUuid
assertEqual "ntSingle wrap/unwrap roundtrip" pk (wrapPk @NtSingle (unwrapPk @NtSingle pk))
-- Test HasPrimaryKey on composite PK table (no newtypes)
let cp = CompositePk {tenantId = testUuid, itemId = 42, payload = "test"}
assertEqual "compositePk toPk" (testUuid, 42) (toPk cp)
assertEqual "compositePk rawPk" (testUuid, 42) (rawPk cp)
-- Test HasPrimaryKey on newtype composite PK table
let nc = NtComposite {tenantId = testUuid, itemId = 99, payload = "nctest"}
ncPk = NtCompositePk {tenantId = testUuid, itemId = 99}
assertEqual "ntComposite toPk" ncPk (toPk nc)
assertEqual "ntComposite wrapPk" ncPk (wrapPk @NtComposite (testUuid, 99))
assertEqual "ntComposite unwrapPk" (testUuid, 99) (unwrapPk @NtComposite ncPk)
assertEqual "ntComposite rawPk" (testUuid, 99) (rawPk nc)
putStrLn "HasPrimaryKey test passed ✔"
----------------------------------------------------------------------------------------------------
-- Batch CRUD functional test
----------------------------------------------------------------------------------------------------
testBatchCrud :: IO ()
testBatchCrud = withTestConnection $ \conn -> do
uuid1 <- nextRandom
uuid2 <- nextRandom
uuid3 <- nextRandom
let rec1 = WithPk {pkid = uuid1, name = "Batch1", email = Just "b1@test.com", age = Just 10}
rec2 = WithPk {pkid = uuid2, name = "Batch2", email = Nothing, age = Just 20}
rec3 = WithPk {pkid = uuid3, name = "Batch3", email = Just "b3@test.com", age = Nothing}
-- insertMany
inserted <- runSession conn (Hasql.Session.statement [rec1, rec2, rec3] insertManyWithPk)
assertEqual "insertMany count" 3 (length inserted)
-- selectMany all 3
found <- runSession conn (Hasql.Session.statement [uuid1, uuid2, uuid3] selectManyWithPk)
assertEqual "selectMany count" 3 (length found)
assertTrue "selectMany contains uuid1" (any (\r -> r.pkid == uuid1) found)
assertTrue "selectMany contains uuid2" (any (\r -> r.pkid == uuid2) found)
assertTrue "selectMany contains uuid3" (any (\r -> r.pkid == uuid3) found)
-- updateMany (use full construction to avoid ambiguous record update)
let upd1 = WithPk {pkid = uuid1, name = "Updated1", email = rec1.email, age = rec1.age}
upd2 = WithPk {pkid = uuid2, name = "Updated2", email = rec2.email, age = rec2.age}
upd3 = WithPk {pkid = uuid3, name = "Updated3", email = rec3.email, age = rec3.age}
updated <- runSession conn (Hasql.Session.statement [upd1, upd2, upd3] updateManyWithPk)
assertEqual "updateMany count" 3 (length updated)
assertTrue "updateMany name1" (any (\(r :: WithPk) -> r.name == "Updated1") updated)
assertTrue "updateMany name2" (any (\(r :: WithPk) -> r.name == "Updated2") updated)
assertTrue "updateMany name3" (any (\(r :: WithPk) -> r.name == "Updated3") updated)
-- deleteMany first 2
runSession conn (Hasql.Session.statement [uuid1, uuid2] deleteManyWithPk)
-- selectMany all 3 — only the third should remain
remaining <- runSession conn (Hasql.Session.statement [uuid1, uuid2, uuid3] selectManyWithPk)
assertEqual "after deleteMany count" 1 (length remaining)
assertTrue "after deleteMany only uuid3 remains" (any (\r -> r.pkid == uuid3) remaining)
-- Clean up
runSession conn (Hasql.Session.statement [uuid3] deleteManyWithPk)
putStrLn "Batch CRUD test passed ✔"
----------------------------------------------------------------------------------------------------
-- Batch typeclass test
----------------------------------------------------------------------------------------------------
testBatchTypeclasses :: IO ()
testBatchTypeclasses = withTestConnection $ \conn -> do
uuid1 <- nextRandom
uuid2 <- nextRandom
let rec1 = WithPk {pkid = uuid1, name = "TC1", email = Just "tc1@test.com", age = Just 30}
rec2 = WithPk {pkid = uuid2, name = "TC2", email = Nothing, age = Nothing}
-- insertMany via typeclass
inserted <- runSession conn (Q.insertMany [rec1, rec2])
assertEqual "typeclass insertMany count" 2 (length inserted)
-- selectMany via typeclass
found <- runSession conn (Q.selectMany @WithPk [uuid1, uuid2])
assertEqual "typeclass selectMany count" 2 (length found)
-- updateMany via typeclass (use full construction to avoid ambiguous record update)
let upd1 = WithPk {pkid = uuid1, name = "TC1-updated", email = rec1.email, age = rec1.age}
upd2 = WithPk {pkid = uuid2, name = "TC2-updated", email = rec2.email, age = rec2.age}
updated <- runSession conn (Q.updateMany [upd1, upd2])
assertEqual "typeclass updateMany count" 2 (length updated)
assertTrue "typeclass updateMany name" (any (\(r :: WithPk) -> r.name == "TC1-updated") updated)
-- deleteMany via typeclass
runSession conn (Q.deleteMany @WithPk [uuid1, uuid2])
-- Verify deletion
gone <- runSession conn (Q.selectMany @WithPk [uuid1, uuid2])
assertEqual "typeclass deleteMany" 0 (length gone)
putStrLn "Batch typeclass test passed ✔"
----------------------------------------------------------------------------------------------------
-- Test helpers
----------------------------------------------------------------------------------------------------
withTestConnection :: (Hasql.Connection.Connection -> IO a) -> IO a
withTestConnection =
bracket acquire Hasql.Connection.release
where
acquire :: IO Hasql.Connection.Connection
acquire = do
result <- Hasql.Connection.acquire ""
case result of
Left err -> error ("Failed to connect: " <> show err)
Right conn -> pure conn
runSession :: Hasql.Connection.Connection -> Hasql.Session.Session a -> IO a
runSession conn session = do
result <- Hasql.Session.run session conn
case result of
Left err -> error ("Session failed: " <> show err)
Right a -> pure a
assertEqual :: (Eq a, Show a) => String -> a -> a -> IO ()
assertEqual label expected actual
| expected == actual = pure ()
| otherwise =
die $ "Assertion failed (" <> label <> "): expected " <> show expected <> " but got " <> show actual
assertTrue :: String -> Bool -> IO ()
assertTrue label condition
| condition = pure ()
| otherwise = die ("Assertion failed (" <> label <> "): expected True but got False")
assertNotEqual :: (Eq a, Show a) => String -> a -> a -> IO ()
assertNotEqual label unexpected actual
| unexpected /= actual = pure ()
| otherwise =
die $ "Assertion failed (" <> label <> "): expected NOT " <> show unexpected <> " but got " <> show actual