2026-10-05 22:22:23 +08:00
module RuntimeSpec ( spec ) where
2026-10-16 23:46:04 +08:00
import ChuSQL.Core.Engine ( bindWrite , executeWriteM , rowsOf , runStatement , runStatementM )
2026-10-11 17:32:12 +08:00
import ChuSQL.Core.Engine.Algebra.Eval ( evalRelOp )
2026-10-16 23:46:04 +08:00
import ChuSQL.Core.Engine.Algebra.Expr ( evalExpr , subquerySlotsIn )
import qualified ChuSQL.Core.Engine.Algebra.Op as Rel
2026-10-11 17:32:12 +08:00
import ChuSQL.Core.Engine.Algebra.Sort ( sortBoundRows )
2026-10-16 23:46:04 +08:00
import ChuSQL.Core.Engine.Runtime.Binding
import ChuSQL.Core.Engine.Runtime.Functions
2026-10-05 22:22:23 +08:00
import qualified ChuSQL.Core.Engine.Runtime.Query as Query
2026-10-16 23:46:04 +08:00
import ChuSQL.Core.Engine.Runtime.Relation ( bindRelOpColumns , bindWriteColumns )
import ChuSQL.Core.Engine.Runtime.Types
2026-10-11 17:32:12 +08:00
import ChuSQL.Core.Engine.Semantic ( prepare , prepareRowExpression )
2026-10-16 23:46:04 +08:00
import ChuSQL.Core.Engine.Storage.Memory ( runMemoryStorage )
import ChuSQL.Core.Engine.Syntax.AST ( Expr ( .. ), FromClause ( .. ), SortDir ( .. ), Statement ( .. ), Subquery ( .. ))
2026-10-05 22:22:23 +08:00
import ChuSQL.Core.Engine.Syntax.Parser ( parseStatement )
import qualified ChuSQL.Core.Model as SQL
2026-10-16 23:46:04 +08:00
import ChuSQL.Core.Protocol ( TableInfo ( .. ), valueFromJSON , valueToJSON )
import Control.Monad ( foldM , when )
2026-10-11 17:32:12 +08:00
import qualified Data.Aeson as A
2026-10-05 22:22:23 +08:00
import Data.Aeson.Types ( parseEither )
2026-10-15 22:21:41 +08:00
import Data.Bifunctor ( second )
2026-10-16 23:46:04 +08:00
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Hashable ( hash )
import Data.List ( isInfixOf )
import Data.Word ( Word64 )
2026-10-05 22:22:23 +08:00
import Test.Hspec
-- 运行时类型、函数绑定、物理编码和类型化查询测试。
2026-10-11 17:32:12 +08:00
-- | 执行语句建立测试目录
sqlCatalog :: [ String ] -> Either String SQL . Database
sqlCatalog = foldM apply []
where
2026-10-16 23:46:04 +08:00
-- \| 更新当前测试数据库
2026-10-11 17:32:12 +08:00
apply db source = do
statement <- parseStatement source
fst <$> runStatement db statement
2026-10-16 23:46:04 +08:00
-- | 为复合值运算建立同一套有重复和空值的数据
capabilityDatabase :: Either String SQL . Database
capabilityDatabase =
sqlCatalog
[ "CREATE DOMAIN int_list AS [Int]"
, "CREATE TABLE compound (id INT, xs int_list, opt Maybe Int, pair (Int, String), ds [Double])"
, "INSERT INTO compound (id, xs, opt, pair, ds) VALUES (1, LIST<Int>(10), MAYBE<Int>(2), TUPLE<Int,String>(2,'a'), LIST<Double>(-0.0))"
, "INSERT INTO compound (id, xs, opt, pair, ds) VALUES (2, LIST<Int>(2,9), MAYBE<Int>(), TUPLE<Int,String>(2,'b'), LIST<Double>(0.0))"
, "INSERT INTO compound (id, xs, opt, pair, ds) VALUES (3, LIST<Int>(2), MAYBE<Int>(10), TUPLE<Int,String>(10,'a'), LIST<Double>(1.5))"
, "INSERT INTO compound (id, xs, opt, pair, ds) VALUES (4, LIST<Int>(2), MAYBE<Int>(), TUPLE<Int,String>(2,'b'), LIST<Double>(0.0))"
, "INSERT INTO compound (id) VALUES (5)"
]
-- | 用正式查询入口验证复合值的所有消费者
capabilityQuery :: String -> Either String [[ SQL . Value ]]
capabilityQuery source = do
db <- capabilityDatabase
statement <- parseStatement source
map ( map snd ) <$> rowsOf ( runStatement db statement )
2026-10-05 22:22:23 +08:00
-- | 检查运行时类型基础契约
spec :: Spec
spec = do
2026-10-15 22:21:41 +08:00
describe "bound write plans" $ do
it "reuses INSERT targets and constraints while refreshing the auto counter" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE DOMAIN cached_quantity AS INT"
, "CREATE TABLE cached_insert (id INT AUTO_INCREMENT PRIMARY KEY, qty cached_quantity DEFAULT 2, tag TEXT CHECK (length(tag) > 1))"
]
2026-10-15 22:21:41 +08:00
statement <- parseStatement "INSERT INTO cached_insert (tag) VALUES ('abc')"
bound <- bindWrite db statement
( first , inserted ) <- runMemoryStorage ( executeWriteM bound ) db
first
2026-10-16 23:46:04 +08:00
let reversed = [( name , table { SQL . tableRows = map reverse ( SQL . tableRows table )}) | ( name , table ) <- inserted ]
2026-10-15 22:21:41 +08:00
( secondResult , final ) <- runMemoryStorage ( executeWriteM bound ) reversed
secondResult
select <- parseStatement "SELECT id, qty, tag FROM cached_insert"
map ( map snd ) <$> rowsOf ( runStatement final select )
result ` shouldBe ` Right [[ SQL . VInt 1 , SQL . VInt 2 , SQL . VStr "abc" ], [ SQL . VInt 2 , SQL . VInt 2 , SQL . VStr "abc" ]]
it "reuses ordered UPDATE targets and final-row uniqueness checks" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE cached_update (id INT PRIMARY KEY, qty INT NOT NULL UNIQUE CHECK (qty < 10))"
, "INSERT INTO cached_update (id, qty) VALUES (1, 1), (2, 8)"
]
2026-10-15 22:21:41 +08:00
statement <- parseStatement "UPDATE cached_update SET qty = qty + 1, qty = qty + id WHERE id = 1"
bound <- bindWrite db statement
duplicate <- parseStatement "UPDATE cached_update SET qty = 8 WHERE id = 1" >>= bindWrite db
( first , updated ) <- runMemoryStorage ( executeWriteM bound ) db
first
( secondResult , twice ) <- runMemoryStorage ( executeWriteM bound ) updated
secondResult
( rejected , unchanged ) <- runMemoryStorage ( executeWriteM duplicate ) twice
2026-10-16 23:46:04 +08:00
Right
( SQL . tableRows <$> lookup "cached_update" twice
, rejected
, SQL . tableRows <$> lookup "cached_update" unchanged
)
2026-10-15 22:21:41 +08:00
rows = Just [[( "id" , SQL . VInt 1 ), ( "qty" , SQL . VInt 5 )], [( "id" , SQL . VInt 2 ), ( "qty" , SQL . VInt 8 )]]
result ` shouldBe ` Right ( rows , Left "UNIQUE: duplicate value in column qty" , rows )
it "defers assignment errors until a reused plan matches a current row" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE deferred_write (id INT, qty INT CHECK (qty > 0))" ]
statement <- parseStatement "UPDATE deferred_write SET qty = 1 / 0 WHERE id = 9"
bound <- bindWrite db statement
( empty , initial ) <- runMemoryStorage ( executeWriteM bound ) db
empty
inserted <- parseStatement "INSERT INTO deferred_write (id, qty) VALUES (9, 5)" >>= runStatement initial
( rejected , final ) <- runMemoryStorage ( executeWriteM bound ) ( fst inserted )
Right ( rejected , SQL . tableRows <$> lookup "deferred_write" final )
result ` shouldBe ` Right ( Left "division by zero" , Just [[( "id" , SQL . VInt 9 ), ( "qty" , SQL . VInt 5 )]])
it "rejects stale INSERT UPDATE and DELETE plans before changing rows" $ do
2026-10-16 23:46:04 +08:00
mapM_
( \ source -> do
let result = do
db <- sqlCatalog [ "CREATE TABLE saved_write (id INT, qty INT)" , "INSERT INTO saved_write (id, qty) VALUES (1, 5)" ]
statement <- parseStatement source
bound <- bindWrite db statement
added <- parseStatement "ALTER TABLE saved_write ADD COLUMN extra TEXT" >>= runStatement db
restored <- parseStatement "ALTER TABLE saved_write DROP COLUMN extra" >>= runStatement ( fst added )
( rejected , final ) <- runMemoryStorage ( executeWriteM bound ) ( fst restored )
Right ( rejected , SQL . tableRows <$> lookup "saved_write" final )
result ` shouldBe ` Right ( Left "bound query schema changed: saved_write" , Just [[( "id" , SQL . VInt 1 ), ( "qty" , SQL . VInt 5 )]])
)
2026-10-15 22:21:41 +08:00
[ "INSERT INTO saved_write (id, qty) VALUES (2, 8)"
, "UPDATE saved_write SET qty = qty + 1"
, "DELETE FROM saved_write WHERE id = 1"
]
it "reuses a write plan across data and unrelated schema changes" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE reusable_write (id INT, qty INT)" , "CREATE TABLE unrelated_write (id INT)" , "INSERT INTO reusable_write (id, qty) VALUES (1, 5)" ]
statement <- parseStatement "UPDATE reusable_write SET qty = qty + 1 WHERE id = 1"
bound <- bindWrite db statement
changed <- parseStatement "INSERT INTO reusable_write (id, qty) VALUES (2, 9)" >>= runStatement db
unrelated <- parseStatement "ALTER TABLE unrelated_write ADD COLUMN extra TEXT" >>= runStatement ( fst changed )
( first , updated ) <- runMemoryStorage ( executeWriteM bound ) ( fst unrelated )
first
( secondResult , final ) <- runMemoryStorage ( executeWriteM bound ) updated
secondResult
Right ( SQL . tableRows <$> lookup "reusable_write" final )
result ` shouldBe ` Right ( Just [[( "id" , SQL . VInt 1 ), ( "qty" , SQL . VInt 7 )], [( "id" , SQL . VInt 2 ), ( "qty" , SQL . VInt 9 )]])
it "rejects replaced targets and changed subquery or DOMAIN dependencies" $ do
let result = do
db <- sqlCatalog [ "CREATE DOMAIN quantity AS INT" , "CREATE TABLE dependent_write (id quantity)" , "CREATE TABLE source_write (id INT)" ]
statement <- parseStatement "UPDATE dependent_write SET id = (SELECT MAX(id) FROM source_write)"
2026-10-16 23:46:04 +08:00
let identified = [( name , table { SQL . tableIdentity = Just ( SQL . TableIdentity 1 1 )}) | ( name , table ) <- db ]
2026-10-15 22:21:41 +08:00
bound <- bindWrite identified statement
2026-10-16 23:46:04 +08:00
let replaced = [( name , if name == "dependent_write" then table { SQL . tableIdentity = Just ( SQL . TableIdentity 1 2 )} else table ) | ( name , table ) <- identified ]
domainChanged = [( name , if name == SQL . domainTableName "quantity" then table { SQL . tableSchemaVersion = Just 2 } else table ) | ( name , table ) <- identified ]
2026-10-15 22:21:41 +08:00
changed <- parseStatement "ALTER TABLE source_write ADD COLUMN extra TEXT" >>= runStatement identified
target <- fst <$> runMemoryStorage ( executeWriteM bound ) replaced
dependency <- fst <$> runMemoryStorage ( executeWriteM bound ) ( fst changed )
domain <- fst <$> runMemoryStorage ( executeWriteM bound ) domainChanged
Right ( target , dependency , domain )
result ` shouldBe ` Right ( Left "bound query object changed: dependent_write" , Left "bound query schema changed: source_write" , Left "bound query schema changed: __system_domain_quantity" )
2026-10-16 23:46:04 +08:00
describe "composite capabilities" $ do
it "derives capabilities through all nested arguments without changing encoding" $
withType ( tupleType [ listType ( maybeType doubleType ), stringType ]) $ \ tid -> do
fmap descriptorCapabilities ( describeType builtinTypes tid )
` shouldBe ` Right [ EqCapability , OrdCapability , HashCapability ]
decodeType builtinTypes ( encodeType tid ) ` shouldBe ` Right tid
it "orders list elements numerically and shorter prefixes first, preserving ties" $ do
capabilityQuery "SELECT id FROM compound ORDER BY xs"
` shouldBe ` Right ( map ( \ n -> [ SQL . VInt n ]) [ 5 , 3 , 4 , 2 , 1 ])
capabilityQuery "SELECT id FROM compound ORDER BY xs DESC"
` shouldBe ` Right ( map ( \ n -> [ SQL . VInt n ]) [ 1 , 2 , 3 , 4 , 5 ])
it "orders Nothing before Just and tuples by their fields" $ do
capabilityQuery "SELECT id FROM compound ORDER BY opt"
` shouldBe ` Right ( map ( \ n -> [ SQL . VInt n ]) [ 5 , 2 , 4 , 1 , 3 ])
capabilityQuery "SELECT id FROM compound ORDER BY pair"
` shouldBe ` Right ( map ( \ n -> [ SQL . VInt n ]) [ 5 , 1 , 2 , 4 , 3 ])
it "groups and removes duplicates with the same equality and hash rules" $ do
capabilityQuery "SELECT COUNT(*) FROM compound GROUP BY xs ORDER BY xs"
` shouldBe ` Right ( map ( \ n -> [ SQL . VInt n ]) [ 1 , 2 , 1 , 1 ])
capabilityQuery "SELECT COUNT(*) FROM (SELECT DISTINCT xs FROM compound) d" ` shouldBe ` Right [[ SQL . VInt 4 ]]
capabilityQuery "SELECT COUNT(*) FROM (SELECT DISTINCT ds FROM compound) d" ` shouldBe ` Right [[ SQL . VInt 3 ]]
capabilityQuery "SELECT COUNT(*) FROM compound GROUP BY ds ORDER BY ds"
` shouldBe ` Right [[ SQL . VInt 1 ], [ SQL . VInt 3 ], [ SQL . VInt 1 ]]
it "computes extrema while retaining domain and runtime identities" $ withType ( listType intType ) $ \ tid -> do
capabilityQuery "SELECT MIN(xs), MAX(xs) FROM compound"
` shouldBe ` Right [[ SQL . VRuntime tid ( RList [ RInt 2 ]), SQL . VRuntime tid ( RList [ RInt 10 ])]]
capabilityQuery "SELECT MIN(xs) FROM compound WHERE id = 99" ` shouldBe ` Right [[ SQL . VNull ]]
it "uses structural equality for joins, membership and correlated existence" $ do
capabilityQuery "SELECT COUNT(*) FROM compound a INNER JOIN compound b ON a.xs = b.xs" ` shouldBe ` Right [[ SQL . VInt 6 ]]
capabilityQuery "SELECT id FROM compound WHERE xs IN (SELECT xs FROM compound WHERE id = 3) ORDER BY id"
` shouldBe ` Right [[ SQL . VInt 3 ], [ SQL . VInt 4 ]]
capabilityQuery "SELECT a.id FROM compound a WHERE EXISTS (SELECT b.id FROM compound b WHERE b.xs = a.xs AND b.id <> a.id) ORDER BY a.id"
` shouldBe ` Right [[ SQL . VInt 3 ], [ SQL . VInt 4 ]]
capabilityQuery "SELECT id FROM compound WHERE xs NOT IN (SELECT xs FROM compound WHERE id = 5)" ` shouldBe ` Right []
capabilityQuery "SELECT id FROM compound WHERE xs < ANY (SELECT xs FROM compound WHERE id = 1) ORDER BY id"
` shouldBe ` Right [[ SQL . VInt 2 ], [ SQL . VInt 3 ], [ SQL . VInt 4 ]]
capabilityQuery "SELECT id FROM compound WHERE xs = ALL (SELECT xs FROM compound WHERE id = 3) ORDER BY id"
` shouldBe ` Right [[ SQL . VInt 3 ], [ SQL . VInt 4 ]]
it "separates SQL NULL from Nothing and rejects different complete identities" $ do
sql "SELECT MAYBE<Int>() = MAYBE<Int>(), MAYBE<Int>() = NULL, LIST<Int>() < LIST<Int>(1)"
` shouldBe ` Right [[ SQL . VBool True , SQL . VNull , SQL . VBool True ]]
mapM_
( \ source -> sql source ` shouldSatisfy ` isFailure )
[ "SELECT LIST<Int>() = LIST<Double>()"
, "SELECT MAYBE<Int>() < MAYBE<String>()"
, "SELECT TUPLE<Int>(1) IN (TUPLE<Double>(1.0))"
, "SELECT SUM(LIST<Int>(1))"
]
it "keeps compare equality and hashes consistent for nested finite values" $ do
withType ( tupleType [ listType doubleType , maybeType intType ]) $ \ tid -> do
let values =
[ SQL . VRuntime tid ( RTuple [ RList [ RDouble n ], RMaybe optional ])
| n <- [ - 10 , - 0 , 0 , 2 , 10 ]
, optional <- [ Nothing , Just ( RInt 2 ), Just ( RInt 10 )]
]
mapM_
( \ ( left , right ) -> do
( SQL . compareValue left right == EQ ) ` shouldBe ` SQL . valuesEqual left right
when ( SQL . valuesEqual left right ) ( hash left ` shouldBe ` hash right )
)
[( left , right ) | left <- values , right <- values ]
it "rejects malformed runtime values at expression boundaries" $ withType ( listType doubleType ) $ \ tid -> do
mapM_
( \ value -> evalExpr ( Eq ( RuntimeLiteral tid value ) ( RuntimeLiteral tid value )) [] ` shouldSatisfy ` isFailure )
[ RList [ RDouble ( 0 / 0 )], RList [ RDouble ( 1 / 0 )], RList [ RInt 1 ]]
it "keeps runtime indexes closed without a key codec" $ do
db <- either ( fail . show ) pure capabilityDatabase
mapM_
( \ source -> do
statement <- either fail pure ( parseStatement source )
prepare db statement ` shouldSatisfy ` either ( isInfixOf "index key encoding is not registered" ) ( const False )
)
[ "CREATE INDEX ON compound(xs)" , "CREATE INDEX ON compound(ds)" ]
2026-10-05 22:22:23 +08:00
describe "runtime type registry" $ do
it "keeps a fixed identity encoding across releases" $ withType ( listType intType ) $ \ tid ->
encodeType tid ` shouldBe ` BS . pack "[1,[5,[[1,[]]]]]"
it "parses nested Haskell-style type expressions" $
parseTypeExpr "(Int, [Maybe String])" ` shouldBe ` Right ( tupleType [ intType , listType ( maybeType stringType )])
it "rejects constructor names without a token boundary" $
parseTypeExpr "MaybeInt" ` shouldSatisfy ` isFailure
it "restores stable nested identities from bootstrap metadata" $ do
let ty = tupleType [ listType intType , maybeType stringType ]
fmap descriptorPhysical ( resolveType builtinTypes ty )
` shouldBe ` Right ( Product [ Sequence SignedInteger , Optional Utf8 ])
it "distinguishes logical String from List Int" $
fmap descriptorId ( resolveType builtinTypes stringType )
` shouldNotBe ` fmap descriptorId ( resolveType builtinTypes ( listType intType ))
it "rejects unknown constructors" $
resolveType builtinTypes ( TypeApply ( TypeConstructorId 99 ) [] ) ` shouldSatisfy ` isFailure
it "rejects unapplied List" $
resolveType builtinTypes ( TypeApply ( TypeConstructorId 5 ) [] ) ` shouldSatisfy ` isFailure
it "rejects arguments to Int" $
resolveType builtinTypes ( TypeApply ( TypeConstructorId 1 ) [ intType ]) ` shouldSatisfy ` isFailure
2026-10-15 22:21:41 +08:00
describe "bound write expressions" $ do
it "rejects missing existing key columns instead of skipping uniqueness checks" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE constraint_slots (id INT PRIMARY KEY, qty INT UNIQUE)" ]
insert <- parseStatement "INSERT INTO constraint_slots (id, qty) VALUES (2, 3)"
2026-10-16 23:46:04 +08:00
let damaged = [( name , table { SQL . tableRows = [[( "qty" , SQL . VInt 9 )]]}) | ( name , table ) <- db ]
2026-10-15 22:21:41 +08:00
Right ( runStatement damaged insert )
case result of
Right rejected -> rejected ` shouldSatisfy ` either ( isInfixOf "missing bound column: id" ) ( const False )
Left err -> expectationFailure err
it "checks existing INSERT keys and ALTER constraints with reversed physical columns" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE constraint_order (id INT PRIMARY KEY, qty INT UNIQUE)"
, "INSERT INTO constraint_order (id, qty) VALUES (1, 2), (2, 3)"
]
let reversed = [( name , table { SQL . tableRows = map reverse ( SQL . tableRows table )}) | ( name , table ) <- db ]
2026-10-15 22:21:41 +08:00
insert <- parseStatement "INSERT INTO constraint_order (qty, id) VALUES (4, 3)"
( inserted , _ ) <- runStatement reversed insert
alter <- parseStatement "ALTER TABLE constraint_order ALTER COLUMN qty SET NOT NULL"
( altered , _ ) <- runStatement inserted alter
select <- parseStatement "SELECT id, qty FROM constraint_order"
map ( map snd ) <$> rowsOf ( runStatement altered select )
result ` shouldBe ` Right [[ SQL . VInt 1 , SQL . VInt 2 ], [ SQL . VInt 2 , SQL . VInt 3 ], [ SQL . VInt 3 , SQL . VInt 4 ]]
it "rejects missing ALTER input before evaluating bound constraints" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE altered_missing (id INT, qty INT UNIQUE)" ]
alter <- parseStatement "ALTER TABLE altered_missing ALTER COLUMN qty SET NOT NULL"
2026-10-16 23:46:04 +08:00
let damaged = [( name , table { SQL . tableRows = [[( "id" , SQL . VInt 1 )]]}) | ( name , table ) <- db ]
2026-10-15 22:21:41 +08:00
Right ( runStatement damaged alter )
case result of
Right rejected -> rejected ` shouldSatisfy ` either ( isInfixOf "missing bound column: qty" ) ( const False )
Left err -> expectationFailure err
it "rejects UPDATE nullability and final-row uniqueness violations" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE update_constraints (id INT PRIMARY KEY, qty INT NOT NULL UNIQUE)"
, "INSERT INTO update_constraints (id, qty) VALUES (1, 2), (2, 3)"
]
2026-10-15 22:21:41 +08:00
nullable <- parseStatement "UPDATE update_constraints SET qty = NULL WHERE id = 1"
duplicate <- parseStatement "UPDATE update_constraints SET qty = 3 WHERE id = 1"
primary <- parseStatement "UPDATE update_constraints SET id = 2 WHERE id = 1"
Right ( db , [( nullable , "NOT NULL" ), ( duplicate , "UNIQUE" ), ( primary , "UNIQUE" )])
case result of
2026-10-16 23:46:04 +08:00
Right ( db , statements ) ->
mapM_
( \ ( statement , marker ) ->
case runMemoryStorage ( runStatementM statement ) db of
Right ( Left err , unchanged ) -> do
err ` shouldSatisfy ` isInfixOf marker
map ( second SQL . tableRows ) unchanged
` shouldBe ` map ( second SQL . tableRows ) db
other -> expectationFailure ( show other )
)
statements
2026-10-15 22:21:41 +08:00
Left err -> expectationFailure err
it "checks UPDATE uniqueness after all rows rather than each replacement" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE update_unique (id INT PRIMARY KEY, qty INT UNIQUE)"
, "INSERT INTO update_unique (id, qty) VALUES (1, 2), (2, 3), (3, NULL), (4, NULL)"
, "UPDATE update_unique SET qty = qty + 1 WHERE id < 3"
]
2026-10-15 22:21:41 +08:00
select <- parseStatement "SELECT id, qty FROM update_unique"
map ( map snd ) <$> rowsOf ( runStatement db select )
2026-10-16 23:46:04 +08:00
result
` shouldBe ` Right
[ [ SQL . VInt 1 , SQL . VInt 3 ]
, [ SQL . VInt 2 , SQL . VInt 4 ]
, [ SQL . VInt 3 , SQL . VNull ]
, [ SQL . VInt 4 , SQL . VNull ]
]
2026-10-15 22:21:41 +08:00
it "rejects repeated INSERT targets instead of discarding later values" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE insert_targets (id INT, qty INT)" ]
statement <- parseStatement "INSERT INTO insert_targets (id, qty, qty) VALUES (1, 2, 9)"
runStatement db statement
result ` shouldSatisfy ` either ( isInfixOf "INSERT: duplicate target column: qty" ) ( const False )
it "binds reordered INSERT inputs while retaining defaults, NULL and auto numbering" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE DOMAIN insert_label AS VARCHAR(4)"
, "CREATE TABLE insert_slots (id INT AUTO_INCREMENT PRIMARY KEY, label insert_label DEFAULT 'ok', qty INT DEFAULT 7)"
, "INSERT INTO insert_slots (qty, label, id) VALUES (NULL, 'ab', 10), (3, 'cd', NULL), (4, 'ef', 2)"
, "INSERT INTO insert_slots (label) VALUES ('gh')"
, "INSERT INTO insert_slots (qty) VALUES (8)"
]
2026-10-15 22:21:41 +08:00
select <- parseStatement "SELECT id, label, qty FROM insert_slots"
map ( map snd ) <$> rowsOf ( runStatement db select )
2026-10-16 23:46:04 +08:00
result
` shouldBe ` Right
[ [ SQL . VInt 10 , SQL . VStr "ab" , SQL . VNull ]
, [ SQL . VInt 11 , SQL . VStr "cd" , SQL . VInt 3 ]
, [ SQL . VInt 2 , SQL . VStr "ef" , SQL . VInt 4 ]
, [ SQL . VInt 12 , SQL . VStr "gh" , SQL . VInt 7 ]
, [ SQL . VInt 13 , SQL . VStr "ok" , SQL . VInt 8 ]
]
2026-10-15 22:21:41 +08:00
it "binds write predicates and assignments to target schema positions" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE write_slots (id INT, qty INT)" ]
statement <- parseStatement "UPDATE write_slots SET qty = qty + id WHERE id = 1"
prepare db statement >>= bindWriteColumns db
2026-10-16 23:46:04 +08:00
result
` shouldBe ` Right
( Update
"write_slots"
[( "qty" , Add ( ColumnSlot 1 "qty" ) ( ColumnSlot 0 "id" ))]
( Just ( Eq ( ColumnSlot 0 "id" ) ( LitInt 1 )))
)
2026-10-15 22:21:41 +08:00
it "binds CHECK columns inside resolved function calls" $ do
let columns = [( "id" , SQL . plainColumn SQL . CInt ), ( "name" , SQL . plainColumn SQL . CStr )]
result = prepareRowExpression columns ( Gt ( FunctionCall "length" [ Col "name" ]) ( LitInt 1 ))
case result of
Right ( Gt ( BoundFunction ( FunctionId 1 ) _ [ ColumnSlot 1 "name" ]) ( LitInt 1 )) -> pure ()
_ -> expectationFailure ( show result )
it "preserves sequential updates and row order with reversed physical columns" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE write_slots (id INT, qty INT CHECK (qty >= 0))"
, "INSERT INTO write_slots (id, qty) VALUES (1, 2), (2, 10), (3, 5)"
]
let reversed = [( name , table { SQL . tableRows = map reverse ( SQL . tableRows table )}) | ( name , table ) <- db ]
2026-10-15 22:21:41 +08:00
update <- parseStatement "UPDATE write_slots SET qty = qty + 1, qty = qty + id WHERE id = 1"
( updated , _ ) <- runStatement reversed update
delete <- parseStatement "DELETE FROM write_slots WHERE qty = 10"
( remaining , _ ) <- runStatement updated delete
select <- parseStatement "SELECT id, qty FROM write_slots"
map ( map snd ) <$> rowsOf ( runStatement remaining select )
result ` shouldBe ` Right [[ SQL . VInt 1 , SQL . VInt 4 ], [ SQL . VInt 3 , SQL . VInt 5 ]]
it "keeps nested DOMAIN coercion, defaults and nullable writes" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE DOMAIN short_label AS VARCHAR(4)"
, "CREATE DOMAIN label AS short_label"
, "CREATE TABLE write_domains (id INT, name label CHECK (length(name) > 1), qty INT DEFAULT 2)"
, "INSERT INTO write_domains (id, name) VALUES (1, 'abc')"
]
2026-10-15 22:21:41 +08:00
select <- parseStatement "SELECT id, name, qty FROM write_domains"
original <- map ( map snd ) <$> rowsOf ( runStatement db select )
update <- parseStatement "UPDATE write_domains SET qty = NULL WHERE id = 1"
( updated , _ ) <- runStatement db update
rejected <- parseStatement "UPDATE write_domains SET name = 'abcde' WHERE id = 1"
rows <- map ( map snd ) <$> rowsOf ( runStatement updated select )
Right ( original , rows , runStatement updated rejected )
case result of
Right ( original , rows , rejected ) -> do
original ` shouldBe ` [[ SQL . VInt 1 , SQL . VStr "abc" , SQL . VInt 2 ]]
rows ` shouldBe ` [[ SQL . VInt 1 , SQL . VStr "abc" , SQL . VNull ]]
rejected ` shouldSatisfy ` isFailure
Left err -> expectationFailure err
it "keeps correlated subqueries in bound assignments and DELETE predicates" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE write_outer (id INT, qty INT)"
, "CREATE TABLE write_inner (id INT)"
, "INSERT INTO write_outer (id, qty) VALUES (1, 2), (2, 10)"
, "INSERT INTO write_inner (id) VALUES (2)"
]
2026-10-15 22:21:41 +08:00
update <- parseStatement "UPDATE write_outer SET qty = qty + (SELECT i.id FROM write_inner i WHERE i.id = qty) WHERE id = 1"
( updated , _ ) <- runStatement db update
select <- parseStatement "SELECT id, qty FROM write_outer"
changed <- map ( map snd ) <$> rowsOf ( runStatement updated select )
delete <- parseStatement "DELETE FROM write_outer WHERE EXISTS (SELECT i.id FROM write_inner i WHERE i.id = qty - 2)"
( remaining , _ ) <- runStatement updated delete
kept <- map ( map snd ) <$> rowsOf ( runStatement remaining select )
Right ( changed , kept )
2026-10-16 23:46:04 +08:00
result
` shouldBe ` Right
( [[ SQL . VInt 1 , SQL . VInt 4 ], [ SQL . VInt 2 , SQL . VInt 10 ]]
, [[ SQL . VInt 2 , SQL . VInt 10 ]]
)
2026-10-15 22:21:41 +08:00
it "checks altered rows using schema order and keeps CHECK failures explicit" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE write_checks (id INT, qty INT CHECK (qty > id))"
, "INSERT INTO write_checks (id, qty) VALUES (1, 3)"
]
let reversed = [( name , table { SQL . tableRows = map reverse ( SQL . tableRows table )}) | ( name , table ) <- db ]
2026-10-15 22:21:41 +08:00
alter <- parseStatement "ALTER TABLE write_checks ADD COLUMN note TEXT DEFAULT 'ok'"
( altered , _ ) <- runStatement reversed alter
invalid <- parseStatement "UPDATE write_checks SET qty = 0 WHERE id = 1"
Right ( runStatement altered invalid )
case result of
Right ( Left err ) -> err ` shouldSatisfy ` isInfixOf "CHECK on qty failed"
other -> expectationFailure ( show other )
it "does not evaluate skipped assignments or empty DELETE predicates" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE write_lazy (id INT, qty INT)"
, "INSERT INTO write_lazy (id, qty) VALUES (1, 2)"
]
2026-10-15 22:21:41 +08:00
update <- parseStatement "UPDATE write_lazy SET qty = 1 / 0 WHERE id = 99"
( updated , _ ) <- runStatement db update
delete <- parseStatement "DELETE FROM write_lazy"
( empty , _ ) <- runStatement updated delete
invalid <- parseStatement "DELETE FROM write_lazy WHERE 1 / 0 = 1"
runStatement empty invalid
result ` shouldSatisfy ` either ( const False ) ( const True )
it "rejects missing physical columns before a write" $ do
2026-10-16 23:46:04 +08:00
let db =
[
( "write_missing"
, SQL . Table
"write_missing"
[( "id" , SQL . plainColumn SQL . CInt ), ( "qty" , SQL . plainColumn SQL . CInt )]
[[( "id" , SQL . VInt 1 )]]
Nothing
Nothing
Nothing
)
]
mapM_
( \ source ->
rowsOf ( parseStatement source >>= runStatement db )
` shouldBe ` Left "missing bound column: qty"
)
2026-10-15 22:21:41 +08:00
[ "UPDATE write_missing SET id = 2" , "DELETE FROM write_missing WHERE id = 1" ]
2026-10-05 22:22:23 +08:00
describe "runtime encoding" $ do
it "round trips nested lists, optional values and tuples" $ do
let ty = tupleType [ listType ( maybeType intType ), stringType , doubleType , boolType ]
value = RTuple [ RList [ RMaybe Nothing , RMaybe ( Just ( RInt 42 ))], RString "你好" , RDouble 1.25 , RBool True ]
withType ty $ \ tid -> do
( encodeValue builtinTypes tid value >>= decodeValue builtinTypes tid ) ` shouldBe ` Right value
decodeType builtinTypes ( encodeType tid ) ` shouldBe ` Right tid
it "round trips the empty tuple" $ withType ( tupleType [] ) $ \ tid ->
( encodeValue builtinTypes tid ( RTuple [] ) >>= decodeValue builtinTypes tid ) ` shouldBe ` Right ( RTuple [] )
it "rejects mismatched list elements" $ withType ( listType intType ) $ \ tid ->
encodeValue builtinTypes tid ( RList [ RString "bad" ]) ` shouldSatisfy ` isFailure
it "rejects tuple arity mismatch" $ withType ( tupleType [ intType ]) $ \ tid ->
encodeValue builtinTypes tid ( RTuple [] ) ` shouldSatisfy ` isFailure
it "rejects non-finite floating point values" $ withType doubleType $ \ tid ->
encodeValue builtinTypes tid ( RDouble ( 1 / 0 )) ` shouldSatisfy ` isFailure
it "rejects unsupported type encoding versions" $
decodeType builtinTypes ( BS . pack "[2,[1,[]]]" ) ` shouldSatisfy ` isFailure
it "rejects overflowed constructor identities" $
decodeType builtinTypes ( BS . pack "[1,[18446744073709551617,[]]]" ) ` shouldSatisfy ` isFailure
it "rejects fractional integer payloads" $ withType intType $ \ tid ->
decodeValue builtinTypes tid ( BS . pack "[1,[1,[]],1.5]" ) ` shouldSatisfy ` isFailure
it "rejects encoded identity mismatch" $ withType intType $ \ tid ->
decodeValue builtinTypes tid ( BS . pack "[1,[4,[]], \" x \" ]" ) ` shouldSatisfy ` isFailure
describe "runtime binder and executor" $ do
it "resolves case-insensitive length to a stable FunctionId" $ withFunctions $ \ functions ->
withType stringType $ \ string -> withType intType $ \ int ->
resolveFunction functions "LENGTH" [ string ]
` shouldBe ` Right ( FunctionSignature ( FunctionId 1 ) "length" [ string ] int )
it "binds and executes nested calls" $ withFunctions $ \ functions -> do
let expression = Apply "not" [ Apply "not" [ Literal boolType ( RBool True )]]
( bindExpression builtinTypes functions [] expression >>= evaluateExpression builtinTypes functions [] )
` shouldBe ` Right ( RBool True )
2026-10-11 17:32:12 +08:00
it "uses the bound column slot and rejects reordered expression input" $ withFunctions $ \ functions ->
withType intType $ \ int -> withType stringType $ \ string -> do
2026-10-16 23:46:04 +08:00
let bound =
bindExpression
builtinTypes
functions
[( "count" , int ), ( "name" , string )]
( Apply "length" [ Reference "name" ])
2026-10-11 17:32:12 +08:00
( bound >>= evaluateExpression builtinTypes functions [( "count" , RInt 1 ), ( "name" , RString "abc" )])
` shouldBe ` Right ( RInt 3 )
( bound >>= evaluateExpression builtinTypes functions [( "name" , RString "abc" ), ( "count" , RInt 1 )])
` shouldBe ` Left "bound column position mismatch: name"
( bound >>= evaluateExpression builtinTypes functions [( "count" , RInt 1 )])
` shouldBe ` Left "missing bound column: name"
it "rejects ambiguous references before binding a slot" $ withFunctions $ \ functions ->
withType intType $ \ int ->
bindExpression builtinTypes functions [( "id" , int ), ( "id" , int )] ( Reference "id" )
` shouldSatisfy ` isFailure
it "normalizes storage order at scan boundaries before evaluating slots" $ withFunctions $ \ functions -> do
let catalog = [( "items" , [( "name" , stringType ), ( "enabled" , boolType )])]
2026-10-16 23:46:04 +08:00
query =
Projection
[( "size" , Apply "length" [ Reference "name" ])]
( Selection ( Reference "enabled" ) ( TableScan "items" ))
2026-10-11 17:32:12 +08:00
scan _ = Right [[( "enabled" , RBool True ), ( "name" , RString "abc" )]]
( bindPlan builtinTypes functions catalog query >>= executePlan builtinTypes functions scan )
` shouldBe ` Right [[( "size" , RInt 3 )]]
it "rebinds slots to each projection output schema" $ withFunctions $ \ functions -> do
let catalog = [( "items" , [( "name" , stringType ), ( "enabled" , boolType )])]
2026-10-16 23:46:04 +08:00
source =
Projection
[( "enabled" , Reference "enabled" ), ( "label" , Reference "name" )]
( TableScan "items" )
2026-10-11 17:32:12 +08:00
query = Projection [( "size" , Apply "length" [ Reference "label" ])] source
scan _ = Right [[( "name" , RString "abc" ), ( "enabled" , RBool True )]]
( bindPlan builtinTypes functions catalog query >>= executePlan builtinTypes functions scan )
` shouldBe ` Right [[( "size" , RInt 3 )]]
2026-10-05 22:22:23 +08:00
it "rejects a wrong function argument type during binding" $ withFunctions $ \ functions ->
bindExpression builtinTypes functions [] ( Apply "length" [ Literal intType ( RInt 1 )]) ` shouldSatisfy ` isFailure
it "rejects unknown function identities" $ withFunctions $ \ functions ->
invokeFunction builtinTypes functions ( FunctionId 99 ) [] ` shouldSatisfy ` isFailure
it "rejects wrong runtime argument types" $ withFunctions $ \ functions ->
invokeFunction builtinTypes functions ( FunctionId 1 ) [ RInt 1 ] ` shouldSatisfy ` isFailure
it "binds empty List and Nothing using explicit element types" $ withFunctions $ \ functions -> do
let expression = TupleLiteral [ ListLiteral intType [] , NothingLiteral stringType ]
( bindExpression builtinTypes functions [] expression >>= evaluateExpression builtinTypes functions [] )
` shouldBe ` Right ( RTuple [ RList [] , RMaybe Nothing ])
it "rejects mixed logical list types" $ withFunctions $ \ functions ->
bindExpression builtinTypes functions [] ( ListLiteral intType [ Literal doubleType ( RDouble 1 )]) ` shouldSatisfy ` isFailure
it "binds queries using schema without reading storage" $ withFunctions $ \ functions -> do
let catalog = [( "items" , [( "name" , stringType ), ( "enabled" , boolType )])]
2026-10-16 23:46:04 +08:00
query =
Projection
[( "size" , Apply "length" [ Reference "name" ])]
( Selection ( Reference "enabled" ) ( TableScan "items" ))
scan name =
if name == "items"
then
Right
[ [( "name" , RString "甲乙" ), ( "enabled" , RBool True )]
, [( "name" , RString "hidden" ), ( "enabled" , RBool False )]
]
else Left "unknown storage table"
2026-10-05 22:22:23 +08:00
( bindPlan builtinTypes functions catalog query >>= executePlan builtinTypes functions scan )
` shouldBe ` Right [[( "size" , RInt 2 )]]
it "uses catalog existence even when storage could return rows" $ withFunctions $ \ functions ->
bindPlan builtinTypes functions [] ( TableScan "missing" ) ` shouldSatisfy ` isFailure
it "rejects non-boolean filters" $ withFunctions $ \ functions ->
bindPlan builtinTypes functions [] ( Selection ( Literal intType ( RInt 1 )) SingleRow ) ` shouldSatisfy ` isFailure
it "rejects schema drift returned by storage" $ withFunctions $ \ functions ->
2026-10-16 23:46:04 +08:00
( bindPlan builtinTypes functions [( "t" , [( "x" , intType )])] ( TableScan "t" )
>>= executePlan builtinTypes functions ( const ( Right [[( "x" , RString "wrong" )]]))
)
` shouldSatisfy ` isFailure
2026-10-05 22:22:23 +08:00
it "propagates storage failures" $ withFunctions $ \ functions ->
2026-10-16 23:46:04 +08:00
( bindPlan builtinTypes functions [( "t" , [] )] ( TableScan "t" )
>>= executePlan builtinTypes functions ( const ( Left "storage unavailable" ))
)
` shouldBe ` Left "storage unavailable"
2026-10-05 22:22:23 +08:00
describe "SQL runtime functions" $ do
2026-10-11 17:32:12 +08:00
it "validates transitive DOMAIN dependencies and ignores unrelated definitions" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE DOMAIN amount AS INT"
, "CREATE DOMAIN total AS amount"
, "CREATE DOMAIN unrelated AS TEXT"
, "CREATE TABLE amounts (value total)"
]
2026-10-11 17:32:12 +08:00
statement <- parseStatement "SELECT value FROM amounts"
bound <- Query . bindQuery db statement
2026-10-16 23:46:04 +08:00
let change target =
[ ( name
, if name == target
then table { SQL . tableCols = [( "base" , SQL . plainColumn SQL . CBool )]}
else table
)
| ( name , table ) <- db
]
2026-10-11 17:32:12 +08:00
accepted <- fst <$> runMemoryStorage ( Query . executeQueryM bound ) ( change "__system_domain_unrelated" )
rejected <- fst <$> runMemoryStorage ( Query . executeQueryM bound ) ( change "__system_domain_amount" )
Right ( accepted , rejected )
result ` shouldBe ` Right ( Right [] , Left "bound query schema changed: __system_domain_amount" )
it "preserves exact catalog identities and rejects malformed identifiers" $ do
let identity = SQL . TableIdentity ( maxBound :: Word64 ) ( maxBound :: Word64 )
info = TableInfo "items" [] 0 [] [] [] ( Just identity ) Nothing
decode text = A . eitherDecode ( BS . pack text ) :: Either String TableInfo
A . fromJSON ( A . toJSON info ) ` shouldBe ` A . Success info
fmap tiIdentity ( decode "{ \" table \" : \" items \" , \" columns \" :[], \" row_count \" :0}" ) ` shouldBe ` Right Nothing
fmap tiIdentity ( decode "{ \" table \" : \" items \" , \" columns \" :[], \" row_count \" :0, \" database_id \" :0, \" object_id \" :1}" )
` shouldBe ` Right ( Just ( SQL . TableIdentity 0 1 ))
2026-10-16 23:46:04 +08:00
mapM_
( \ fields ->
decode ( "{ \" table \" : \" items \" , \" columns \" :[], \" row_count \" :0," ++ fields ++ "}" )
` shouldSatisfy ` isFailure
)
[ " \" database_id \" :1"
, " \" database_id \" :1, \" object_id \" :-1"
, " \" database_id \" :1, \" object_id \" :1.5"
, " \" database_id \" :1, \" object_id \" : \" 18446744073709551616 \" "
, " \" database_id \" :1, \" object_id \" :1e99999999"
]
2026-10-11 17:32:12 +08:00
it "rejects a same-schema replacement or loss of object identity" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE bound_items (id INT)" ]
2026-10-16 23:46:04 +08:00
let identified = [( name , table { SQL . tableIdentity = Just ( SQL . TableIdentity 1 1 )}) | ( name , table ) <- db ]
2026-10-11 17:32:12 +08:00
statement <- parseStatement "SELECT id FROM bound_items"
bound <- Query . bindQuery identified statement
2026-10-16 23:46:04 +08:00
let replaced = [( name , table { SQL . tableIdentity = Just ( SQL . TableIdentity 1 2 )}) | ( name , table ) <- db ]
2026-10-11 17:32:12 +08:00
changed <- fst <$> runMemoryStorage ( Query . executeQueryM bound ) replaced
lost <- fst <$> runMemoryStorage ( Query . executeQueryM bound ) db
Right ( changed , lost )
result ` shouldBe ` Right ( Left "bound query object changed: bound_items" , Left "bound query object changed: bound_items" )
it "preserves exact schema versions and rejects malformed versions" $ do
let info = TableInfo "items" [] 0 [] [] [] Nothing ( Just maxBound )
decode version = A . eitherDecode ( BS . pack ( "{ \" table \" : \" items \" , \" columns \" :[], \" row_count \" :0, \" schema_version \" :" ++ version ++ "}" )) :: Either String TableInfo
A . fromJSON ( A . toJSON info ) ` shouldBe ` A . Success info
fmap tiSchemaVersion ( decode "0" ) ` shouldBe ` Right Nothing
fmap tiSchemaVersion ( decode "7" ) ` shouldBe ` Right ( Just 7 )
2026-10-16 23:46:04 +08:00
mapM_
( \ version -> decode version ` shouldSatisfy ` isFailure )
2026-10-11 17:32:12 +08:00
[ "-1" , "1.5" , " \" 18446744073709551616 \" " , " \" +1 \" " , "1e99999999" ]
it "invalidates a bound query after restoring its original columns" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE versioned (id INT)" ]
statement <- parseStatement "SELECT id FROM versioned"
bound <- Query . bindQuery db statement
added <- parseStatement "ALTER TABLE versioned ADD COLUMN extra TEXT" >>= runStatement db
restored <- parseStatement "ALTER TABLE versioned DROP COLUMN extra" >>= runStatement ( fst added )
fst <$> runMemoryStorage ( Query . executeQueryM bound ) ( fst restored )
result ` shouldBe ` Right ( Left "bound query schema changed: versioned" )
it "rejects loss of a bound schema version" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE versioned (id INT)" ]
statement <- parseStatement "SELECT id FROM versioned"
bound <- Query . bindQuery db statement
2026-10-16 23:46:04 +08:00
fst
<$> runMemoryStorage
( Query . executeQueryM bound )
[( name , table { SQL . tableSchemaVersion = Nothing }) | ( name , table ) <- db ]
2026-10-11 17:32:12 +08:00
result ` shouldBe ` Right ( Left "bound query schema changed: versioned" )
it "ignores unrelated table changes but validates nested query dependencies" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE referenced (id INT)" , "CREATE TABLE unrelated (id INT)" ]
statement <- parseStatement "SELECT length((SELECT MIN(name) FROM (SELECT 'abc' AS name FROM referenced) d)) AS n"
bound <- Query . bindQuery db statement
unrelated <- parseStatement "ALTER TABLE unrelated ADD COLUMN extra TEXT" >>= runStatement db
accepted <- fst <$> runMemoryStorage ( Query . executeQueryM bound ) ( fst unrelated )
referenced <- parseStatement "ALTER TABLE referenced ADD COLUMN extra TEXT" >>= runStatement db
rejected <- fst <$> runMemoryStorage ( Query . executeQueryM bound ) ( fst referenced )
Right ( accepted , rejected )
result ` shouldBe ` Right ( Right [[( "n" , SQL . VNull )]], Left "bound query schema changed: referenced" )
2026-10-15 22:21:41 +08:00
it "guards tables referenced only by HAVING or expression ordering" $ do
let result query = do
db <- sqlCatalog [ "CREATE TABLE main_rows (id INT)" , "CREATE TABLE dependency_rows (id INT)" ]
bound <- parseStatement query >>= Query . bindQuery db
changed <- parseStatement "ALTER TABLE dependency_rows ADD COLUMN extra TEXT" >>= runStatement db
fst <$> runMemoryStorage ( Query . executeQueryM bound ) ( fst changed )
2026-10-16 23:46:04 +08:00
mapM_
( \ query -> result query ` shouldBe ` Right ( Left "bound query schema changed: dependency_rows" ))
2026-10-15 22:21:41 +08:00
[ "SELECT COUNT(*) FROM main_rows HAVING COUNT(*) > (SELECT COUNT(*) FROM dependency_rows)"
, "SELECT id FROM main_rows ORDER BY (SELECT COUNT(*) FROM dependency_rows) + id"
]
2026-10-11 17:32:12 +08:00
it "rejects schema drift before executing an empty bound query" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE bound_items (id INT)" ]
statement <- parseStatement "SELECT id FROM bound_items"
bound <- Query . bindQuery db statement
changed <- parseStatement "ALTER TABLE bound_items ADD COLUMN extra TEXT" >>= runStatement db
fst <$> runMemoryStorage ( Query . executeQueryM bound ) ( fst changed )
result ` shouldBe ` Right ( Left "bound query schema changed: bound_items" )
it "keeps binding valid across row and statistics changes" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE bound_items (id INT)" ]
statement <- parseStatement "SELECT id FROM bound_items"
bound <- Query . bindQuery db statement
changed <- parseStatement "INSERT INTO bound_items (id) VALUES (7)" >>= runStatement db
2026-10-16 23:46:04 +08:00
let current =
[ ( name , table { SQL . tableMeta = Just ( SQL . TableMeta 100 [] [] [] )})
| ( name , table ) <- fst changed
]
2026-10-11 17:32:12 +08:00
fst <$> runMemoryStorage ( Query . executeQueryM bound ) current
result ` shouldBe ` Right ( Right [[( "id" , SQL . VInt 7 )]])
it "binds grouping keys and then sorting to the grouped output" $ do
let source = Rel . Compute [( "first" , LitInt 1 ), ( "key" , LitInt 2 )] Rel . Unit
plan = Rel . Sort [( "key" , Desc )] ( Rel . Aggregate [ "key" ] [( "n" , CountAll )] source )
2026-10-16 23:46:04 +08:00
bound =
Rel . BoundSort
[( ColumnSlot 0 "key" , Desc )]
( Rel . BoundAggregate [( "key" , ColumnSlot 1 "key" )] [( "n" , CountAll )] source )
2026-10-11 17:32:12 +08:00
bindRelOpColumns [] [] plan ` shouldBe ` Right bound
evalRelOp [] bound ` shouldBe ` Right [[( "key" , SQL . VInt 2 ), ( "n" , SQL . VInt 1 )]]
evalRelOp [] ( Rel . BoundAggregate [( "key" , ColumnSlot 0 "key" )] [] source )
` shouldBe ` Left "bound column position mismatch: key"
it "sorts bound NULL keys stably and rejects wrong slots" $ do
let a = [( "id" , SQL . VInt 1 ), ( "key" , SQL . VInt 2 )]
b = [( "id" , SQL . VInt 2 ), ( "key" , SQL . VNull )]
c = [( "id" , SQL . VInt 3 ), ( "key" , SQL . VInt 2 )]
sortBoundRows [( ColumnSlot 1 "key" , Asc )] [] [ a , b , c ] ` shouldBe ` Right [ b , a , c ]
sortBoundRows [( ColumnSlot 1 "key" , Desc )] [] [ a , b , c ] ` shouldBe ` Right [ a , c , b ]
sortBoundRows [( ColumnSlot 0 "key" , Asc )] [] [ a ]
` shouldBe ` Left "bound column position mismatch: key"
it "preserves NULL group order and empty-input global aggregates" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE grouped_slots (id INT, tag TEXT)"
, "INSERT INTO grouped_slots (id, tag) VALUES (1, 'b'), (2, NULL), (3, 'b')"
]
2026-10-11 17:32:12 +08:00
grouped <- parseStatement "SELECT tag, COUNT(*) AS n FROM grouped_slots GROUP BY tag"
groups <- rowsOf ( runStatement db grouped )
empty <- parseStatement "SELECT COUNT(*) AS n, SUM(id) AS total FROM grouped_slots WHERE id < 0"
aggregates <- rowsOf ( runStatement db empty )
Right ( map ( map snd ) groups , map ( map snd ) aggregates )
2026-10-16 23:46:04 +08:00
result
` shouldBe ` Right
( [[ SQL . VStr "b" , SQL . VInt 2 ], [ SQL . VNull , SQL . VInt 1 ]]
, [[ SQL . VInt 0 , SQL . VNull ]]
)
2026-10-11 17:32:12 +08:00
it "binds SQL relation expressions to the optimized input slots" $ do
2026-10-16 23:46:04 +08:00
let plan =
Rel . Compute
[( "value" , Col "second" )]
( Rel . Compute [( "first" , LitInt 1 ), ( "second" , LitInt 2 )] Rel . Unit )
bindRelOpColumns [] [] plan
` shouldBe ` Right
( Rel . Compute
[( "value" , ColumnSlot 1 "second" )]
( Rel . Compute [( "first" , LitInt 1 ), ( "second" , LitInt 2 )] Rel . Unit )
)
2026-10-11 17:32:12 +08:00
bindRelOpColumns [] [] ( Rel . Filter ( Col "missing" ) Rel . Unit )
` shouldBe ` Left "unknown column: missing"
it "checks SQL slot position instead of searching another column" $ do
evalExpr ( ColumnSlot 1 "name" ) [( "name" , SQL . VStr "abc" ), ( "id" , SQL . VInt 1 )]
` shouldBe ` Left "bound column position mismatch: name"
evalExpr ( ColumnSlot ( - 1 ) "name" ) [( "name" , SQL . VStr "abc" )]
` shouldBe ` Left "bound column position mismatch: name"
it "binds projections without losing repeated outputs or empty rows" $ do
let source = Rel . Compute [( "first" , LitInt 1 ), ( "second" , LitInt 2 )] Rel . Unit
bindRelOpColumns [] [] ( Rel . Project [ "second" , "first" , "second" ] source )
2026-10-16 23:46:04 +08:00
` shouldBe ` Right
( Rel . Compute
[ ( "second" , ColumnSlot 1 "second" )
, ( "first" , ColumnSlot 0 "first" )
, ( "second" , ColumnSlot 1 "second" )
]
source
)
2026-10-11 17:32:12 +08:00
bindRelOpColumns [] [] ( Rel . Project [] source )
` shouldBe ` Right ( Rel . Compute [] source )
bindRelOpColumns [] [] ( Rel . Project [ "*" ] source )
` shouldBe ` Right ( Rel . Compute [( "first" , ColumnSlot 0 "first" ), ( "second" , ColumnSlot 1 "second" )] source )
it "preserves repeated SQL outputs and correlated projection values" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE slot_items (id INT)"
, "INSERT INTO slot_items (id) VALUES (1), (2)"
]
2026-10-11 17:32:12 +08:00
repeated <- parseStatement "SELECT id, id FROM slot_items"
repeatedRows <- rowsOf ( runStatement db repeated )
correlated <- parseStatement "SELECT o.id, (SELECT o.id FROM slot_items i WHERE i.id = o.id) AS echoed FROM slot_items o"
correlatedRows <- rowsOf ( runStatement db correlated )
Right ( map ( map snd ) repeatedRows , map ( map snd ) correlatedRows )
2026-10-16 23:46:04 +08:00
result
` shouldBe ` Right
( [[ SQL . VInt 1 , SQL . VInt 1 ], [ SQL . VInt 2 , SQL . VInt 2 ]]
, [[ SQL . VInt 1 , SQL . VInt 1 ], [ SQL . VInt 2 , SQL . VInt 2 ]]
)
2026-10-11 17:32:12 +08:00
it "binds outer references after the local relation layout" $ do
bindRelOpColumns [] [ "outer.id" ] ( Rel . Compute [( "id" , Col "outer.id" )] Rel . Unit )
` shouldBe ` Right ( Rel . Compute [( "id" , OuterColumnSlot 0 0 "outer.id" )] Rel . Unit )
2026-10-15 22:21:41 +08:00
it "binds subquery references to parent slots before execution" $ do
let statement = Select [( "value" , Col "parent.id" )] FromUnit Nothing [] Nothing [] Nothing
query = Subquery statement [ "parent.id" ]
source = Rel . Compute [( "id" , LitInt 1 )] Rel . Unit
plan = Rel . Compute [( "value" , ScalarSub query )] source
2026-10-16 23:46:04 +08:00
bindRelOpColumns [] [] plan
` shouldBe ` Right
( Rel . Compute
[( "value" , ScalarSub ( BoundSubquery statement [ "parent.id" ] [( "parent.id" , ColumnSlot 0 "id" )]))]
source
)
2026-10-15 22:21:41 +08:00
case bindRelOpColumns [] [] plan of
Left err -> expectationFailure err
Right bound -> evalRelOp [] bound ` shouldBe ` Right [[( "value" , SQL . VInt 1 )]]
it "keeps exact outer subquery references ahead of local physical fallbacks" $ do
let statement = Select [( "value" , Col "parent.id" )] FromUnit Nothing [] Nothing [] Nothing
query = Subquery statement [ "parent.id" ]
source = Rel . Compute [( "id" , LitInt 1 )] Rel . Unit
bindRelOpColumns [] [ "parent.id" ] ( Rel . Compute [( "value" , ScalarSub query )] source )
2026-10-16 23:46:04 +08:00
` shouldBe ` Right
( Rel . Compute
[
( "value"
, ScalarSub
( BoundSubquery
statement
[ "parent.id" ]
[( "parent.id" , OuterColumnSlot 1 0 "parent.id" )]
)
)
]
source
)
2026-10-15 22:21:41 +08:00
it "uses distinct bound positions when subqueries share a diagnostic name" $ do
let statement = Select [( "value" , Col "x" )] FromUnit Nothing [] Nothing [] Nothing
first = ScalarSub ( BoundSubquery statement [ "x" ] [( "x" , ColumnSlot 0 "a" )])
second = ScalarSub ( BoundSubquery statement [ "x" ] [( "x" , ColumnSlot 1 "b" )])
2026-10-16 23:46:04 +08:00
table =
SQL . Table
"slot_cache"
[( "a" , SQL . plainColumn SQL . CInt ), ( "b" , SQL . plainColumn SQL . CInt )]
[[( "a" , SQL . VInt 1 ), ( "b" , SQL . VInt 2 )], [( "a" , SQL . VInt 1 ), ( "b" , SQL . VInt 3 )]]
Nothing
Nothing
Nothing
2026-10-15 22:21:41 +08:00
plan = Rel . Compute [( "first" , first ), ( "second" , second )] ( Rel . Scan Nothing "slot_cache" Nothing )
subquerySlotsIn ( Add first second ) ` shouldBe ` [ ColumnSlot 0 "a" , ColumnSlot 1 "b" ]
2026-10-16 23:46:04 +08:00
evalRelOp [( "slot_cache" , table )] plan
` shouldBe ` Right
[ [( "first" , SQL . VInt 1 ), ( "second" , SQL . VInt 2 )]
, [( "first" , SQL . VInt 1 ), ( "second" , SQL . VInt 3 )]
]
2026-10-15 22:21:41 +08:00
it "rejects bound subquery layout mismatches instead of looking up names" $ do
let statement = Select [( "value" , Col "id" )] FromUnit Nothing [] Nothing [] Nothing
query = BoundSubquery statement [ "id" ] [( "id" , ColumnSlot 0 "id" )]
wrongLayout = Rel . Compute [( "other" , LitInt 2 ), ( "id" , LitInt 1 )] Rel . Unit
evalRelOp [] ( Rel . Compute [( "value" , ScalarSub query )] wrongLayout )
` shouldBe ` Left "bound column position mismatch: id"
prepareRowExpression [] ( ScalarSub query )
` shouldBe ` Left "execution subquery cannot be used in semantic input"
2026-10-16 23:46:04 +08:00
bindRelOpColumns
[]
[]
( Rel . Compute
[
( "value"
, ScalarSub
( BoundSubquery statement [ "id" ] [] )
)
]
Rel . Unit
)
2026-10-15 22:21:41 +08:00
` shouldBe ` Left "bound subquery references mismatch"
2026-10-11 17:32:12 +08:00
it "preserves outer scope identity when rebinding beside a local name" $ do
let source = Rel . Compute [( "id" , LitInt 1 )] Rel . Unit
expression = OuterColumnSlot 0 0 "id"
bound = bindRelOpColumns [] [ "id" ] ( Rel . Compute [( "outer" , expression )] source )
bound ` shouldBe ` Right ( Rel . Compute [( "outer" , OuterColumnSlot 1 0 "id" )] source )
evalExpr ( OuterColumnSlot 1 0 "id" ) [( "id" , SQL . VInt 1 ), ( "id" , SQL . VInt 9 )]
` shouldBe ` Right ( SQL . VInt 9 )
bindRelOpColumns [] [] ( Rel . Compute [( "outer" , expression )] source )
` shouldBe ` Left "unknown column: id"
prepareRowExpression [] expression ` shouldBe ` Left "execution column cannot be used in semantic input"
prepareRowExpression [] ( ColumnSlot 0 "id" ) ` shouldBe ` Left "execution column cannot be used in semantic input"
2026-10-15 22:21:41 +08:00
it "preserves duplicate column positions when rebinding local and outer slots" $ do
let source = Rel . Compute [( "id" , LitInt 1 ), ( "id" , LitInt 9 )] Rel . Unit
plan = Rel . Compute [( "value" , ColumnSlot 1 "id" )] source
bindRelOpColumns [] [] plan ` shouldBe ` Right plan
( bindRelOpColumns [] [] plan >>= evalRelOp [] )
` shouldBe ` Right [[( "value" , SQL . VInt 9 )]]
bindRelOpColumns [] [ "id" , "id" ] ( Rel . Compute [( "value" , OuterColumnSlot 0 1 "id" )] source )
` shouldBe ` Right ( Rel . Compute [( "value" , OuterColumnSlot 2 1 "id" )] source )
it "rejects ambiguous slot relocation and invalid bound positions" $ do
let source = Rel . Compute [( "other" , LitInt 0 ), ( "id" , LitInt 1 ), ( "id" , LitInt 9 )] Rel . Unit
bindRelOpColumns [] [] ( Rel . Compute [( "value" , ColumnSlot 0 "id" )] source )
` shouldBe ` Left "ambiguous bound column: id"
bindRelOpColumns [] [ "other" , "id" , "id" ] ( Rel . Compute [( "value" , OuterColumnSlot 0 0 "id" )] Rel . Unit )
` shouldBe ` Left "ambiguous bound column: id"
bindRelOpColumns [] [] ( Rel . Compute [( "value" , ColumnSlot ( - 1 ) "id" )] source )
` shouldBe ` Left "bound column position mismatch: id"
bindRelOpColumns [] [ "id" ] ( Rel . Compute [( "value" , OuterColumnSlot ( - 1 ) 0 "id" )] Rel . Unit )
` shouldBe ` Left "bound column position mismatch: id"
2026-10-16 23:46:04 +08:00
bindRelOpColumns
[]
[]
( Rel . Compute
[( "value" , ColumnSlot 0 "id" )]
( Rel . Compute [( "other" , LitInt 0 ), ( "id" , LitInt 9 )] Rel . Unit )
)
` shouldBe ` Right
( Rel . Compute
[( "value" , ColumnSlot 1 "id" )]
( Rel . Compute [( "other" , LitInt 0 ), ( "id" , LitInt 9 )] Rel . Unit )
)
2026-10-15 22:21:41 +08:00
it "keeps duplicate parent slots distinct through subquery rebinding and caching" $ do
let statement = Select [( "value" , Col "x" )] FromUnit Nothing [] Nothing [] Nothing
first = ScalarSub ( BoundSubquery statement [ "x" ] [( "x" , ColumnSlot 0 "id" )])
second = ScalarSub ( BoundSubquery statement [ "x" ] [( "x" , ColumnSlot 1 "id" )])
source = Rel . Compute [( "id" , LitInt 1 ), ( "id" , LitInt 9 )] Rel . Unit
plan = Rel . Compute [( "first" , first ), ( "second" , second )] source
bindRelOpColumns [] [] plan ` shouldBe ` Right plan
( bindRelOpColumns [] [] plan >>= evalRelOp [] )
` shouldBe ` Right [[( "first" , SQL . VInt 1 ), ( "second" , SQL . VInt 9 )]]
2026-10-11 17:32:12 +08:00
it "keeps inner shadowing and multi-level correlated SQL references" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE scoped_items (id INT)"
, "INSERT INTO scoped_items (id) VALUES (1), (2)"
]
2026-10-11 17:32:12 +08:00
statement <- parseStatement "SELECT o.id, (SELECT id FROM scoped_items i WHERE i.id = o.id) AS inner_id, (SELECT (SELECT o.id FROM scoped_items j WHERE j.id = i.id) FROM scoped_items i WHERE i.id = o.id) AS nested_id FROM scoped_items o"
rows <- rowsOf ( runStatement db statement )
Right ( map ( map snd ) rows )
result ` shouldBe ` Right [[ SQL . VInt 1 , SQL . VInt 1 , SQL . VInt 1 ], [ SQL . VInt 2 , SQL . VInt 2 , SQL . VInt 2 ]]
2026-10-15 22:21:41 +08:00
it "resolves the nearest of several enclosing column scopes" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE scope_far (id INT)"
, "CREATE TABLE scope_near (id INT)"
, "INSERT INTO scope_far (id) VALUES (1), (2)"
, "INSERT INTO scope_near (id) VALUES (10), (11)"
]
2026-10-15 22:21:41 +08:00
statement <- parseStatement "SELECT o.id, (SELECT (SELECT id) FROM scope_near n WHERE n.id = o.id + 9) AS nearest FROM scope_far o"
map ( map snd ) <$> rowsOf ( runStatement db statement )
result ` shouldBe ` Right [[ SQL . VInt 1 , SQL . VInt 10 ], [ SQL . VInt 2 , SQL . VInt 11 ]]
it "keeps enclosing scopes separate when aliases and DOMAIN types overlap" $ withType stringType $ \ tid -> do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE DOMAIN scope_label AS VARCHAR(4)"
, "CREATE TABLE scope_far (value INT)"
, "CREATE TABLE scope_near (value scope_label)"
, "INSERT INTO scope_far (value) VALUES (7)"
, "INSERT INTO scope_near (value) VALUES ('abc')"
]
2026-10-15 22:21:41 +08:00
statement <- parseStatement "SELECT (SELECT (SELECT length(s.value)) FROM scope_near s) AS size FROM scope_far s"
rows <- map ( map snd ) <$> rowsOf ( runStatement db statement )
domain <- parseStatement "SELECT (SELECT (SELECT s.value) FROM scope_near s) AS label FROM scope_far s"
bound <- Query . bindQuery db domain
Right ( rows , Query . queryTypes bound )
result ` shouldBe ` Right ([[ SQL . VInt 3 ]], [( "label" , Query . DomainType "scope_label" ( Query . RuntimeType tid ))])
it "skips empty or unrelated enclosing scopes and preserves NULL" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE scope_far (id INT)"
, "CREATE TABLE scope_near (name TEXT)"
, "INSERT INTO scope_far (id) VALUES (NULL), (4)"
, "INSERT INTO scope_near (name) VALUES ('n')"
]
2026-10-15 22:21:41 +08:00
statement <- parseStatement "SELECT (SELECT (SELECT (SELECT id)) FROM scope_near n) AS echoed FROM scope_far o"
map ( map snd ) <$> rowsOf ( runStatement db statement )
result ` shouldBe ` Right [[ SQL . VNull ], [ SQL . VInt 4 ]]
it "does not resolve an ambiguous nearer scope against a farther one" $ do
let result = do
db <- sqlCatalog [ "CREATE TABLE scope_far (id INT)" , "CREATE TABLE scope_near (id INT)" ]
statement <- parseStatement "SELECT (SELECT (SELECT id) FROM scope_near a JOIN scope_near b ON a.id = b.id) FROM scope_far o"
rowsOf ( runStatement db statement )
result ` shouldSatisfy ` either ( isInfixOf "ambiguous column" ) ( const False )
it "does not take a missing column from a shadowed source alias" $ do
let result source = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE source_far (id INT)"
, "CREATE TABLE source_near (other INT)"
, "INSERT INTO source_far (id) VALUES (1)"
, "INSERT INTO source_near (other) VALUES (10)"
]
2026-10-15 22:21:41 +08:00
statement <- parseStatement source
rowsOf ( runStatement db statement )
2026-10-16 23:46:04 +08:00
mapM_
( \ source -> result source ` shouldSatisfy ` either ( isInfixOf "unknown column" ) ( const False ))
[ "SELECT (SELECT s.id FROM source_near s) FROM source_far s"
, "SELECT (SELECT (SELECT s.id) FROM source_near s) FROM source_far s"
]
2026-10-15 22:21:41 +08:00
it "keeps bare far columns visible when the nearer alias has no such column" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE source_far (id INT)"
, "CREATE TABLE source_near (other INT)"
, "INSERT INTO source_far (id) VALUES (1), (2)"
, "INSERT INTO source_near (other) VALUES (10)"
]
2026-10-15 22:21:41 +08:00
statement <- parseStatement "SELECT (SELECT (SELECT id) FROM source_near s) AS inherited FROM source_far s"
map ( map snd ) <$> rowsOf ( runStatement db statement )
result ` shouldBe ` Right [[ SQL . VInt 1 ], [ SQL . VInt 2 ]]
it "uses lexical scopes in IN, EXISTS and quantified subqueries" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE scope_far (id INT)"
, "CREATE TABLE scope_near (id INT)"
, "INSERT INTO scope_far (id) VALUES (1)"
, "INSERT INTO scope_near (id) VALUES (10)"
]
2026-10-15 22:21:41 +08:00
statement <- parseStatement "SELECT (SELECT 10 IN (SELECT id) AND EXISTS (SELECT 1 WHERE id = 10) AND 10 = ALL (SELECT id) FROM scope_near n) AS matched FROM scope_far o"
map ( map snd ) <$> rowsOf ( runStatement db statement )
result ` shouldBe ` Right [[ SQL . VBool True ]]
it "resolves JOIN conditions against the nearest enclosing scope" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE scope_far (value INT)"
, "CREATE TABLE scope_near (value INT)"
, "CREATE TABLE scope_join (id INT)"
, "INSERT INTO scope_far (value) VALUES (1)"
, "INSERT INTO scope_near (value) VALUES (10)"
, "INSERT INTO scope_join (id) VALUES (10)"
]
2026-10-15 22:21:41 +08:00
statement <- parseStatement "SELECT (SELECT (SELECT a.id FROM scope_join a JOIN scope_join b ON a.id = value AND b.id = a.id) FROM scope_near n) AS matched FROM scope_far o"
map ( map snd ) <$> rowsOf ( runStatement db statement )
result ` shouldBe ` Right [[ SQL . VInt 10 ]]
2026-10-11 17:32:12 +08:00
it "executes SQL against reversed physical column order" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE TABLE slot_items (id INT, name TEXT)"
, "INSERT INTO slot_items (id, name) VALUES (1, 'abc'), (2, 'xy')"
]
let reordered = [( name , table { SQL . tableRows = map reverse ( SQL . tableRows table )}) | ( name , table ) <- db ]
2026-10-11 17:32:12 +08:00
statement <- parseStatement "SELECT length(name) AS size, id + 1 AS next FROM slot_items WHERE id > 0 ORDER BY size"
rowsOf ( runStatement reordered statement )
fmap ( map ( map snd )) result ` shouldBe ` Right [[ SQL . VInt 2 , SQL . VInt 3 ], [ SQL . VInt 3 , SQL . VInt 2 ]]
2026-10-05 22:22:23 +08:00
it "binds the SQL entry point to output TypeIds" $ withType intType $ \ tid -> do
let result = parseStatement "SELECT length('abc') AS size" >>= Query . bindQuery []
fmap Query . queryTypes result ` shouldBe ` Right [( "size" , Query . RuntimeType tid )]
it "retains compatibility for existing temporal SQL types" $ do
let result = parseStatement "SELECT DATE '2026-10-05' AS today" >>= Query . bindQuery []
fmap Query . queryTypes result ` shouldBe ` Right [( "today" , Query . CompatibilityType SQL . CDate )]
2026-10-11 17:32:12 +08:00
it "retains nested DOMAIN identities through derived aliases and DISTINCT" $ withType intType $ \ tid -> do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE DOMAIN quantity AS INT"
, "CREATE DOMAIN stock AS quantity"
, "CREATE TABLE inventory (qty stock)"
, "INSERT INTO inventory (qty) VALUES (2), (NULL)"
]
2026-10-11 17:32:12 +08:00
statement <- parseStatement "SELECT DISTINCT d.qty AS available FROM (SELECT qty FROM inventory) d"
bound <- Query . bindQuery db statement
rows <- rowsOf ( runStatement db statement )
Right ( Query . queryTypes bound , map ( map snd ) rows )
2026-10-16 23:46:04 +08:00
result
` shouldBe ` Right
(
[
( "available"
, Query . DomainType
"stock"
( Query . DomainType "quantity" ( Query . RuntimeType tid ))
)
]
, [[ SQL . VInt 2 ], [ SQL . VNull ]]
)
2026-10-11 17:32:12 +08:00
it "preserves temporal and binary DOMAIN wrappers" $ do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE DOMAIN day AS DATE"
, "CREATE DOMAIN payload AS BLOB"
, "CREATE TABLE documents (created day, contents payload)"
]
2026-10-11 17:32:12 +08:00
statement <- parseStatement "SELECT created, contents FROM documents"
Query . queryTypes <$> Query . bindQuery db statement
2026-10-16 23:46:04 +08:00
result
` shouldBe ` Right
[ ( "created" , Query . DomainType "day" ( Query . CompatibilityType SQL . CDate ))
, ( "contents" , Query . DomainType "payload" ( Query . CompatibilityType SQL . CBlob ))
]
2026-10-11 17:32:12 +08:00
it "uses base function semantics without labeling function results as DOMAIN" $ withType intType $ \ tid -> do
let result = do
2026-10-16 23:46:04 +08:00
db <-
sqlCatalog
[ "CREATE DOMAIN label AS VARCHAR(3)"
, "CREATE TABLE names (name label)"
, "INSERT INTO names (name) VALUES ('abc')"
]
2026-10-11 17:32:12 +08:00
statement <- parseStatement "SELECT length(name) AS size FROM names"
bound <- Query . bindQuery db statement
rows <- rowsOf ( runStatement db statement )
Right ( Query . queryTypes bound , map ( map snd ) rows )
result ` shouldBe ` Right ([( "size" , Query . RuntimeType tid )], [[ SQL . VInt 3 ]])
2026-10-16 23:46:04 +08:00
it "sorts composites with their registered ordering" $ withType ( listType intType ) $ \ tid ->
sql "SELECT LIST<Int>(1) AS xs ORDER BY xs" ` shouldBe ` Right [[ SQL . VRuntime tid ( RList [ RInt 1 ])]]
it "computes composite extrema with their registered ordering" $ withType ( listType intType ) $ \ tid ->
sql "SELECT MIN(LIST<Int>(1))" ` shouldBe ` Right [[ SQL . VRuntime tid ( RList [ RInt 1 ])]]
2026-10-05 22:22:23 +08:00
it "rejects unique runtime columns without a key implementation" $
( parseStatement "CREATE TABLE keyed (xs [Int] UNIQUE)" >>= runStatement [] ) ` shouldSatisfy ` isFailure
it "rejects primary runtime keys without a key implementation" $
( parseStatement "CREATE TABLE keyed (xs [Int] PRIMARY KEY)" >>= runStatement [] ) ` shouldSatisfy ` isFailure
it "constructs nested compound values in SQL" $ withType ( listType ( maybeType intType )) $ \ tid ->
sql "SELECT LIST<Maybe Int>(MAYBE<Int>(), MAYBE<Int>(42))"
` shouldBe ` Right [[ SQL . VRuntime tid ( RList [ RMaybe Nothing , RMaybe ( Just ( RInt 42 ))])]]
it "constructs heterogeneous tuples with stable type identity" $ withType ( tupleType [ intType , stringType ]) $ \ tid ->
sql "SELECT TUPLE<Int, String>(1, 'a')" ` shouldBe ` Right [[ SQL . VRuntime tid ( RTuple [ RInt 1 , RString "a" ])]]
it "rejects constructor argument type mismatch" $
sql "SELECT LIST<Int>('bad')" ` shouldSatisfy ` isFailure
it "rejects constructor arity mismatch" $
sql "SELECT MAYBE<Int>(1, 2)" ` shouldSatisfy ` isFailure
it "rejects SQL NULL inside a typed compound value" $
sql "SELECT LIST<Int>(NULL)" ` shouldSatisfy ` isFailure
it "round trips typed runtime values through the shared wire protocol" $
withType ( maybeType ( listType intType )) $ \ tid -> do
let value = SQL . VRuntime tid ( RMaybe ( Just ( RList [ RInt 1 , RInt 2 ])))
parseEither valueFromJSON ( valueToJSON value ) ` shouldBe ` Right value
it "round trips typed schema identities through catalog type names" $
withType ( tupleType [ intType , listType stringType ]) $ \ tid ->
SQL . parseColumnType ( SQL . typeName ( SQL . CRuntime tid )) ` shouldBe ` Just ( SQL . CRuntime tid )
it "keeps hashing consistent for signed floating zero" $ withType ( listType doubleType ) $ \ tid -> do
let positive = SQL . VRuntime tid ( RList [ RDouble 0 ])
negative = SQL . VRuntime tid ( RList [ RDouble ( - 0 )])
positive ` shouldBe ` negative
hash positive ` shouldBe ` hash negative
it "creates and writes compound columns through SQL" $ do
let result = do
create <- parseStatement "CREATE TABLE composite (xs [Int], opt Maybe String, pair (Int, String))"
( db , _ ) <- runStatement [] create
insert <- parseStatement "INSERT INTO composite (xs, opt, pair) VALUES (LIST<Int>(1, 2), MAYBE<String>(), TUPLE<Int, String>(3, 'x'))"
( updated , _ ) <- runStatement db insert
select <- parseStatement "SELECT xs, opt, pair FROM composite"
rowsOf ( runStatement updated select )
result ` shouldSatisfy ` either ( const False ) (( == 1 ) . length )
it "stores logical String with the generic runtime encoding" $ do
let result = do
create <- parseStatement "CREATE TABLE strings (text String)"
( db , _ ) <- runStatement [] create
insert <- parseStatement "INSERT INTO strings (text) VALUES ('abc')"
( updated , _ ) <- runStatement db insert
select <- parseStatement "SELECT length(text) FROM strings"
map ( map snd ) <$> rowsOf ( runStatement updated select )
result ` shouldBe ` Right [[ SQL . VInt 3 ]]
it "runs length and not through resolved identities" $
sql "SELECT length('你好'), not(TRUE)" ` shouldBe ` Right [[ SQL . VInt 2 , SQL . VBool False ]]
it "preserves nullable SQL function semantics" $
sql "SELECT length(NULL), not(NULL)" ` shouldBe ` Right [[ SQL . VNull , SQL . VNull ]]
it "binds calls before execution" $ do
let bound = parseStatement "SELECT length('abc')" >>= prepare []
case bound of
2026-10-16 23:46:04 +08:00
Right Select { selectItems = [( _ , BoundFunction ( FunctionId 1 ) _ [ _ ])]} -> pure ()
2026-10-05 22:22:23 +08:00
_ -> expectationFailure ( show bound )
it "rejects unknown SQL functions before scanning" $
sql "SELECT missing('abc')" ` shouldSatisfy ` isFailure
it "rejects wrong argument count" $
sql "SELECT length('a', 'b')" ` shouldSatisfy ` isFailure
it "rejects wrong SQL argument type" $
sql "SELECT length(1)" ` shouldSatisfy ` isFailure
it "finds references inside calls for projection pushdown" $
sql "SELECT length(name) FROM t WHERE not(enabled)" ` shouldBe ` Right [[ SQL . VInt 3 ]]
it "rewrites aggregates nested in calls" $
sql "SELECT length(MIN(name)) FROM t" ` shouldBe ` Right [[ SQL . VInt 2 ]]
it "executes subqueries nested in function arguments" $
sql "SELECT length((SELECT MIN(name) FROM t))" ` shouldBe ` Right [[ SQL . VInt 2 ]]
it "expands CTEs inside function arguments" $
sql "WITH names AS (SELECT name FROM t) SELECT length((SELECT MIN(name) FROM names))"
` shouldBe ` Right [[ SQL . VInt 2 ]]
it "binds CHECK functions using the row schema" $ do
let result = do
statement <- parseStatement "CREATE TABLE checked (name TEXT CHECK (length(name) > 1))"
( db , _ ) <- runStatement [] statement
insert <- parseStatement "INSERT INTO checked (name) VALUES ('abc')"
runStatement db insert
result ` shouldSatisfy ` either ( const False ) ( const True )
-- | 通过正式入口执行测试 SQL
sql :: String -> Either String [[ SQL . Value ]]
sql source = do
statement <- parseStatement source
rows <- rowsOf ( runStatement database statement )
Right ( map ( map snd ) rows )
where
2026-10-16 23:46:04 +08:00
-- \| 提供函数调用测试表
database =
[
( "t"
, SQL . Table
"t"
[( "name" , SQL . plainColumn SQL . CStr ), ( "enabled" , SQL . plainColumn SQL . CBool )]
[ [( "name" , SQL . VStr "ab" ), ( "enabled" , SQL . VBool True )]
, [( "name" , SQL . VStr "xyz" ), ( "enabled" , SQL . VBool False )]
]
Nothing
Nothing
Nothing
)
]
2026-10-05 22:22:23 +08:00
-- | 判断结果是否明确失败
isFailure :: Either a b -> Bool
isFailure ( Left _ ) = True
isFailure _ = False
-- | 准备已解析类型身份
withType :: TypeExpr -> ( TypeId -> Expectation ) -> Expectation
withType ty action = case resolveType builtinTypes ty of
Left err -> expectationFailure err
Right descriptor -> action ( descriptorId descriptor )
-- | 准备内建函数注册表
withFunctions :: ( FunctionRegistry -> Expectation ) -> Expectation
withFunctions action = case builtinFunctions builtinTypes of
Left err -> expectationFailure err
Right functions -> action functions