v26.10.1 正式版
修复部分问题，优化性能，进一步推进类型系统
This commit is contained in:
LIm1tZz7 committed
1 parent
48eec484b7
commit
8ce4239452
89 files changed
+5808
-884
No files matched your search
@@ -22,6 +22,12 @@ library
|
||||
ChuSQL.Core.Engine.Error
|
||||
ChuSQL.Core.Engine
|
||||
ChuSQL.Core.Engine.Parallel
|
||||
ChuSQL.Core.Engine.Normalization
|
||||
ChuSQL.Core.Engine.Runtime.Types
|
||||
ChuSQL.Core.Engine.Runtime.Functions
|
||||
ChuSQL.Core.Engine.Runtime.Binding
|
||||
ChuSQL.Core.Engine.Runtime.SQL
|
||||
ChuSQL.Core.Engine.Runtime.Query
|
||||
ChuSQL.Core.Engine.Semantic
|
||||
ChuSQL.Core.Engine.Storage
|
||||
ChuSQL.Core.Engine.Storage.FFI
|
||||
@@ -39,6 +45,7 @@ library
|
||||
, scientific
|
||||
, text
|
||||
, unordered-containers
|
||||
, vector
|
||||
extra-libraries: chusql_core_storage
|
||||
-- 运行期找 libchusql_core_storage.so：$ORIGIN 让二进制与动态库同目录即可
|
||||
if os(linux)
|
||||
@@ -51,6 +58,8 @@ library
|
||||
test-suite chusql-core-engine-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules: NormalizationSpec
|
||||
RuntimeSpec
|
||||
hs-source-dirs: test
|
||||
build-depends: base
|
||||
, chusql-core-engine
|
||||
@@ -59,5 +68,7 @@ test-suite chusql-core-engine-test
|
||||
, filepath
|
||||
, hashable
|
||||
, hspec
|
||||
, bytestring
|
||||
, aeson
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -threaded
|
||||
@@ -1,11 +1,10 @@
|
||||
module ChuSQL.Core.Engine (runStatement, runStatementM, rowsOf) where
|
||||
|
||||
import ChuSQL.Core.Engine.Algebra.Eval (evalCondForRowM, evalExprM, evalRelOpM)
|
||||
import ChuSQL.Core.Engine.Algebra.Eval (evalCondForRowM, evalExprM)
|
||||
import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr)
|
||||
import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
|
||||
import ChuSQL.Core.Engine.Algebra.Planner (translate)
|
||||
import ChuSQL.Core.Engine.Runtime.Query (bindQuery, executeQueryM)
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Semantic (prepare)
|
||||
import ChuSQL.Core.Engine.Semantic (prepare, prepareRowExpression)
|
||||
import ChuSQL.Core.Engine.Storage (MonadStorage (..))
|
||||
import ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage))
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
@@ -41,13 +40,13 @@ runStatementM q = do
|
||||
-- | 按语句类型分发（已检查过）
|
||||
runStatementUncheckedM :: (MonadStorage m) => Database -> Statement -> m (Either String [Row])
|
||||
runStatementUncheckedM db q@Select{} =
|
||||
case translate q of
|
||||
case bindQuery db q of
|
||||
Left e -> pure (Left e)
|
||||
Right relOp -> evalRelOpM db (optimize db relOp)
|
||||
Right bound -> executeQueryM bound
|
||||
runStatementUncheckedM db q@SelectExpr{} =
|
||||
case translate q of
|
||||
case bindQuery db q of
|
||||
Left e -> pure (Left e)
|
||||
Right relOp -> evalRelOpM db (optimize db relOp)
|
||||
Right bound -> executeQueryM bound
|
||||
runStatementUncheckedM db (Insert tbl cols rows) =
|
||||
case lookupTable db tbl of
|
||||
Left e -> pure (Left e)
|
||||
@@ -241,7 +240,9 @@ checkPlan table = mapM parse (mapMaybe checked (tableCols table))
|
||||
-- | 解析一列的 CHECK 文本
|
||||
parse (name, text) = case parseExpression text of
|
||||
Left err -> Left ("CHECK on " ++ name ++ ": " ++ firstLine err)
|
||||
Right e -> Right (name, e)
|
||||
Right e -> do
|
||||
bound <- prepareRowExpression (tableCols table) e
|
||||
Right (name, bound)
|
||||
|
||||
-- | 执行解析好的 CHECK 条件
|
||||
runChecks :: CheckPlan -> Row -> Either String ()
|
||||
|
||||
@@ -36,6 +36,7 @@ valueLiteral (VInt n) = LitInt n
|
||||
valueLiteral (VFloat d) = LitFloat d
|
||||
valueLiteral (VStr s) = LitStr s
|
||||
valueLiteral (VBool b) = LitBool b
|
||||
valueLiteral (VRuntime tid value) = RuntimeLiteral tid value
|
||||
valueLiteral VNull = LitNull
|
||||
|
||||
-- | 点查退化成扫描时用的条件
|
||||
@@ -362,6 +363,18 @@ scalarResult rows = do
|
||||
-- | 把子查询求值成字面量；子查询的错直接往上传
|
||||
substSubqueries :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Expr)
|
||||
substSubqueries db e env = case e of
|
||||
Construct tid arguments -> do
|
||||
bound <- mapM (\argument -> substSubqueries db argument env) arguments
|
||||
pure (Construct tid <$> sequence bound)
|
||||
BoundConstruct tid arguments -> do
|
||||
bound <- mapM (\argument -> substSubqueries db argument env) arguments
|
||||
pure (BoundConstruct tid <$> sequence bound)
|
||||
FunctionCall name arguments -> do
|
||||
bound <- mapM (\argument -> substSubqueries db argument env) arguments
|
||||
pure (FunctionCall name <$> sequence bound)
|
||||
BoundFunction fid tid arguments -> do
|
||||
bound <- mapM (\argument -> substSubqueries db argument env) arguments
|
||||
pure (BoundFunction fid tid <$> sequence bound)
|
||||
ScalarSub sq -> scalarResult <$> runSubqueryRows db sq env
|
||||
InSub a sq negated -> do
|
||||
lhs <- substSubqueries db a env
|
||||
|
||||
@@ -3,6 +3,7 @@ module ChuSQL.Core.Engine.Algebra.Expr (evalExpr, evalCondForRow, colsInExpr, su
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import ChuSQL.Core.Engine.Builtin (Operator (..), compareNode, executeOperator, inValues, threeValuedNot)
|
||||
import ChuSQL.Core.Engine.Runtime.SQL (invokeSQLFunction, constructSQLValue)
|
||||
|
||||
-- 表达式求值：三值逻辑，NULL 参与运算结果仍是 NULL。
|
||||
|
||||
@@ -10,6 +11,12 @@ import ChuSQL.Core.Engine.Builtin (Operator (..), compareNode, executeOperator,
|
||||
evalExpr :: Expr -> Row -> Either String Value
|
||||
evalExpr (Col name) row =
|
||||
maybe (Left ("unknown column: " ++ name)) Right (lookup name row)
|
||||
evalExpr (FunctionCall name _) _ = Left ("unbound function call: " ++ name)
|
||||
evalExpr (Construct _ _) _ = Left "unbound runtime constructor"
|
||||
evalExpr (BoundConstruct tid arguments) row = mapM (\argument -> evalExpr argument row) arguments >>= constructSQLValue tid
|
||||
evalExpr (RuntimeLiteral tid value) _ = coerceValue (CRuntime tid) (VRuntime tid value)
|
||||
evalExpr (BoundFunction fid tid arguments) row =
|
||||
mapM (\argument -> evalExpr argument row) arguments >>= invokeSQLFunction fid tid
|
||||
evalExpr LitNull _ = Right VNull
|
||||
evalExpr (LitInt n) _ = Right (VInt n)
|
||||
evalExpr (LitFloat d) _ = Right (VFloat d)
|
||||
@@ -63,6 +70,10 @@ quantifiedCompare op lhs vs q = case vs of
|
||||
-- | 表达式用到了哪些列
|
||||
colsInExpr :: Expr -> [String]
|
||||
colsInExpr (Col c) = [c]
|
||||
colsInExpr (Construct _ arguments) = concatMap colsInExpr arguments
|
||||
colsInExpr (BoundConstruct _ arguments) = concatMap colsInExpr arguments
|
||||
colsInExpr (FunctionCall _ arguments) = concatMap colsInExpr arguments
|
||||
colsInExpr (BoundFunction _ _ arguments) = concatMap colsInExpr arguments
|
||||
colsInExpr (Add a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Sub a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Mul a b) = colsInExpr a ++ colsInExpr b
|
||||
@@ -93,6 +104,10 @@ colsInExpr _ = []
|
||||
-- | 表达式里子查询引用的外层列
|
||||
subqueryRefsIn :: Expr -> [String]
|
||||
subqueryRefsIn e = case e of
|
||||
Construct _ arguments -> concatMap subqueryRefsIn arguments
|
||||
BoundConstruct _ arguments -> concatMap subqueryRefsIn arguments
|
||||
FunctionCall _ arguments -> concatMap subqueryRefsIn arguments
|
||||
BoundFunction _ _ arguments -> concatMap subqueryRefsIn arguments
|
||||
ScalarSub sq -> subqueryRefs sq
|
||||
InSub a sq _ -> subqueryRefsIn a ++ subqueryRefs sq
|
||||
InList a es _ -> concatMap subqueryRefsIn (a : es)
|
||||
@@ -126,6 +141,10 @@ subqueryRefsIn e = case e of
|
||||
-- | 表达式里有没有除法（除法可能报错，不能提前或延后求值）
|
||||
hasDivision :: Expr -> Bool
|
||||
hasDivision e = case e of
|
||||
Construct _ arguments -> any hasDivision arguments
|
||||
BoundConstruct _ arguments -> any hasDivision arguments
|
||||
FunctionCall _ arguments -> any hasDivision arguments
|
||||
BoundFunction _ _ arguments -> any hasDivision arguments
|
||||
Div _ _ -> True
|
||||
Neg a -> hasDivision a
|
||||
Add a b -> both a b
|
||||
@@ -148,6 +167,10 @@ hasDivision e = case e of
|
||||
-- | 表达式里有没有子查询
|
||||
hasSubquery :: Expr -> Bool
|
||||
hasSubquery e = case e of
|
||||
Construct _ arguments -> any hasSubquery arguments
|
||||
BoundConstruct _ arguments -> any hasSubquery arguments
|
||||
FunctionCall _ arguments -> any hasSubquery arguments
|
||||
BoundFunction _ _ arguments -> any hasSubquery arguments
|
||||
ScalarSub _ -> True
|
||||
InSub _ _ _ -> True
|
||||
InList a es _ -> any hasSubquery (a : es)
|
||||
@@ -181,6 +204,10 @@ hasSubquery e = case e of
|
||||
-- | 表达式里出现的聚合调用（按出现顺序）
|
||||
aggregatesIn :: Expr -> [Expr]
|
||||
aggregatesIn e = case e of
|
||||
Construct _ arguments -> concatMap aggregatesIn arguments
|
||||
BoundConstruct _ arguments -> concatMap aggregatesIn arguments
|
||||
FunctionCall _ arguments -> concatMap aggregatesIn arguments
|
||||
BoundFunction _ _ arguments -> concatMap aggregatesIn arguments
|
||||
a@CountAll -> [a]
|
||||
a@(CountOf _) -> [a]
|
||||
a@(SumOf _) -> [a]
|
||||
@@ -215,6 +242,10 @@ hasAggregate = not . null . aggregatesIn
|
||||
-- | 聚合之外的列引用（聚合参数里的列不算）
|
||||
bareColumns :: Expr -> [String]
|
||||
bareColumns e = case e of
|
||||
Construct _ arguments -> concatMap bareColumns arguments
|
||||
BoundConstruct _ arguments -> concatMap bareColumns arguments
|
||||
FunctionCall _ arguments -> concatMap bareColumns arguments
|
||||
BoundFunction _ _ arguments -> concatMap bareColumns arguments
|
||||
Col c -> [c]
|
||||
Add a b -> both a b
|
||||
Sub a b -> both a b
|
||||
|
||||
@@ -139,6 +139,7 @@ foldNode e
|
||||
Right (VFloat d) -> LitFloat d
|
||||
Right (VStr s) -> LitStr s
|
||||
Right (VBool b) -> LitBool b
|
||||
Right (VRuntime tid value) -> RuntimeLiteral tid value
|
||||
Left _ -> e
|
||||
| otherwise = e
|
||||
|
||||
@@ -149,6 +150,8 @@ foldConstants (Sub a b) = foldNode (Sub (foldConstants a) (foldConstants b))
|
||||
foldConstants (Mul a b) = foldNode (Mul (foldConstants a) (foldConstants b))
|
||||
foldConstants (Div a b) = foldNode (Div (foldConstants a) (foldConstants b))
|
||||
foldConstants (Neg a) = foldNode (Neg (foldConstants a))
|
||||
foldConstants (BoundConstruct tid arguments) = BoundConstruct tid (map foldConstants arguments)
|
||||
foldConstants (BoundFunction fid tid arguments) = foldNode (BoundFunction fid tid (map foldConstants arguments))
|
||||
foldConstants (Gt a b) = foldNode (Gt (foldConstants a) (foldConstants b))
|
||||
foldConstants (Lt a b) = foldNode (Lt (foldConstants a) (foldConstants b))
|
||||
foldConstants (Eq a b) = foldNode (Eq (foldConstants a) (foldConstants b))
|
||||
|
||||
@@ -37,6 +37,10 @@ rewriteAggs :: [(String, Expr)] -> Expr -> Expr
|
||||
rewriteAggs aggs e = case [label | (label, agg) <- aggs, agg == e] of
|
||||
(label : _) -> Col label
|
||||
[] -> case e of
|
||||
Construct tid arguments -> Construct tid (map go arguments)
|
||||
BoundConstruct tid arguments -> BoundConstruct tid (map go arguments)
|
||||
FunctionCall name arguments -> FunctionCall name (map go arguments)
|
||||
BoundFunction fid tid arguments -> BoundFunction fid tid (map go arguments)
|
||||
Add a b -> Add (go a) (go b)
|
||||
Sub a b -> Sub (go a) (go b)
|
||||
Mul a b -> Mul (go a) (go b)
|
||||
|
||||
@@ -0,0 +1,125 @@
|
||||
module ChuSQL.Core.Engine.Normalization where
|
||||
|
||||
import ChuSQL.Core.Model (Column)
|
||||
import Data.List (nub, sort, subsequences, (\\))
|
||||
|
||||
-- 只读范式分析：声明验证、阿姆斯特朗闭包、候选键与分解建议。
|
||||
|
||||
type Attributes = [String]
|
||||
data Dependency = Dependency Attributes Attributes deriving (Eq, Show)
|
||||
data Verdict = Satisfied | Violated | Insufficient deriving (Eq, Show)
|
||||
data NormalForm = NF1 | NF2 | NF3 | BCNF deriving (Eq, Show)
|
||||
data Declaration = Declaration
|
||||
{ declaredKeys :: [Attributes]
|
||||
, dependencies :: [Dependency]
|
||||
, dependenciesComplete :: Bool
|
||||
, atomicAttributes :: Maybe Bool
|
||||
} deriving (Eq, Show)
|
||||
data Finding = Finding
|
||||
{ normalForm :: NormalForm
|
||||
, verdict :: Verdict
|
||||
, witnesses :: [Dependency]
|
||||
, condition :: String
|
||||
} deriving (Eq, Show)
|
||||
data Decomposition = Decomposition
|
||||
{ relations :: [Attributes]
|
||||
, losslessJoin :: Verdict
|
||||
, dependencyPreserving :: Verdict
|
||||
} deriving (Eq, Show)
|
||||
data Analysis = Analysis
|
||||
{ candidateKeys :: [Attributes]
|
||||
, findings :: [Finding]
|
||||
, suggestions :: [Decomposition]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- 规范化属性集合。
|
||||
canonical :: Attributes -> Attributes
|
||||
canonical = sort . nub
|
||||
|
||||
-- 判断属性集合包含关系。
|
||||
subset :: Attributes -> Attributes -> Bool
|
||||
subset xs ys = all (`elem` ys) xs
|
||||
|
||||
-- 用自反、增广和传递规则求闭包。
|
||||
attributeClosure :: [Dependency] -> Attributes -> Attributes
|
||||
attributeClosure f seed = fixed (canonical seed)
|
||||
where
|
||||
-- 迭代加入已蕴含的属性。
|
||||
fixed xs = let ys = canonical (xs ++ concat [b | Dependency a b <- f, subset a xs])
|
||||
in if xs == ys then xs else fixed ys
|
||||
|
||||
-- 判断声明是否蕴含依赖。
|
||||
implies :: [Dependency] -> Dependency -> Bool
|
||||
implies f (Dependency a b) = subset b (attributeClosure f a)
|
||||
|
||||
-- 枚举最小超键。
|
||||
keysOf :: Attributes -> [Dependency] -> [Attributes]
|
||||
keysOf attrs f = [x | x <- subsequences attrs, super x,
|
||||
all (not . super) [x \\ [a] | a <- x]]
|
||||
where
|
||||
-- 判断闭包是否覆盖关系。
|
||||
super x = subset attrs (attributeClosure f x)
|
||||
|
||||
-- 投影关系上的全部非平凡依赖。
|
||||
projectDependencies :: [Dependency] -> Attributes -> [Dependency]
|
||||
projectDependencies f attrs =
|
||||
[Dependency x [a] | x <- subsequences attrs,
|
||||
a <- attributeClosure f x, a `elem` attrs, a `notElem` x]
|
||||
|
||||
-- 验证声明并生成只读范式报告。
|
||||
analyzeNormalization :: [(String, Column)] -> Declaration -> Either String Analysis
|
||||
analyzeNormalization schema declaration
|
||||
| null attrs = Left "normalization: empty schema"
|
||||
| length attrs /= length schema = Left "normalization: duplicate columns"
|
||||
| length attrs > 12 = Left "normalization: exhaustive analysis supports at most 12 columns"
|
||||
| any invalidDependency supplied = Left "normalization: unknown or duplicate dependency attributes"
|
||||
| any invalidKey rawKeys = Left "normalization: unknown or duplicate key attributes"
|
||||
| any (`notElem` keys) normalizedKeys = Left "normalization: declared candidate key is not minimal"
|
||||
| otherwise = Right (Analysis keys results decompositions)
|
||||
where
|
||||
attrs = canonical (map fst schema)
|
||||
supplied = dependencies declaration
|
||||
rawKeys = declaredKeys declaration
|
||||
normalizedKeys = map canonical rawKeys
|
||||
f = supplied ++ [Dependency k attrs | k <- normalizedKeys]
|
||||
keys = keysOf attrs f
|
||||
prime = nub (concat keys)
|
||||
complete = dependenciesComplete declaration
|
||||
atomic = case atomicAttributes declaration of
|
||||
Just True -> Satisfied
|
||||
Just False -> Violated
|
||||
Nothing -> Insufficient
|
||||
allFDs = projectDependencies f attrs
|
||||
partial = [d | d@(Dependency x [a]) <- allFDs, a `notElem` prime,
|
||||
any (\k -> x /= k && subset x k) keys]
|
||||
third = [d | d@(Dependency x [a]) <- allFDs, a `notElem` prime,
|
||||
not (subset attrs (attributeClosure f x))]
|
||||
boyce = [d | d@(Dependency x _) <- allFDs,
|
||||
not (subset attrs (attributeClosure f x))]
|
||||
results = Finding NF1 atomic [] "attributes must have atomic domains; requires an explicit declaration" :
|
||||
[classify NF2 partial, classify NF3 third, classify BCNF boyce]
|
||||
decompositions = [split d | d <- take 1 boyce, complete, atomic == Satisfied]
|
||||
-- 校验字段集合。
|
||||
valid xs = length xs == length (canonical xs) && subset xs attrs
|
||||
-- 校验依赖声明。
|
||||
invalidDependency (Dependency a b) = not (valid a && valid b) || null b
|
||||
-- 校验候选键声明。
|
||||
invalidKey k = not (valid k)
|
||||
-- 结合声明完整性判定范式。
|
||||
classify nf ds = Finding nf status (if complete then ds else []) (rule nf)
|
||||
where
|
||||
status | atomic == Violated = Violated
|
||||
| atomic == Insufficient || not complete = Insufficient
|
||||
| null ds = Satisfied
|
||||
| otherwise = Violated
|
||||
-- 说明各范式的必要条件。
|
||||
rule NF1 = "attributes must have atomic domains"
|
||||
rule NF2 = "no nonprime attribute depends on a proper subset of any candidate key"
|
||||
rule NF3 = "each nontrivial dependency has a superkey determinant or a prime dependent"
|
||||
rule BCNF = "each nontrivial dependency has a superkey determinant"
|
||||
-- 按违反依赖生成一次无损分解。
|
||||
split (Dependency x y) = Decomposition parts Satisfied preservation
|
||||
where
|
||||
parts = [canonical (x ++ y), attrs \\ (y \\ x)]
|
||||
projected = concatMap (projectDependencies f) parts
|
||||
preservation = if all (implies projected) f then Satisfied else Violated
|
||||
@@ -0,0 +1,177 @@
|
||||
module ChuSQL.Core.Engine.Runtime.Binding
|
||||
( Expression (..), TypedExpression, expressionType, bindExpression, evaluateExpression
|
||||
, Plan (..), TypedPlan, planSchema, bindPlan, executePlan
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Engine.Runtime.Types
|
||||
import ChuSQL.Core.Engine.Runtime.Functions
|
||||
import Control.Monad (filterM)
|
||||
import Data.List (nub, sort)
|
||||
|
||||
-- 仅依据 schema 绑定表达式与查询，执行已解析的类型和函数身份。
|
||||
|
||||
-- | 表达未绑定的类型化语言
|
||||
data Expression = Literal TypeExpr RuntimeValue | Reference String | Apply String [Expression]
|
||||
| ListLiteral TypeExpr [Expression] | NothingLiteral TypeExpr | JustLiteral Expression
|
||||
| TupleLiteral [Expression] deriving (Show, Eq)
|
||||
|
||||
-- | 保存绑定后的表达式节点
|
||||
data ExpressionNode = Constant RuntimeValue | BoundReference String | BoundApply FunctionId [TypedExpression]
|
||||
| BoundList [TypedExpression] | BoundNothing | BoundJust TypedExpression | BoundTuple [TypedExpression]
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 保存表达式的确定类型
|
||||
data TypedExpression = TypedExpression TypeId ExpressionNode deriving (Show, Eq)
|
||||
|
||||
-- | 提取表达式类型身份
|
||||
expressionType :: TypedExpression -> TypeId
|
||||
expressionType (TypedExpression tid _) = tid
|
||||
|
||||
-- | 绑定类型、列与函数身份
|
||||
bindExpression :: TypeRegistry -> FunctionRegistry -> [(String, TypeId)] -> Expression -> Either String TypedExpression
|
||||
bindExpression types functions env expression = case expression of
|
||||
Literal ty value -> do
|
||||
tid <- descriptorId <$> resolveType types ty
|
||||
validateValue types tid value
|
||||
Right (TypedExpression tid (Constant value))
|
||||
Reference name -> case [tid | (key, tid) <- env, key == name] of
|
||||
[tid] -> describeType types tid >> Right (TypedExpression tid (BoundReference name))
|
||||
[] -> Left ("unknown column: " ++ name)
|
||||
_ -> Left ("ambiguous column: " ++ name)
|
||||
Apply name arguments -> do
|
||||
bound <- mapM bind arguments
|
||||
sig <- resolveFunction functions name (map expressionType bound)
|
||||
Right (TypedExpression (signatureResult sig) (BoundApply (signatureId sig) bound))
|
||||
ListLiteral child arguments -> do
|
||||
childId <- descriptorId <$> resolveType types child
|
||||
bound <- mapM bind arguments
|
||||
if all ((== childId) . expressionType) bound
|
||||
then compound (listType child) (BoundList bound)
|
||||
else Left "list element type mismatch"
|
||||
NothingLiteral child -> compound (maybeType child) BoundNothing
|
||||
JustLiteral argument -> do
|
||||
bound <- bind argument
|
||||
compound (maybeType (typeExpression (expressionType bound))) (BoundJust bound)
|
||||
TupleLiteral arguments -> do
|
||||
bound <- mapM bind arguments
|
||||
compound (tupleType (map (typeExpression . expressionType) bound)) (BoundTuple bound)
|
||||
where
|
||||
-- | 绑定当前作用域的子表达式
|
||||
bind = bindExpression types functions env
|
||||
-- | 校验并构造复合表达式
|
||||
compound ty node = do
|
||||
tid <- descriptorId <$> resolveType types ty
|
||||
Right (TypedExpression tid node)
|
||||
|
||||
-- | 执行已绑定表达式并校验输出
|
||||
evaluateExpression :: TypeRegistry -> FunctionRegistry -> [(String, RuntimeValue)] -> TypedExpression -> Either String RuntimeValue
|
||||
evaluateExpression types functions row (TypedExpression tid node) = do
|
||||
value <- case node of
|
||||
Constant v -> Right v
|
||||
BoundReference name -> case [v | (key, v) <- row, key == name] of
|
||||
[v] -> Right v
|
||||
[] -> Left ("missing bound column: " ++ name)
|
||||
_ -> Left ("duplicate bound column: " ++ name)
|
||||
BoundApply fid arguments -> mapM evaluate arguments >>= invokeFunction types functions fid
|
||||
BoundList arguments -> RList <$> mapM evaluate arguments
|
||||
BoundNothing -> Right (RMaybe Nothing)
|
||||
BoundJust argument -> RMaybe . Just <$> evaluate argument
|
||||
BoundTuple arguments -> RTuple <$> mapM evaluate arguments
|
||||
validateValue types tid value
|
||||
Right value
|
||||
where
|
||||
-- | 执行当前行的子表达式
|
||||
evaluate = evaluateExpression types functions row
|
||||
|
||||
-- | 表达未绑定的关系计划
|
||||
data Plan = TableScan String | SingleRow | Projection [(String, Expression)] Plan
|
||||
| Selection Expression Plan deriving (Show, Eq)
|
||||
|
||||
-- | 保存绑定后的关系节点
|
||||
data PlanNode = BoundScan String | BoundSingleRow | BoundProjection [(String, TypedExpression)] TypedPlan
|
||||
| BoundSelection TypedExpression TypedPlan deriving (Show, Eq)
|
||||
|
||||
-- | 保存输出 schema 和关系节点
|
||||
data TypedPlan = TypedPlan [(String, TypeId)] PlanNode deriving (Show, Eq)
|
||||
|
||||
-- | 提取计划的输出 schema
|
||||
planSchema :: TypedPlan -> [(String, TypeId)]
|
||||
planSchema (TypedPlan output _) = output
|
||||
|
||||
-- | 使用目录 schema 绑定查询计划
|
||||
bindPlan :: TypeRegistry -> FunctionRegistry -> [(String, [(String, TypeExpr)])] -> Plan -> Either String TypedPlan
|
||||
bindPlan types functions catalog plan = case plan of
|
||||
TableScan name -> case [columns | (key, columns) <- catalog, key == name] of
|
||||
[columns] -> do
|
||||
uniqueNames (map fst columns)
|
||||
bound <- mapM bindColumn columns
|
||||
Right (TypedPlan bound (BoundScan name))
|
||||
[] -> Left ("unknown table: " ++ name)
|
||||
_ -> Left ("ambiguous table: " ++ name)
|
||||
SingleRow -> Right (TypedPlan [] BoundSingleRow)
|
||||
Projection items source -> do
|
||||
child <- bind source
|
||||
uniqueNames (map fst items)
|
||||
bound <- mapM (bindItem (planSchema child)) items
|
||||
Right (TypedPlan [(name, expressionType value) | (name, value) <- bound] (BoundProjection bound child))
|
||||
Selection condition source -> do
|
||||
child <- bind source
|
||||
predicate <- bindExpression types functions (planSchema child) condition
|
||||
bool <- descriptorId <$> resolveType types boolType
|
||||
if expressionType predicate == bool
|
||||
then Right (TypedPlan (planSchema child) (BoundSelection predicate child))
|
||||
else Left "selection predicate must be Bool"
|
||||
where
|
||||
-- | 绑定子计划
|
||||
bind = bindPlan types functions catalog
|
||||
-- | 解析 schema 列的类型身份
|
||||
bindColumn (name, ty) = do
|
||||
tid <- descriptorId <$> resolveType types ty
|
||||
Right (name, tid)
|
||||
-- | 绑定投影项
|
||||
bindItem env (name, value) = do
|
||||
bound <- bindExpression types functions env value
|
||||
Right (name, bound)
|
||||
|
||||
-- | 拒绝重复输出列
|
||||
uniqueNames :: [String] -> Either String ()
|
||||
uniqueNames names
|
||||
| nub names == names = Right ()
|
||||
| otherwise = Left "duplicate schema column"
|
||||
|
||||
-- | 执行绑定计划并校验存储返回值
|
||||
executePlan :: TypeRegistry -> FunctionRegistry -> (String -> Either String [[(String, RuntimeValue)]])
|
||||
-> TypedPlan -> Either String [[(String, RuntimeValue)]]
|
||||
executePlan types functions scan (TypedPlan output node) = do
|
||||
rows <- case node of
|
||||
BoundScan name -> scan name
|
||||
BoundSingleRow -> Right [[]]
|
||||
BoundProjection items child -> do
|
||||
input <- executePlan types functions scan child
|
||||
mapM (project items) input
|
||||
BoundSelection condition child -> do
|
||||
input <- executePlan types functions scan child
|
||||
filterM (keep condition) input
|
||||
mapM_ (validateRow output) rows
|
||||
Right [[(name, value) | (name, _) <- output, Just value <- [lookup name row]] | row <- rows]
|
||||
where
|
||||
-- | 计算一行的投影项
|
||||
project items row = mapM (projectItem row) items
|
||||
-- | 计算命名输出项
|
||||
projectItem row (name, expression) = do
|
||||
value <- evaluateExpression types functions row expression
|
||||
Right (name, value)
|
||||
-- | 计算选择条件
|
||||
keep condition row = do
|
||||
value <- evaluateExpression types functions row condition
|
||||
case value of
|
||||
RBool result -> Right result
|
||||
_ -> Left "bound predicate returned a non-Bool value"
|
||||
-- | 校验存储行的完整 schema
|
||||
validateRow columns row
|
||||
| sort (map fst row) /= sort (map fst columns) = Left "storage row schema mismatch"
|
||||
| otherwise = mapM_ (validateColumn row) columns
|
||||
-- | 按列名校验返回值的类型
|
||||
validateColumn row (name, tid) = case lookup name row of
|
||||
Just value -> validateValue types tid value
|
||||
Nothing -> Left ("missing bound column: " ++ name)
|
||||
@@ -0,0 +1,83 @@
|
||||
module ChuSQL.Core.Engine.Runtime.Functions
|
||||
( FunctionId (..), FunctionSignature (..), FunctionRegistry
|
||||
, builtinFunctions, resolveFunction, resolveNullableFunction, functionSignature, invokeFunction
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Engine.Runtime.Types
|
||||
import Data.Char (toLower)
|
||||
|
||||
-- 内建函数的固定身份、签名解析和类型化调用。
|
||||
|
||||
-- | 标识稳定的内建函数
|
||||
newtype FunctionId = FunctionId Int deriving (Show, Eq, Ord)
|
||||
|
||||
-- | 描述已解析的函数签名
|
||||
data FunctionSignature = FunctionSignature
|
||||
{ signatureId :: FunctionId, signatureName :: String
|
||||
, signatureArguments :: [TypeId], signatureResult :: TypeId
|
||||
} deriving (Show, Eq)
|
||||
|
||||
-- | 保存函数签名和实现
|
||||
newtype FunctionRegistry = FunctionRegistry [(FunctionSignature, [RuntimeValue] -> Either String RuntimeValue)]
|
||||
|
||||
-- | 从内建元数据恢复函数注册表
|
||||
builtinFunctions :: TypeRegistry -> Either String FunctionRegistry
|
||||
builtinFunctions types = do
|
||||
int <- descriptorId <$> resolveType types intType
|
||||
bool <- descriptorId <$> resolveType types boolType
|
||||
string <- descriptorId <$> resolveType types stringType
|
||||
Right (FunctionRegistry
|
||||
[(FunctionSignature (FunctionId 1) "length" [string] int, stringLength)
|
||||
,(FunctionSignature (FunctionId 2) "not" [bool] bool, booleanNot)])
|
||||
|
||||
-- | 按名称和完整参数类型解析函数
|
||||
resolveFunction :: FunctionRegistry -> String -> [TypeId] -> Either String FunctionSignature
|
||||
resolveFunction (FunctionRegistry functions) name arguments =
|
||||
case [sig | (sig, _) <- functions, map toLower (signatureName sig) == map toLower name
|
||||
, signatureArguments sig == arguments] of
|
||||
[sig] -> Right sig
|
||||
[] -> Left ("no matching function signature: " ++ name)
|
||||
_ -> Left ("ambiguous function signature: " ++ name)
|
||||
|
||||
-- | 按可空 SQL 参数解析确定签名
|
||||
resolveNullableFunction :: FunctionRegistry -> String -> [Maybe TypeId] -> Either String FunctionSignature
|
||||
resolveNullableFunction (FunctionRegistry functions) name arguments =
|
||||
case [sig | (sig, _) <- functions, map toLower (signatureName sig) == map toLower name
|
||||
, length arguments == length (signatureArguments sig)
|
||||
, and (zipWith matches arguments (signatureArguments sig))] of
|
||||
[sig] -> Right sig
|
||||
[] -> Left ("no matching function signature: " ++ name)
|
||||
_ -> Left ("ambiguous function signature: " ++ name)
|
||||
where
|
||||
-- | 匹配具体参数或未定型 NULL
|
||||
matches Nothing _ = True
|
||||
matches (Just supplied) expected = supplied == expected
|
||||
|
||||
-- | 按固定身份查找函数签名
|
||||
functionSignature :: FunctionRegistry -> FunctionId -> Either String FunctionSignature
|
||||
functionSignature (FunctionRegistry functions) fid = case [sig | (sig, _) <- functions, signatureId sig == fid] of
|
||||
[sig] -> Right sig
|
||||
_ -> Left ("unknown function identity: " ++ show fid)
|
||||
|
||||
-- | 校验参数并执行已解析的函数
|
||||
invokeFunction :: TypeRegistry -> FunctionRegistry -> FunctionId -> [RuntimeValue] -> Either String RuntimeValue
|
||||
invokeFunction types (FunctionRegistry functions) fid values =
|
||||
case [(sig, implementation) | (sig, implementation) <- functions, signatureId sig == fid] of
|
||||
[(sig, implementation)]
|
||||
| length values == length (signatureArguments sig) -> do
|
||||
sequence_ (zipWith (validateValue types) (signatureArguments sig) values)
|
||||
result <- implementation values
|
||||
validateValue types (signatureResult sig) result
|
||||
Right result
|
||||
| otherwise -> Left "function argument count mismatch"
|
||||
_ -> Left ("unknown function identity: " ++ show fid)
|
||||
|
||||
-- | 计算字符串字符个数
|
||||
stringLength :: [RuntimeValue] -> Either String RuntimeValue
|
||||
stringLength [RString text] = Right (RInt (length text))
|
||||
stringLength _ = Left "length expects String"
|
||||
|
||||
-- | 计算布尔取反
|
||||
booleanNot :: [RuntimeValue] -> Either String RuntimeValue
|
||||
booleanNot [RBool value] = Right (RBool (not value))
|
||||
booleanNot _ = Left "not expects Bool"
|
||||
@@ -0,0 +1,65 @@
|
||||
module ChuSQL.Core.Engine.Runtime.Query
|
||||
( BoundQuery, QueryType (..), queryTypes, bindQuery, executeQueryM
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Engine.Algebra.Eval (evalRelOpM)
|
||||
import ChuSQL.Core.Engine.Algebra.Op (RelOp)
|
||||
import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
|
||||
import ChuSQL.Core.Engine.Algebra.Planner (translate)
|
||||
import ChuSQL.Core.Engine.Semantic (prepare, querySchema)
|
||||
import ChuSQL.Core.Engine.Syntax.AST (Statement)
|
||||
import ChuSQL.Core.Engine.Storage (MonadStorage)
|
||||
import ChuSQL.Core.Engine.Runtime.SQL (sqlType)
|
||||
import ChuSQL.Core.Engine.Runtime.Types (TypeId)
|
||||
import ChuSQL.Core.Model
|
||||
|
||||
-- SQL 查询绑定边界：保存解析后的类型、函数身份及输出 schema。
|
||||
|
||||
-- | 保存运行时或兼容列类型
|
||||
data QueryType = RuntimeType TypeId | CompatibilityType ColumnType | NullType deriving (Show, Eq)
|
||||
|
||||
-- | 保存仅由 schema 绑定的执行计划
|
||||
data BoundQuery = BoundQuery Database [(String, Column)] [(String, QueryType)] RelOp
|
||||
|
||||
-- | 查询绑定计划的输出类型身份
|
||||
queryTypes :: BoundQuery -> [(String, QueryType)]
|
||||
queryTypes (BoundQuery _ _ types _) = types
|
||||
|
||||
-- | 绑定 SQL 查询并优化确定的计划
|
||||
bindQuery :: Database -> Statement -> Either String BoundQuery
|
||||
bindQuery catalog statement = do
|
||||
let schemaOnly = [(name, table {tableRows = []}) | (name, table) <- catalog]
|
||||
resolved <- prepare schemaOnly statement
|
||||
columns <- querySchema schemaOnly resolved
|
||||
plan <- translate resolved
|
||||
types <- mapM typeOf columns
|
||||
Right (BoundQuery schemaOnly columns types (optimize schemaOnly plan))
|
||||
where
|
||||
-- | 解析输出列的运行时身份
|
||||
typeOf (name, column) = do
|
||||
ty <- bindingType (columnType column)
|
||||
Right (name, ty)
|
||||
-- | 保留阶段外类型的兼容表示
|
||||
bindingType CNull = Right NullType
|
||||
bindingType CDate = Right (CompatibilityType CDate)
|
||||
bindingType CTimestamp = Right (CompatibilityType CTimestamp)
|
||||
bindingType CBlob = Right (CompatibilityType CBlob)
|
||||
bindingType ty@(CDomain _ base)
|
||||
| typeClassOf base == TemporalClass || base == CBlob = Right (CompatibilityType ty)
|
||||
bindingType ty = RuntimeType <$> sqlType ty
|
||||
|
||||
-- | 执行绑定查询并校验输出类型
|
||||
executeQueryM :: MonadStorage m => BoundQuery -> m (Either String [Row])
|
||||
executeQueryM (BoundQuery catalog columns _ plan) = do
|
||||
result <- evalRelOpM catalog plan
|
||||
pure (result >>= mapM validateRow)
|
||||
where
|
||||
-- | 校验完整输出行而不重新解析函数
|
||||
validateRow row
|
||||
| map fst row /= map fst columns = Left "bound query output schema mismatch"
|
||||
| otherwise = mapM validateColumn (zip columns row)
|
||||
-- | 校验输出列的物理值
|
||||
validateColumn ((name, column), (_, value))
|
||||
| columnType column == CNull, value == VNull = Right (name, value)
|
||||
| valueFits (columnType column) value = Right (name, value)
|
||||
| otherwise = Left ("bound query output type mismatch: " ++ name)
|
||||
@@ -0,0 +1,92 @@
|
||||
module ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, invokeSQLFunction, sqlType, constructSQLValue) where
|
||||
|
||||
import ChuSQL.Core.Engine.Runtime.Types
|
||||
import ChuSQL.Core.Engine.Runtime.Functions
|
||||
import ChuSQL.Core.Model (ColumnType (..), Value (..))
|
||||
|
||||
-- SQL 现有标量表示与已解析运行时函数之间的类型边界。
|
||||
|
||||
-- | 解析 SQL 标量调用的固定签名
|
||||
resolveSQLFunction :: String -> [Maybe ColumnType] -> Either String FunctionSignature
|
||||
resolveSQLFunction name arguments = do
|
||||
functions <- builtinFunctions builtinTypes
|
||||
types <- mapM (traverse sqlType) arguments
|
||||
resolveNullableFunction functions name types
|
||||
|
||||
-- | 解析现有标量列的逻辑类型
|
||||
sqlType :: ColumnType -> Either String TypeId
|
||||
sqlType (CDomain _ base) = sqlType base
|
||||
sqlType (CRuntime tid) = describeType builtinTypes tid >> Right tid
|
||||
sqlType ty = do
|
||||
expression <- case ty of
|
||||
CInt -> Right intType
|
||||
CBigInt -> Right intType
|
||||
CSmallInt -> Right intType
|
||||
CFloat -> Right doubleType
|
||||
CDouble -> Right doubleType
|
||||
CDecimal{} -> Right doubleType
|
||||
CBool -> Right boolType
|
||||
CStr -> Right stringType
|
||||
CVarchar{} -> Right stringType
|
||||
CChar{} -> Right stringType
|
||||
_ -> Left ("unsupported runtime function argument type: " ++ show ty)
|
||||
descriptorId <$> resolveType builtinTypes expression
|
||||
|
||||
-- | 将函数输出类型映射为 SQL schema
|
||||
sqlResultType :: TypeId -> Either String ColumnType
|
||||
sqlResultType tid
|
||||
| typeExpression tid == intType = Right CInt
|
||||
| typeExpression tid == doubleType = Right CDouble
|
||||
| typeExpression tid == boolType = Right CBool
|
||||
| typeExpression tid == stringType = Right CStr
|
||||
| otherwise = Left "runtime function result needs a composite SQL representation"
|
||||
|
||||
-- | 执行固定身份的 SQL 标量函数
|
||||
invokeSQLFunction :: FunctionId -> TypeId -> [Value] -> Either String Value
|
||||
invokeSQLFunction fid expected values = do
|
||||
functions <- builtinFunctions builtinTypes
|
||||
sig <- functionSignature functions fid
|
||||
if signatureResult sig /= expected then Left "bound function result identity mismatch"
|
||||
else if length values /= length (signatureArguments sig) then Left "function argument count mismatch"
|
||||
else do
|
||||
sequence_ (zipWith validateArgument (signatureArguments sig) values)
|
||||
if VNull `elem` values then Right VNull else do
|
||||
arguments <- mapM runtimeValue values
|
||||
result <- invokeFunction builtinTypes functions fid arguments
|
||||
sqlValue result
|
||||
where
|
||||
-- | 校验具体参数并保留 SQL NULL
|
||||
validateArgument _ VNull = Right ()
|
||||
validateArgument tid value = runtimeValue value >>= validateValue builtinTypes tid
|
||||
|
||||
-- | 转换现有 SQL 标量值
|
||||
runtimeValue :: Value -> Either String RuntimeValue
|
||||
runtimeValue (VInt n) = Right (RInt n)
|
||||
runtimeValue (VFloat n) = Right (RDouble n)
|
||||
runtimeValue (VBool b) = Right (RBool b)
|
||||
runtimeValue (VStr text) = Right (RString text)
|
||||
runtimeValue (VRuntime tid value) = validateValue builtinTypes tid value >> Right value
|
||||
runtimeValue VNull = Left "untyped SQL NULL has no runtime scalar value"
|
||||
|
||||
-- | 转换运行时标量结果
|
||||
sqlValue :: RuntimeValue -> Either String Value
|
||||
sqlValue (RInt n) = Right (VInt n)
|
||||
sqlValue (RDouble n) = Right (VFloat n)
|
||||
sqlValue (RBool b) = Right (VBool b)
|
||||
sqlValue (RString text) = Right (VStr text)
|
||||
sqlValue _ = Left "composite runtime result has no SQL scalar representation"
|
||||
|
||||
-- | 按已解析构造器生成类型化值
|
||||
constructSQLValue :: TypeId -> [Value] -> Either String Value
|
||||
constructSQLValue tid values = do
|
||||
arguments <- mapM runtimeValue values
|
||||
value <- case typeExpression tid of
|
||||
TypeApply (TypeConstructorId 5) [_] -> Right (RList arguments)
|
||||
TypeApply (TypeConstructorId 6) [_] -> case arguments of
|
||||
[] -> Right (RMaybe Nothing)
|
||||
[argument] -> Right (RMaybe (Just argument))
|
||||
_ -> Left "Maybe constructor expects zero or one argument"
|
||||
TypeApply (TypeConstructorId 7) _ -> Right (RTuple arguments)
|
||||
_ -> Left "type is not a composite constructor"
|
||||
validateValue builtinTypes tid value
|
||||
Right (VRuntime tid value)
|
||||
@@ -0,0 +1,5 @@
|
||||
module ChuSQL.Core.Engine.Runtime.Types (module ChuSQL.Core.Runtime) where
|
||||
|
||||
import ChuSQL.Core.Runtime
|
||||
|
||||
-- 导出共享的运行时类型身份和物理编码契约。
|
||||
@@ -1,9 +1,12 @@
|
||||
module ChuSQL.Core.Engine.Semantic (check, prepare) where
|
||||
module ChuSQL.Core.Engine.Semantic (check, prepare, prepareRowExpression, querySchema) where
|
||||
|
||||
import ChuSQL.Core.Engine.Algebra.Expr (bareColumns, colsInExpr, hasAggregate)
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
|
||||
import ChuSQL.Core.Engine.Runtime.Functions (FunctionSignature (..), builtinFunctions, functionSignature)
|
||||
import ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, sqlType)
|
||||
import ChuSQL.Core.Engine.Runtime.Types
|
||||
import Data.Char (isAlphaNum, isAscii, toLower)
|
||||
import Data.List (intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub)
|
||||
|
||||
@@ -21,6 +24,12 @@ prefixColumns mAlias cols = [(prefix ++ c, ty) | (c, ty) <- cols]
|
||||
where
|
||||
prefix = maybe "" (++ ".") mAlias
|
||||
|
||||
-- | 从 schema 推导查询输出列
|
||||
querySchema :: Database -> Statement -> Either String [(String, Column)]
|
||||
querySchema db statement = do
|
||||
columns <- inferSubqueryOutput db (Scope [] []) (Subquery statement [])
|
||||
Right [(name, plainColumn (derivedType ty)) | (name, ty) <- columns]
|
||||
|
||||
-- | 检查期的作用域：本层优先，外层兜底
|
||||
data Scope = Scope
|
||||
{ scopeInner :: [(String, Column)]
|
||||
@@ -103,6 +112,7 @@ checkGrouping env keys items
|
||||
| null keys && not (any (hasAggregate . snd) items) = Right ()
|
||||
| otherwise = do
|
||||
checkColumns "GROUP BY" env keys
|
||||
mapM_ (checkRuntimeColumn "GROUP BY" env) keys
|
||||
mapM_ okCol (nub (concatMap (bareColumns . snd) items))
|
||||
where
|
||||
-- | 这一列能不能出现在分组查询里
|
||||
@@ -127,6 +137,23 @@ inferExpr _ _ _ (LitBool _) = Right (InferType CBool)
|
||||
inferExpr _ _ _ (LitDate _) = Right (InferType CDate)
|
||||
inferExpr _ _ _ (LitTimestamp _) = Right (InferType CTimestamp)
|
||||
inferExpr _ _ _ (LitBlob _) = Right (InferType CBlob)
|
||||
inferExpr db place env (Construct ty arguments) = InferType . CRuntime <$> inferConstruction db place env ty arguments
|
||||
inferExpr db place env (BoundConstruct tid arguments) = do
|
||||
inferred <- inferConstruction db place env (typeExpression tid) arguments
|
||||
if inferred == tid then Right (InferType (CRuntime tid)) else Left "constructor result identity mismatch"
|
||||
inferExpr _ _ _ (RuntimeLiteral tid value) = validateValue builtinTypes tid value >> Right (InferType (CRuntime tid))
|
||||
inferExpr db place env (FunctionCall name arguments) = do
|
||||
inferred <- mapM (inferExpr db place env) arguments
|
||||
sig <- resolveSQLFunction name (map inferredArgument inferred)
|
||||
InferType <$> sqlResultType (signatureResult sig)
|
||||
inferExpr db place env (BoundFunction fid tid arguments) = do
|
||||
functions <- builtinFunctions builtinTypes
|
||||
expected <- functionSignature functions fid
|
||||
inferred <- mapM (inferExpr db place env) arguments
|
||||
resolved <- resolveSQLFunction (signatureName expected) (map inferredArgument inferred)
|
||||
if signatureId resolved == fid && signatureResult resolved == tid
|
||||
then InferType <$> sqlResultType tid
|
||||
else Left "bound function signature identity mismatch"
|
||||
inferExpr db place env (Add a b) = arithmetic db place env a b
|
||||
inferExpr db place env (Sub a b) = arithmetic db place env a b
|
||||
inferExpr db place env (Mul a b) = arithmetic db place env a b
|
||||
@@ -160,8 +187,8 @@ inferExpr db place env (AvgOf a) = do
|
||||
InferType x
|
||||
| numericType x -> Right (InferType CFloat)
|
||||
| otherwise -> Left (place ++ ": AVG needs a number, got " ++ typeLabel x)
|
||||
inferExpr db place env (MinOf a) = aggregateArg db place env a
|
||||
inferExpr db place env (MaxOf a) = aggregateArg db place env a
|
||||
inferExpr db place env (MinOf a) = aggregateArg db place env a >>= requireOrdering "MIN"
|
||||
inferExpr db place env (MaxOf a) = aggregateArg db place env a >>= requireOrdering "MAX"
|
||||
inferExpr db place env (ScalarSub sq) = do
|
||||
cols <- inferSubqueryOutput db env sq
|
||||
case cols of
|
||||
@@ -386,18 +413,18 @@ ddlTargets statement = case statement of
|
||||
-- | 从 schema 解析列上的命名类型
|
||||
resolveDomainTypes :: Database -> Statement -> Either String Statement
|
||||
resolveDomainTypes db statement = case statement of
|
||||
CreateDomain name base -> CreateDomain name <$> resolveType base
|
||||
CreateDomain name base -> CreateDomain name <$> resolveDomainType base
|
||||
CreateTable name cols -> CreateTable name <$> mapM resolveColumnType cols
|
||||
AddColumn name col -> AddColumn name <$> resolveColumnType col
|
||||
AlterColumnType name col ty -> AlterColumnType name col <$> resolveType ty
|
||||
AlterColumnType name col ty -> AlterColumnType name col <$> resolveDomainType ty
|
||||
_ -> Right statement
|
||||
where
|
||||
-- | 解析一列的类型
|
||||
resolveColumnType (name, col) = do
|
||||
ty <- resolveType (columnType col)
|
||||
ty <- resolveDomainType (columnType col)
|
||||
Right (name, col {columnType = ty})
|
||||
-- | 从类型目录取基础类型
|
||||
resolveType = resolveWith []
|
||||
resolveDomainType = resolveWith []
|
||||
-- | 递归解析类型并拒绝循环定义
|
||||
resolveWith seen (CDomain name _)
|
||||
| map toLower name `elem` seen = Left ("cyclic domain definition: " ++ name)
|
||||
@@ -427,6 +454,7 @@ checkResolvedWith db outer q = case q of
|
||||
checkColumns "SELECT" full cols
|
||||
checkGrouping full groupBy (map (\c -> (c, Col c)) cols)
|
||||
checkColumns "ORDER BY" full (map fst orderBy)
|
||||
mapM_ (checkRuntimeColumn "ORDER BY" full . fst) orderBy
|
||||
mapM_ (checkNoAggregate "WHERE") mWhere
|
||||
mapM_ (checkBool db "WHERE" full) mWhere
|
||||
SelectExpr items fromC mWhere groupBy orderBy _ -> do
|
||||
@@ -434,7 +462,7 @@ checkResolvedWith db outer q = case q of
|
||||
let full = Scope env outer
|
||||
mapM_ (\item -> () <$ inferExpr db "SELECT" full (snd item)) items
|
||||
checkGrouping full groupBy (items ++ [(c, Col c) | (c, _) <- orderBy, c `notElem` map fst items])
|
||||
mapM_ (checkOrder full items . fst) orderBy
|
||||
mapM_ (checkOrder db full items . fst) orderBy
|
||||
mapM_ (checkNoAggregate "WHERE") mWhere
|
||||
mapM_ (checkBool db "WHERE" full) mWhere
|
||||
Insert tbl cols rows -> do
|
||||
@@ -468,7 +496,7 @@ checkResolvedWith db outer q = case q of
|
||||
CreateIndex tbl col -> do
|
||||
t <- lookupTable db tbl
|
||||
if col `elem` tableCols' t
|
||||
then Right ()
|
||||
then checkRuntimeColumn "CREATE INDEX" (Scope (tableCols t) []) col
|
||||
else Left ("CREATE INDEX: unknown column: " ++ col)
|
||||
DropIndex tbl col -> do
|
||||
t <- lookupTable db tbl
|
||||
@@ -581,14 +609,22 @@ checkColumnDefs names cols = do
|
||||
mapM_ (checkTypeParameters . columnType . snd) cols
|
||||
mapM_ (\(_, c) -> mapM_ (checkDefault c) (columnDefault c)) cols
|
||||
mapM_ (\(_, c) -> checkAutoIncrement c) cols
|
||||
mapM_ checkRuntimeKey cols
|
||||
if length [() | (_, c) <- cols, columnAutoIncrement c] > 1
|
||||
then Left "CREATE TABLE: at most one AUTO_INCREMENT column is allowed"
|
||||
else Right ()
|
||||
checkChecks names cols
|
||||
where
|
||||
-- | 拒绝缺少能力实现的运行时键
|
||||
checkRuntimeKey (_, column)
|
||||
| typeClassOf (columnType column) == RuntimeClass
|
||||
, columnUnique column || columnPrimaryKey column = Left "runtime type key capability is not registered"
|
||||
| otherwise = Right ()
|
||||
|
||||
-- | 校验列类型的长度和精度参数
|
||||
checkTypeParameters :: ColumnType -> Either String ()
|
||||
checkTypeParameters (CDomain _ base) = checkTypeParameters base
|
||||
checkTypeParameters (CRuntime tid) = () <$ describeType builtinTypes tid
|
||||
checkTypeParameters CNull = Left "NULL is only valid as an inferred query output"
|
||||
checkTypeParameters (CDecimal p s)
|
||||
| p <= 0 || p > 308 || s < 0 || s > p = Left "invalid decimal precision or scale"
|
||||
@@ -707,6 +743,17 @@ resolveExpr ::
|
||||
Expr ->
|
||||
Either String Expr
|
||||
resolveExpr db env outer f e = case e of
|
||||
Construct ty arguments -> do
|
||||
tid <- inferConstruction db "constructor" (Scope env outer) ty arguments
|
||||
bound <- mapM (resolveExpr db env outer f) arguments
|
||||
Right (BoundConstruct tid bound)
|
||||
BoundConstruct tid arguments -> BoundConstruct tid <$> mapM (resolveExpr db env outer f) arguments
|
||||
FunctionCall name arguments -> do
|
||||
inferred <- mapM (inferExpr db "function" (Scope env outer)) arguments
|
||||
sig <- resolveSQLFunction name (map inferredArgument inferred)
|
||||
bound <- mapM (resolveExpr db env outer f) arguments
|
||||
Right (BoundFunction (signatureId sig) (signatureResult sig) bound)
|
||||
BoundFunction fid tid arguments -> BoundFunction fid tid <$> mapM (resolveExpr db env outer f) arguments
|
||||
Col c -> Col <$> f c
|
||||
Add a b -> binary Add a b
|
||||
Sub a b -> binary Sub a b
|
||||
@@ -739,6 +786,36 @@ resolveExpr db env outer f e = case e of
|
||||
-- | 递归处理两个子表达式
|
||||
binary ctor a b = ctor <$> resolveExpr db env outer f a <*> resolveExpr db env outer f b
|
||||
|
||||
-- | 校验具体构造器和参数逻辑类型
|
||||
inferConstruction :: Database -> String -> Scope -> TypeExpr -> [Expr] -> Either String TypeId
|
||||
inferConstruction db place env ty@(TypeApply cid parameters) arguments = do
|
||||
descriptor <- resolveType builtinTypes ty
|
||||
expected <- case (cid, parameters) of
|
||||
(TypeConstructorId 5, [child]) -> Right (replicate (length arguments) child)
|
||||
(TypeConstructorId 6, [child]) | length arguments <= 1 -> Right (replicate (length arguments) child)
|
||||
(TypeConstructorId 7, fields) | length fields == length arguments -> Right fields
|
||||
_ -> Left "composite constructor argument count mismatch"
|
||||
inferred <- mapM (inferExpr db place env) arguments
|
||||
supplied <- mapM argumentIdentity inferred
|
||||
required <- mapM (fmap descriptorId . resolveType builtinTypes) expected
|
||||
if supplied == required then Right (descriptorId descriptor) else Left "composite constructor argument type mismatch"
|
||||
where
|
||||
-- | 解析非空参数的逻辑类型身份
|
||||
argumentIdentity InferNull = Left "SQL NULL needs Maybe construction inside a runtime value"
|
||||
argumentIdentity (InferType column) = sqlType column
|
||||
|
||||
-- | 使用单行 schema 绑定表达式
|
||||
prepareRowExpression :: [(String, Column)] -> Expr -> Either String Expr
|
||||
prepareRowExpression columns expression = do
|
||||
bound <- resolveExpr [] columns [] (nameIn columns "expression") expression
|
||||
_ <- inferExpr [] "expression" (Scope columns []) bound
|
||||
Right bound
|
||||
|
||||
-- | 将推导类型转换为可空参数类型
|
||||
inferredArgument :: InferredType -> Maybe ColumnType
|
||||
inferredArgument InferNull = Nothing
|
||||
inferredArgument (InferType ty) = Just ty
|
||||
|
||||
-- | 解析子查询，并记下它引用的外层列
|
||||
resolveSubquery :: Database -> [(String, Column)] -> Subquery -> Either String Subquery
|
||||
resolveSubquery db outer sq = do
|
||||
@@ -822,12 +899,25 @@ resolveSelect db q@SelectExpr{} = resolveQuery db [] q (selectItems q)
|
||||
resolveSelect _ q = Right q
|
||||
|
||||
-- | 检查排序输出别名或来源列
|
||||
checkOrder :: Scope -> [(String, Expr)] -> String -> Either String ()
|
||||
checkOrder env items column = case [e | (label, e) <- items, label == column] of
|
||||
[] -> checkColumns "ORDER BY" env [column]
|
||||
[_] -> Right ()
|
||||
checkOrder :: Database -> Scope -> [(String, Expr)] -> String -> Either String ()
|
||||
checkOrder db env items column = case [e | (label, e) <- items, label == column] of
|
||||
[] -> checkRuntimeColumn "ORDER BY" env column
|
||||
[expression] -> () <$ (inferExpr db "ORDER BY" env expression >>= requireOrdering "ORDER BY")
|
||||
_ -> Left ("ORDER BY: ambiguous projection alias: " ++ column)
|
||||
|
||||
-- | 校验列已有排序能力
|
||||
checkRuntimeColumn :: String -> Scope -> String -> Either String ()
|
||||
checkRuntimeColumn place env column = do
|
||||
(_, definition) <- scopeAt place env column
|
||||
() <$ requireOrdering place (InferType (columnType definition))
|
||||
|
||||
-- | 拒绝尚未注册能力的复合类型
|
||||
requireOrdering :: String -> InferredType -> Either String InferredType
|
||||
requireOrdering place inferred@(InferType ty)
|
||||
| typeClassOf ty == RuntimeClass = Left (place ++ ": runtime type capability is not registered")
|
||||
| otherwise = Right inferred
|
||||
requireOrdering _ inferred = Right inferred
|
||||
|
||||
-- | 解析投影、条件、排序与连接引用
|
||||
resolveQuery :: Database -> [(String, Column)] -> Statement -> [(String, Expr)] -> Either String Statement
|
||||
resolveQuery db outer q items = do
|
||||
|
||||
@@ -1,6 +1,8 @@
|
||||
module ChuSQL.Core.Engine.Syntax.AST (Statement (..), FromClause (..), JoinKind (..), Expr (..), Subquery (..), Quantifier (..), CompareOp (..), SortDir (..), makeSelect) where
|
||||
|
||||
import ChuSQL.Core.Model (Column (..), ColumnType, Value (..))
|
||||
import ChuSQL.Core.Engine.Runtime.Types (TypeId, TypeExpr, RuntimeValue)
|
||||
import ChuSQL.Core.Engine.Runtime.Functions (FunctionId)
|
||||
|
||||
-- 语法树：语句、数据来源、条件表达式、排序方向。
|
||||
|
||||
@@ -112,6 +114,11 @@ data CompareOp
|
||||
-- | 条件表达式：列、字面量、算术、比较、逻辑、聚合与子查询
|
||||
data Expr
|
||||
= Col String
|
||||
| FunctionCall String [Expr]
|
||||
| BoundFunction FunctionId TypeId [Expr]
|
||||
| Construct TypeExpr [Expr]
|
||||
| BoundConstruct TypeId [Expr]
|
||||
| RuntimeLiteral TypeId RuntimeValue
|
||||
| LitNull
|
||||
| LitInt Int
|
||||
| LitFloat Double
|
||||
|
||||
@@ -5,6 +5,7 @@ module ChuSQL.Core.Engine.Syntax.Parser (parseStatement, parseExpression) where
|
||||
import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), plainColumn)
|
||||
import ChuSQL.Core.Engine.Builtin (Builtin (..), builtinName, builtinNames, builtinNode, compareNode)
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import ChuSQL.Core.Engine.Runtime.Types
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
|
||||
import Data.Char (isAlpha, isAlphaNum, isHexDigit, isSpace, toLower, toUpper)
|
||||
@@ -167,6 +168,8 @@ atom =
|
||||
, LitInt <$> integer
|
||||
, LitStr <$> stringLit
|
||||
, try aggregateCall
|
||||
, try constructorCall
|
||||
, try scalarFunctionCall
|
||||
, try existsPredicate
|
||||
, Col <$> qualifiedName
|
||||
, try scalarSubquery
|
||||
@@ -202,6 +205,33 @@ inPredicate = do
|
||||
subquerySelect :: Parser Subquery
|
||||
subquerySelect = Subquery <$> queryStatement <*> pure []
|
||||
|
||||
-- | 读取带具体类型参数的构造器
|
||||
constructorCall :: Parser Expr
|
||||
constructorCall = do
|
||||
cid <- (TypeConstructorId 5 <$ keyword "list") <|> (TypeConstructorId 6 <$ keyword "maybe")
|
||||
<|> (TypeConstructorId 7 <$ keyword "tuple")
|
||||
arguments <- between (symbol "<") (symbol ">") (sepBy runtimeTypeP (symbol ","))
|
||||
values <- between (symbol "(") (symbol ")") (sepBy expr (symbol ","))
|
||||
pure (Construct (TypeApply cid arguments) values)
|
||||
|
||||
-- | 解析运行时逻辑类型语法
|
||||
runtimeTypeP :: Parser TypeExpr
|
||||
runtimeTypeP = choice
|
||||
[ intType <$ keyword "int", doubleType <$ keyword "double", boolType <$ keyword "bool"
|
||||
, stringType <$ keyword "string", stringType <$ keyword "str", stringType <$ keyword "text"
|
||||
, listType <$> between (symbol "[") (symbol "]") runtimeTypeP
|
||||
, listType <$> (keyword "list" *> runtimeTypeP)
|
||||
, maybeType <$> (keyword "maybe" *> runtimeTypeP)
|
||||
, tupleType <$> between (symbol "(") (symbol ")") (sepBy runtimeTypeP (symbol ","))
|
||||
]
|
||||
|
||||
-- | 读取待绑定的标量函数调用
|
||||
scalarFunctionCall :: Parser Expr
|
||||
scalarFunctionCall = do
|
||||
name <- identifier
|
||||
arguments <- between (symbol "(") (symbol ")") (sepBy expr (symbol ","))
|
||||
pure (FunctionCall name arguments)
|
||||
|
||||
-- | 聚合调用：名称与节点都由内置函数表给出
|
||||
aggregateCall :: Parser Expr
|
||||
aggregateCall = choice (countAll : map named builtinNames)
|
||||
@@ -480,7 +510,9 @@ alterUserStatement = do
|
||||
-- | 读身份属性开关
|
||||
identityAttribute :: Parser (String, Bool)
|
||||
identityAttribute = choice
|
||||
[ ("system_catalog_manager", True) <$ keyword "system_catalog_manager"
|
||||
[ ("allow_sudo_auth", True) <$ keyword "allow_sudo_auth"
|
||||
, ("allow_sudo_auth", False) <$ keyword "noallow_sudo_auth"
|
||||
, ("system_catalog_manager", True) <$ keyword "system_catalog_manager"
|
||||
, ("system_catalog_manager", False) <$ keyword "nosystem_catalog_manager"
|
||||
, ("login", True) <$ keyword "login", ("login", False) <$ keyword "nologin"
|
||||
, ("superuser", True) <$ keyword "superuser", ("superuser", False) <$ keyword "nosuperuser"
|
||||
@@ -525,12 +557,16 @@ privilegeName =
|
||||
, "INSERT" <$ keyword "insert"
|
||||
, "UPDATE" <$ keyword "update"
|
||||
, "DELETE" <$ keyword "delete"
|
||||
, "CONNECT" <$ keyword "connect"
|
||||
, "CREATE" <$ keyword "create"
|
||||
, "ALL" <$ keyword "all"
|
||||
]
|
||||
|
||||
-- | ON 后面的授权对象：* 或一张表
|
||||
grantObject :: Parser String
|
||||
grantObject = ("*" <$ symbol "*") <|> tableName
|
||||
grantObject = try (("database:" ++) <$> (keyword "database" *> identifier))
|
||||
<|> try ((++ ".*") <$> (identifier <* symbol "." <* symbol "*"))
|
||||
<|> ("*" <$ symbol "*") <|> (optional (keyword "table") *> tableName)
|
||||
|
||||
-- | 可选的 WITH GRANT OPTION
|
||||
grantOption :: Parser Bool
|
||||
@@ -597,7 +633,8 @@ sizeParen = try (between (symbol "(") (symbol ")") integer)
|
||||
columnTypeP :: Parser ColumnType
|
||||
columnTypeP =
|
||||
choice
|
||||
[ keyword "integer" >> pure CInt
|
||||
[ try runtimeColumnType
|
||||
, keyword "integer" >> pure CInt
|
||||
, keyword "int" >> pure CInt
|
||||
, keyword "bigint" >> pure CBigInt
|
||||
, keyword "smallint" >> pure CSmallInt
|
||||
@@ -619,6 +656,20 @@ columnTypeP =
|
||||
, (\name -> CDomain (map toLower name) CStr) <$> identifier
|
||||
]
|
||||
|
||||
-- | 解析复合列的稳定类型身份
|
||||
runtimeColumnType :: Parser ColumnType
|
||||
runtimeColumnType = do
|
||||
expression <- choice
|
||||
[ listType <$> between (symbol "[") (symbol "]") runtimeTypeP
|
||||
, listType <$> (keyword "list" *> runtimeTypeP)
|
||||
, maybeType <$> (keyword "maybe" *> runtimeTypeP)
|
||||
, tupleType <$> between (symbol "(") (symbol ")") (sepBy runtimeTypeP (symbol ","))
|
||||
, stringType <$ keyword "string"
|
||||
]
|
||||
case resolveType builtinTypes expression of
|
||||
Left err -> fail err
|
||||
Right descriptor -> pure (CRuntime (descriptorId descriptor))
|
||||
|
||||
-- | DECIMAL 的精度与小数位
|
||||
decimalType :: Parser ColumnType
|
||||
decimalType = do
|
||||
@@ -744,6 +795,10 @@ expandClause env fromC = case fromC of
|
||||
-- | 表达式里的子查询也要展开
|
||||
expandExpr :: [(String, Statement)] -> Expr -> Either String Expr
|
||||
expandExpr env e = case e of
|
||||
Construct tid arguments -> Construct tid <$> mapM go arguments
|
||||
BoundConstruct tid arguments -> BoundConstruct tid <$> mapM go arguments
|
||||
FunctionCall name arguments -> FunctionCall name <$> mapM go arguments
|
||||
BoundFunction fid tid arguments -> BoundFunction fid tid <$> mapM go arguments
|
||||
Add a b -> Add <$> go a <*> go b
|
||||
Sub a b -> Sub <$> go a <*> go b
|
||||
Mul a b -> Mul <$> go a <*> go b
|
||||
|
||||
@@ -0,0 +1,70 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module NormalizationSpec (spec) where
|
||||
|
||||
import ChuSQL.Core.Engine.Normalization
|
||||
import ChuSQL.Core.Model (pattern TInt)
|
||||
import Test.Hspec
|
||||
|
||||
-- 范式分析回归：公理闭包、候选键、信息不足与分解性质。
|
||||
|
||||
-- 执行范式检查回归。
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "Armstrong normalization" $ do
|
||||
it "computes reflexivity, augmentation and transitivity" $ do
|
||||
attributeClosure [Dependency ["a"] ["b"], Dependency ["b"] ["c"]] ["a"]
|
||||
`shouldBe` ["a", "b", "c"]
|
||||
implies [Dependency ["a"] ["b"]] (Dependency ["a", "c"] ["b", "c"])
|
||||
`shouldBe` True
|
||||
attributeClosure [] ["a"] `shouldBe` ["a"]
|
||||
it "accepts BCNF with a declared key" $ do
|
||||
fmap (map verdict . findings) (analyzeNormalization schema
|
||||
(Declaration [["a"]] [] True (Just True)))
|
||||
`shouldBe` Right (replicate 4 Satisfied)
|
||||
it "detects partial dependencies of composite keys" $ do
|
||||
fmap (map verdict . findings) (analyzeNormalization schema
|
||||
(Declaration [["a", "b"]] [Dependency ["a"] ["c"]] True (Just True)))
|
||||
`shouldBe` Right [Satisfied, Violated, Violated, Violated]
|
||||
it "detects transitive dependencies" $ do
|
||||
fmap (map verdict . findings) (analyzeNormalization schema
|
||||
(Declaration [["a"]] [Dependency ["b"] ["c"]] True (Just True)))
|
||||
`shouldBe` Right [Satisfied, Satisfied, Violated, Violated]
|
||||
it "distinguishes 3NF from BCNF using all candidate keys" $ do
|
||||
fmap (map verdict . findings) (analyzeNormalization schema
|
||||
(Declaration [["a", "b"]] [Dependency ["c"] ["b"]] True (Just True)))
|
||||
`shouldBe` Right [Satisfied, Satisfied, Satisfied, Violated]
|
||||
it "reports lossless decomposition that loses dependencies" $ do
|
||||
fmap suggestions (analyzeNormalization schema
|
||||
(Declaration [["a", "b"]] [Dependency ["c"] ["b"]] True (Just True)))
|
||||
`shouldBe` Right [Decomposition [["b", "c"], ["a", "c"]] Satisfied Violated]
|
||||
it "reports dependency preserving transitive split" $ do
|
||||
fmap suggestions (analyzeNormalization schema
|
||||
(Declaration [["a"]] [Dependency ["b"] ["c"]] True (Just True)))
|
||||
`shouldBe` Right [Decomposition [["b", "c"], ["a", "b"]] Satisfied Satisfied]
|
||||
it "does not certify incomplete dependencies" $ do
|
||||
fmap (map verdict . findings) (analyzeNormalization schema
|
||||
(Declaration [["a"]] [] False (Just True)))
|
||||
`shouldBe` Right [Satisfied, Insufficient, Insufficient, Insufficient]
|
||||
it "requires an atomicity declaration" $ do
|
||||
fmap (map verdict . findings) (analyzeNormalization schema
|
||||
(Declaration [] [] True Nothing)) `shouldBe` Right (replicate 4 Insufficient)
|
||||
it "propagates a declared 1NF violation" $ do
|
||||
fmap (map verdict . findings) (analyzeNormalization schema
|
||||
(Declaration [] [] True (Just False))) `shouldBe` Right (replicate 4 Violated)
|
||||
it "rejects unknown attributes" $ do
|
||||
analyzeNormalization schema (Declaration [] [Dependency ["z"] ["a"]] True (Just True))
|
||||
`shouldBe` Left "normalization: unknown or duplicate dependency attributes"
|
||||
it "rejects nonminimal declared candidate keys" $ do
|
||||
analyzeNormalization schema (Declaration [["a", "b"]]
|
||||
[Dependency ["a"] ["b", "c"]] True (Just True))
|
||||
`shouldBe` Left "normalization: declared candidate key is not minimal"
|
||||
it "includes the empty candidate key for constant relations" $ do
|
||||
fmap candidateKeys (analyzeNormalization schema
|
||||
(Declaration [] [Dependency [] ["a", "b", "c"]] True (Just True))) `shouldBe` Right [[]]
|
||||
it "rejects excessive exhaustive searches" $ do
|
||||
analyzeNormalization [(show n, TInt) | n <- [1 :: Int .. 13]]
|
||||
(Declaration [] [] True (Just True))
|
||||
`shouldBe` Left "normalization: exhaustive analysis supports at most 12 columns"
|
||||
where
|
||||
schema = [("a", TInt), ("b", TInt), ("c", TInt)]
|
||||
@@ -0,0 +1,222 @@
|
||||
module RuntimeSpec (spec) where
|
||||
|
||||
import ChuSQL.Core.Engine.Runtime.Types
|
||||
import ChuSQL.Core.Engine.Runtime.Functions
|
||||
import ChuSQL.Core.Engine.Runtime.Binding
|
||||
import qualified ChuSQL.Core.Engine.Runtime.Query as Query
|
||||
import ChuSQL.Core.Engine (rowsOf, runStatement)
|
||||
import ChuSQL.Core.Engine.Semantic (prepare)
|
||||
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
|
||||
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), Statement (..))
|
||||
import qualified ChuSQL.Core.Model as SQL
|
||||
import ChuSQL.Core.Protocol (valueToJSON, valueFromJSON)
|
||||
import Data.Aeson.Types (parseEither)
|
||||
import Data.Hashable (hash)
|
||||
import qualified Data.ByteString.Lazy.Char8 as BS
|
||||
import Test.Hspec
|
||||
|
||||
-- 运行时类型、函数绑定、物理编码和类型化查询测试。
|
||||
|
||||
-- | 检查运行时类型基础契约
|
||||
spec :: Spec
|
||||
spec = do
|
||||
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]
|
||||
resolveType builtinTypes ty `shouldBe` resolveType builtinTypes ty
|
||||
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
|
||||
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)
|
||||
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)])]
|
||||
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"
|
||||
(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 ->
|
||||
(bindPlan builtinTypes functions [("t", [("x", intType)])] (TableScan "t")
|
||||
>>= executePlan builtinTypes functions (const (Right [[("x", RString "wrong")]]))) `shouldSatisfy` isFailure
|
||||
it "propagates storage failures" $ withFunctions $ \functions ->
|
||||
(bindPlan builtinTypes functions [("t", [])] (TableScan "t")
|
||||
>>= executePlan builtinTypes functions (const (Left "storage unavailable"))) `shouldBe` Left "storage unavailable"
|
||||
describe "SQL runtime functions" $ do
|
||||
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)]
|
||||
it "rejects composite ordering without an Ord implementation" $
|
||||
sql "SELECT LIST<Int>(1) AS xs ORDER BY xs" `shouldSatisfy` isFailure
|
||||
it "rejects composite extrema without an Ord implementation" $
|
||||
sql "SELECT MIN(LIST<Int>(1))" `shouldSatisfy` isFailure
|
||||
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
|
||||
Right SelectExpr {selectItems = [(_, BoundFunction (FunctionId 1) _ [_])]} -> pure ()
|
||||
_ -> 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
|
||||
-- | 提供函数调用测试表
|
||||
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)]
|
||||
|
||||
-- | 判断结果是否明确失败
|
||||
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
|
||||
@@ -31,6 +31,8 @@ import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, remove
|
||||
import System.FilePath ((</>))
|
||||
import System.Timeout (timeout)
|
||||
import Test.Hspec
|
||||
import qualified NormalizationSpec
|
||||
import qualified RuntimeSpec
|
||||
|
||||
-- 引擎层的 hspec 测试：语法、执行、优化器与存储链路行为。
|
||||
|
||||
@@ -116,7 +118,12 @@ domainSql db (sql : rest) = do
|
||||
-- | 跑引擎层全部 hspec 用例
|
||||
main :: IO ()
|
||||
main = hspec $ do
|
||||
NormalizationSpec.spec
|
||||
RuntimeSpec.spec
|
||||
describe "identity syntax" $ do
|
||||
it "parses independent sudo authentication switches" $ do
|
||||
parseStatement "ALTER USER worker ALLOW_SUDO_AUTH" `shouldBe` Right (AlterIdentity "worker" [("allow_sudo_auth", True)])
|
||||
parseStatement "ALTER ROLE worker NOALLOW_SUDO_AUTH" `shouldBe` Right (AlterIdentity "worker" [("allow_sudo_auth", False)])
|
||||
it "parses role and user attributes with their aliases" $ do
|
||||
parseStatement "ALTER ROLE worker LOGIN SUPERUSER ENABLED" `shouldBe` Right (AlterIdentity "worker" [("login", True), ("superuser", True), ("enabled", True)])
|
||||
parseStatement "ALTER USER worker NOLOGIN NOSUPERUSER DISABLED" `shouldBe` Right (AlterIdentity "worker" [("login", False), ("superuser", False), ("enabled", False)])
|
||||
@@ -1056,6 +1063,16 @@ main = hspec $ do
|
||||
parseStatement "GRANT SELECT ON users TO analyst WITH"
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "parses database scopes, explicit tables and qualified wildcards" $ do
|
||||
parseStatement "GRANT CONNECT, CREATE ON DATABASE sales TO analyst"
|
||||
`shouldBe` Right (GrantPrivileges ["CONNECT", "CREATE"] "database:sales" "analyst" False)
|
||||
parseStatement "REVOKE CONNECT ON DATABASE sales FROM PUBLIC"
|
||||
`shouldBe` Right (RevokePrivileges ["CONNECT"] "database:sales" "PUBLIC")
|
||||
parseStatement "GRANT SELECT ON TABLE sales.orders TO analyst"
|
||||
`shouldBe` Right (GrantPrivileges ["SELECT"] "sales.orders" "analyst" False)
|
||||
parseStatement "REVOKE ALL ON sales.* FROM analyst"
|
||||
`shouldBe` Right (RevokePrivileges ["ALL"] "sales.*" "analyst")
|
||||
|
||||
it "parses REVOKE symmetrically" $ do
|
||||
parseStatement "REVOKE SELECT ON users FROM analyst"
|
||||
`shouldBe` Right (RevokePrivileges ["SELECT"] "users" "analyst")
|
||||
@@ -2077,6 +2094,27 @@ main = hspec $ do
|
||||
]
|
||||
|
||||
describe "ChuSQL.Core.Engine.Storage.IPC" $ do
|
||||
it "persists runtime type identities and nested values across restart" $ do
|
||||
withTestSession $ \srv -> do
|
||||
-- | 解析并通过真实存储执行 SQL
|
||||
let query source = case parseStatement source of
|
||||
Left err -> expectationFailure err >> pure (Left err)
|
||||
Right statement -> runIPCStorage (runStatementM statement)
|
||||
originalRows <- withServerEnv srv $ do
|
||||
query "CREATE TABLE compound (id Int, xs [Int], opt Maybe String, pair (Int, String), text String)" `shouldReturn` Right []
|
||||
query "INSERT INTO compound (id, xs, opt, pair, text) VALUES (1, LIST<Int>(1, 2), MAYBE<String>('x'), TUPLE<Int, String>(3, 'y'), 'abc')" `shouldReturn` Right []
|
||||
query "SELECT xs, opt, pair, length(text) FROM compound"
|
||||
originalRows `shouldSatisfy` isRight
|
||||
closeConnection
|
||||
openSessionIn (dataDir srv)
|
||||
reloadedRows <- withServerEnv srv $ query "SELECT xs, opt, pair, length(text) FROM compound"
|
||||
reloadedRows `shouldBe` originalRows
|
||||
withServerEnv srv $ do
|
||||
query "INSERT INTO compound (xs) VALUES (LIST<String>('wrong'))" >>= (`shouldSatisfy` isLeft)
|
||||
query "UPDATE compound SET xs = LIST<Int>(9) WHERE id = 1" `shouldReturn` Right []
|
||||
updated <- query "SELECT xs FROM compound WHERE id = 1"
|
||||
updated `shouldSatisfy` isRight
|
||||
|
||||
it "projects scan columns and preserves constant rows" $ do
|
||||
withTestSession $ \srv -> withServerEnv srv $ do
|
||||
runIPCStorage (insertMany "projected" [[("id", VInt 1), ("name", VStr "one")], [("id", VInt 2), ("name", VNull)]]) `shouldReturn` Right ()
|
||||
|
||||
Reference in new issue
Block a user