完成语义检查,整理项目
This commit is contained in:
1 parent
0791fe0446
commit
91ce26d7f0
17 files changed
+447
-301
No files matched your search
@@ -17,6 +17,7 @@
|
||||
作为函数式编程语言,从语言层面契合SQL语句解析和代数数学运算,同时有强大的类型安全系统。
|
||||
|
||||
- SQL词法分析、AST
|
||||
- 语义分析:表/列存在性与类型检查(执行前的关卡)
|
||||
- 事务处理
|
||||
- 查询优化、内存表管理
|
||||
- 关系代数运算
|
||||
@@ -41,22 +42,6 @@
|
||||
|
||||
> 如果找到了较好的Rust+Haskell集成方法也会及时替换
|
||||
|
||||
# 代码规模
|
||||
|
||||
| 语言 / 类别 | 文件数 | 行数 | 说明 |
|
||||
| --------------- | -----: | -------: | --------------------------------------------------------------- |
|
||||
| Haskell(引擎) | 11 | 902 | `chusql-engine/src/` 10 个模块 + `app/Main.hs` |
|
||||
| Haskell(测试) | 1 | 1058 | `test/Spec.hs`,124 条用例 |
|
||||
| Haskell(基准) | 1 | 118 | `benchmark/chusql-engine/src/Main.hs` |
|
||||
| Rust | 0 | 0 | `chusql-storage/` 尚未开工 |
|
||||
| 前端 | 0 | 0 | `chusql-web/` 尚未开工 |
|
||||
| Markdown 文档 | 6 | 1456 | `README.md` + `docs/` 3 篇 + `benchmark/` 2 篇 |
|
||||
| 构建 / 配置 | 9 | 231 | cabal、`stack.yaml(.lock)`、`tasks.json`、`.gitignore`、LICENSE |
|
||||
| 项目计划 | 1 | 368 | `chusql-engine/projectplan.txt` |
|
||||
| **合计** | **29** | **4133** | 另有 3 个 `.gitkeep` 占位文件未计入 |
|
||||
|
||||
> 最近更新:2026-09-19
|
||||
|
||||
# 性能基准
|
||||
|
||||
**测试环境**:Windows / GHC 9.10.3 / `-O2`
|
||||
@@ -65,9 +50,9 @@
|
||||
|
||||
| 查询 | 结果行数 | 未优化 | 优化后 | 加速 |
|
||||
| ------------------------------------------ | -------: | -------: | ----------: | --------: |
|
||||
| `JOIN` + `WHERE u.age > 90` | 45 | 125.0 ms | **7.1 ms** | **17.7x** |
|
||||
| `JOIN`(无 WHERE,只有投影) | 500 | 132.8 ms | 105.5 ms | 1.3x |
|
||||
| `JOIN` + `WHERE` + `ORDER BY` + `LIMIT 10` | 10 | 171.9 ms | **10.3 ms** | **16.8x** |
|
||||
| 单表 `WHERE age > 90`(对照组) | 45 | 0.111 ms | 0.153 ms | 0.7x |
|
||||
| `JOIN` + `WHERE u.age > 90` | 45 | 242.2 ms | **16.6 ms** | **14.6x** |
|
||||
| `JOIN`(无 WHERE,只有投影) | 500 | 210.9 ms | 195.3 ms | 1.1x |
|
||||
| `JOIN` + `WHERE` + `ORDER BY` + `LIMIT 10` | 10 | 164.1 ms | **14.2 ms** | **11.6x** |
|
||||
| 单表 `WHERE age > 90`(对照组) | 45 | 0.175 ms | 0.290 ms | 0.6x |
|
||||
|
||||
> 最近更新:2026-09-19
|
||||
> 最近更新:2026-09-22(绝对值受机器状态影响,倍率更稳定;同机同法可复现)
|
||||
@@ -4,8 +4,9 @@ import ChuSQL.Algebra.Eval (evalRelOp)
|
||||
import ChuSQL.Algebra.Optimize (optimize)
|
||||
import ChuSQL.Algebra.Planner (translate)
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.SQLSyntax.Parser (parseQuery)
|
||||
import ChuSQL.Syntax.Parser (parseQuery)
|
||||
import Control.Exception (evaluate)
|
||||
import Data.IORef (IORef, newIORef, readIORef)
|
||||
import System.CPUTime (getCPUTime)
|
||||
import System.Environment (getArgs)
|
||||
import Text.Printf (printf)
|
||||
@@ -14,7 +15,7 @@ mkUsers :: Int -> Table
|
||||
mkUsers n =
|
||||
Table
|
||||
{ tableName = "users"
|
||||
, tableCols = ["id", "name", "age"]
|
||||
, tableCols = [("id", TInt), ("name", TStr), ("age", TInt)]
|
||||
, tableRows =
|
||||
[ [("id", VInt i), ("name", VStr ("user" ++ show i)), ("age", VInt (i `mod` 100))]
|
||||
| i <- [1 .. n]
|
||||
@@ -25,7 +26,7 @@ mkOrders :: Int -> Int -> Table
|
||||
mkOrders n m =
|
||||
Table
|
||||
{ tableName = "orders"
|
||||
, tableCols = ["id", "user_id", "product"]
|
||||
, tableCols = [("id", TInt), ("user_id", TInt), ("product", TStr)]
|
||||
, tableRows =
|
||||
[ [("id", VInt j), ("user_id", VInt (1 + (j - 1) `mod` n)), ("product", VStr ("item" ++ show (j `mod` 50)))]
|
||||
| j <- [1 .. m]
|
||||
@@ -43,17 +44,21 @@ rowCount :: Either String [Row] -> Int
|
||||
rowCount (Left _) = -1
|
||||
rowCount (Right rows) = length rows
|
||||
|
||||
runOnce :: Database -> String -> Bool -> IO Int
|
||||
runOnce db sql useOpt = do
|
||||
let result = case parseQuery sql >>= translate db of
|
||||
-- salt 是从 IORef 里读出来的:有了这个"IO 里来的"依赖,GHC 就没法把整段纯计算
|
||||
-- 提到循环外只算一次 —— 否则批量计时会把 1 次的开销除以 k,测出 0.000 ms 这种假数据
|
||||
runOnce :: IORef String -> Database -> String -> Bool -> IO Int
|
||||
runOnce saltRef db sql useOpt = do
|
||||
salt <- readIORef saltRef
|
||||
let result = case parseQuery (sql ++ salt) >>= translate of
|
||||
Left e -> Left e
|
||||
Right plan -> evalRelOp db (if useOpt then optimize db plan else plan)
|
||||
forced <- evaluate (checksum result)
|
||||
return forced
|
||||
|
||||
resultRows :: Database -> String -> Bool -> IO Int
|
||||
resultRows db sql useOpt = do
|
||||
let result = case parseQuery sql >>= translate db of
|
||||
resultRows :: IORef String -> Database -> String -> Bool -> IO Int
|
||||
resultRows saltRef db sql useOpt = do
|
||||
salt <- readIORef saltRef
|
||||
let result = case parseQuery (sql ++ salt) >>= translate of
|
||||
Left e -> Left e
|
||||
Right plan -> evalRelOp db (if useOpt then optimize db plan else plan)
|
||||
_ <- evaluate (checksum result)
|
||||
@@ -73,12 +78,12 @@ benchOp target act = loop 1
|
||||
t <- timed (mapM_ (const act) [1 .. k])
|
||||
if t < target then loop (k * 2) else return (t / fromIntegral k, k)
|
||||
|
||||
report :: Database -> Double -> String -> IO ()
|
||||
report db target sql = do
|
||||
nUn <- resultRows db sql False
|
||||
nOp <- resultRows db sql True
|
||||
(tUn, kUn) <- benchOp target (runOnce db sql False)
|
||||
(tOp, kOp) <- benchOp target (runOnce db sql True)
|
||||
report :: IORef String -> Database -> Double -> String -> IO ()
|
||||
report saltRef db target sql = do
|
||||
nUn <- resultRows saltRef db sql False
|
||||
nOp <- resultRows saltRef db sql True
|
||||
(tUn, kUn) <- benchOp target (runOnce saltRef db sql False)
|
||||
(tOp, kOp) <- benchOp target (runOnce saltRef db sql True)
|
||||
let speedup = if tOp <= 0 then 0 else tUn / tOp
|
||||
mismatch = if nUn == nOp then "" else " <<< 结果不一致!"
|
||||
printf "%s\n" sql
|
||||
@@ -113,6 +118,7 @@ main = do
|
||||
printf "数据规模:users = %d 行,orders = %d 行\n" n m
|
||||
printf "计时方式:CPU 时间;每个用例自动加倍批量次数,直到一批累计耗时超过 %.2f 秒,再折算成单次耗时\n" target
|
||||
printf "(先跑一遍预热,避免把首次构造数据的开销算进去)\n\n"
|
||||
_ <- runOnce db warmupSql False
|
||||
_ <- runOnce db warmupSql True
|
||||
mapM_ (report db target) queries
|
||||
saltRef <- newIORef ""
|
||||
_ <- runOnce saltRef db warmupSql False
|
||||
_ <- runOnce saltRef db warmupSql True
|
||||
mapM_ (report saltRef db target) queries
|
||||
+10
-37
@@ -1,18 +1,18 @@
|
||||
module Main where
|
||||
|
||||
import ChuSQL.Algebra.Op (RelOp (..))
|
||||
import ChuSQL.Algebra.Op (renderPlan)
|
||||
import ChuSQL.Algebra.Optimize (optimize)
|
||||
import ChuSQL.Algebra.Planner (translate)
|
||||
import ChuSQL.Engine
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.SQLSyntax.AST
|
||||
import ChuSQL.SQLSyntax.Executor
|
||||
import ChuSQL.SQLSyntax.Parser
|
||||
import ChuSQL.Syntax.AST
|
||||
import ChuSQL.Syntax.Parser
|
||||
|
||||
users :: Table
|
||||
users =
|
||||
Table
|
||||
{ tableName = "users"
|
||||
, tableCols = ["id", "name", "age"]
|
||||
, tableCols = [("id", TInt), ("name", TStr), ("age", TInt)]
|
||||
, tableRows =
|
||||
[ [("id", VInt 1), ("name", VStr "Alice"), ("age", VInt 25)]
|
||||
, [("id", VInt 2), ("name", VStr "Bob"), ("age", VInt 17)]
|
||||
@@ -24,7 +24,7 @@ orders :: Table
|
||||
orders =
|
||||
Table
|
||||
{ tableName = "orders"
|
||||
, tableCols = ["id", "user_id", "product"]
|
||||
, tableCols = [("id", TInt), ("user_id", TInt), ("product", TStr)]
|
||||
, tableRows =
|
||||
[ [("id", VInt 1), ("user_id", VInt 1), ("product", VStr "Book")]
|
||||
, [("id", VInt 2), ("user_id", VInt 2), ("product", VStr "Pen")]
|
||||
@@ -35,13 +35,9 @@ orders =
|
||||
db :: Database
|
||||
db = [("users", users), ("orders", orders)]
|
||||
|
||||
-- runQuery 返回 (更新后的数据库, 结果行);演示只关心结果行
|
||||
rowsOf :: Either String (Database, [Row]) -> Either String [Row]
|
||||
rowsOf = fmap snd
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "==================== Parser Test ====================="
|
||||
putStrLn "==================== Engine ====================="
|
||||
let q1 = makeSelect ["name"] "users" (Just (Gt (Col "age") (LitInt 18)))
|
||||
print (rowsOf (runQuery db q1))
|
||||
|
||||
@@ -73,35 +69,12 @@ main = do
|
||||
\JOIN orders o ON u.id = o.user_id WHERE u.age > 18"
|
||||
case parseQuery planSql of
|
||||
Left err -> putStrLn err
|
||||
Right query -> case translate db query of
|
||||
Right query -> case translate query of
|
||||
Left err -> putStrLn err
|
||||
Right plan -> do
|
||||
putStrLn "--- plan before optimization ---"
|
||||
putStrLn (dump 0 plan)
|
||||
putStrLn (renderPlan plan)
|
||||
putStrLn "--- plan after optimization ---"
|
||||
putStrLn (dump 0 (optimize db plan))
|
||||
putStrLn (renderPlan (optimize db plan))
|
||||
putStrLn "--- rows ---"
|
||||
print (rowsOf (runQuery db query))
|
||||
|
||||
dump :: Int -> RelOp -> String
|
||||
dump ind op = case op of
|
||||
Scan a t ->
|
||||
pad ++ "Scan " ++ show a ++ " " ++ show t
|
||||
Filter e x ->
|
||||
pad ++ "Filter " ++ show e ++ "\n" ++ dump (ind + 1) x
|
||||
Project c x ->
|
||||
pad ++ "Project " ++ show c ++ "\n" ++ dump (ind + 1) x
|
||||
Sort s x ->
|
||||
pad ++ "Sort " ++ show s ++ "\n" ++ dump (ind + 1) x
|
||||
Limit n x ->
|
||||
pad ++ "Limit " ++ show n ++ "\n" ++ dump (ind + 1) x
|
||||
Join l r c ->
|
||||
pad
|
||||
++ "Join on "
|
||||
++ show c
|
||||
++ "\n"
|
||||
++ dump (ind + 1) l
|
||||
++ "\n"
|
||||
++ dump (ind + 1) r
|
||||
where
|
||||
pad = replicate (ind * 2) ' '
|
||||
@@ -10,15 +10,16 @@ build-type: Simple
|
||||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules: ChuSQL.Algebra.Eval
|
||||
ChuSQL.Algebra.Expr
|
||||
ChuSQL.Algebra.Op
|
||||
ChuSQL.Algebra.Optimize
|
||||
ChuSQL.Algebra.Planner
|
||||
ChuSQL.Algebra.Sort
|
||||
ChuSQL.Engine
|
||||
ChuSQL.Model
|
||||
ChuSQL.SQLSyntax.AST
|
||||
ChuSQL.SQLSyntax.Executor
|
||||
ChuSQL.SQLSyntax.Expr
|
||||
ChuSQL.SQLSyntax.Parser
|
||||
ChuSQL.SQLSyntax.Sort
|
||||
ChuSQL.Semantic
|
||||
ChuSQL.Syntax.AST
|
||||
ChuSQL.Syntax.Parser
|
||||
build-depends: base >= 4.14 && < 5
|
||||
, megaparsec
|
||||
, parser-combinators
|
||||
|
||||
@@ -1,9 +1,9 @@
|
||||
module ChuSQL.Algebra.Eval where
|
||||
module ChuSQL.Algebra.Eval (evalRelOp) where
|
||||
|
||||
import ChuSQL.Algebra.Expr (evalCondForRow)
|
||||
import ChuSQL.Algebra.Op
|
||||
import ChuSQL.Algebra.Sort (sortRows)
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.SQLSyntax.Expr (evalCondForRow)
|
||||
import ChuSQL.SQLSyntax.Sort (sortRows)
|
||||
import Control.Monad (filterM)
|
||||
|
||||
-- 投影
|
||||
@@ -17,7 +17,7 @@ addPrefix prefix = map (\(k, v) -> (prefix ++ k, v))
|
||||
|
||||
evalRelOp :: Database -> RelOp -> Either String [Row]
|
||||
evalRelOp db (Scan mAlias tbl) = do
|
||||
table <- maybe (Left ("unknown table: " ++ tbl)) Right (lookup tbl db)
|
||||
table <- lookupTable db tbl
|
||||
let prefix = maybe "" (++ ".") mAlias
|
||||
Right (map (addPrefix prefix) (tableRows table))
|
||||
evalRelOp db (Filter e op) = do
|
||||
|
||||
+12
-2
@@ -1,7 +1,7 @@
|
||||
module ChuSQL.SQLSyntax.Expr where
|
||||
module ChuSQL.Algebra.Expr (evalExpr, evalCondForRow, colsInExpr) where
|
||||
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.SQLSyntax.AST
|
||||
import ChuSQL.Syntax.AST
|
||||
import Control.Monad (join)
|
||||
|
||||
-- 表达式求值
|
||||
@@ -17,6 +17,16 @@ evalExpr (Eq a b) row = liftBinOp eqOp a b row
|
||||
evalExpr (And a b) row = liftBinOp (boolOp (&&)) a b row
|
||||
evalExpr (Or a b) row = liftBinOp (boolOp (||)) a b row
|
||||
|
||||
-- | 收集表达式里用到的列名
|
||||
colsInExpr :: Expr -> [String]
|
||||
colsInExpr (Col c) = [c]
|
||||
colsInExpr (Gt a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Lt a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Eq a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (And a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Or a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr _ = []
|
||||
|
||||
-- 对行计算条件语句
|
||||
evalCondForRow :: Expr -> Row -> Either String Bool
|
||||
evalCondForRow e row = do
|
||||
@@ -1,6 +1,6 @@
|
||||
module ChuSQL.Algebra.Op where
|
||||
module ChuSQL.Algebra.Op (RelOp (..), renderPlan) where
|
||||
|
||||
import ChuSQL.SQLSyntax.AST (Expr, SortDir)
|
||||
import ChuSQL.Syntax.AST (Expr, SortDir)
|
||||
|
||||
-- 关系代数算子
|
||||
data RelOp
|
||||
@@ -11,3 +11,17 @@ data RelOp
|
||||
| Limit Int RelOp
|
||||
| Join RelOp RelOp Expr
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 把算子树画成缩进文本(演示和调试用)
|
||||
renderPlan :: RelOp -> String
|
||||
renderPlan = go 0
|
||||
where
|
||||
go ind op = case op of
|
||||
Scan a t -> pad ++ "Scan " ++ show a ++ " " ++ show t
|
||||
Filter e x -> pad ++ "Filter " ++ show e ++ "\n" ++ go (ind + 1) x
|
||||
Project c x -> pad ++ "Project " ++ show c ++ "\n" ++ go (ind + 1) x
|
||||
Sort s x -> pad ++ "Sort " ++ show s ++ "\n" ++ go (ind + 1) x
|
||||
Limit n x -> pad ++ "Limit " ++ show n ++ "\n" ++ go (ind + 1) x
|
||||
Join l r c -> pad ++ "Join on " ++ show c ++ "\n" ++ go (ind + 1) l ++ "\n" ++ go (ind + 1) r
|
||||
where
|
||||
pad = replicate (ind * 2) ' '
|
||||
@@ -1,22 +1,12 @@
|
||||
module ChuSQL.Algebra.Optimize where
|
||||
module ChuSQL.Algebra.Optimize (optimize, pushProject) where
|
||||
|
||||
import ChuSQL.Algebra.Op (RelOp (..))
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.SQLSyntax.AST (Expr (..))
|
||||
import ChuSQL.SQLSyntax.Expr (evalExpr)
|
||||
import ChuSQL.Syntax.AST (Expr (..))
|
||||
import ChuSQL.Algebra.Expr (colsInExpr, evalExpr)
|
||||
|
||||
-- * 谓词下推
|
||||
|
||||
-- | 收集表达式里用到的列名;谓词下推判断条件归属、常量折叠判断能否求值,都要用它
|
||||
colsInExpr :: Expr -> [String]
|
||||
colsInExpr (Col c) = [c]
|
||||
colsInExpr (Gt a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Lt a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Eq a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (And a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Or a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr _ = []
|
||||
|
||||
-- | 一个算子会产出哪些列;返回 ["*"] 表示"全部列,不用挑"
|
||||
relOpCols :: Database -> RelOp -> [String]
|
||||
relOpCols db (Filter _ x) = relOpCols db x
|
||||
@@ -28,7 +18,7 @@ relOpCols db (Join l r _) = relOpCols db l ++ relOpCols db r
|
||||
relOpCols db (Scan mAlias tbl) =
|
||||
case lookup tbl db of
|
||||
Nothing -> []
|
||||
Just t -> map (prefix ++) (tableCols t)
|
||||
Just t -> map (prefix ++) (colNames t)
|
||||
where
|
||||
prefix = maybe "" (++ ".") mAlias
|
||||
|
||||
@@ -85,7 +75,7 @@ pushOne _ op = op
|
||||
|
||||
-- | 工具函数
|
||||
needsAll :: [String] -> Bool
|
||||
needsAll = elem "*"
|
||||
needsAll = elem allColumns
|
||||
|
||||
pushProject :: Database -> [String] -> RelOp -> RelOp
|
||||
pushProject db _ (Project cols x) = case pushProject db cols x of
|
||||
|
||||
@@ -1,44 +1,7 @@
|
||||
module ChuSQL.Algebra.Planner where
|
||||
module ChuSQL.Algebra.Planner (translate) where
|
||||
|
||||
import ChuSQL.Algebra.Op
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.SQLSyntax.AST
|
||||
|
||||
-- * 存在性检查
|
||||
checkColumns :: [String] -> [String] -> Either String ()
|
||||
checkColumns available requested =
|
||||
case [c | c <- requested, c /= "*", c `notElem` available] of
|
||||
[] -> Right ()
|
||||
(c : _) -> Left ("unknown column: " ++ c)
|
||||
|
||||
checkFrom :: Database -> FromClause -> Either String ()
|
||||
checkFrom db (FromTable _ tbl) =
|
||||
case lookup tbl db of
|
||||
Just _ -> Right ()
|
||||
Nothing -> Left ("unknown table: " ++ tbl)
|
||||
checkFrom db (FromJoin left _ tbl _) = do
|
||||
_ <- checkFrom db left
|
||||
case lookup tbl db of
|
||||
Just _ -> Right ()
|
||||
Nothing -> Left ("unknown table: " ++ tbl)
|
||||
|
||||
-- | 收集 FromClause 里所有可用的列名
|
||||
availableColumns :: Database -> FromClause -> Either String [String]
|
||||
availableColumns db (FromTable mAlias tbl) = do
|
||||
table <- maybe (Left ("unknown table: " ++ tbl)) Right (lookup tbl db)
|
||||
let prefix = maybe "" (++ ".") mAlias
|
||||
Right (map (prefix ++) (tableCols table))
|
||||
availableColumns db (FromJoin left mAlias tbl _) = do
|
||||
lcols <- availableColumns db left
|
||||
table <- maybe (Left ("unknown table: " ++ tbl)) Right (lookup tbl db)
|
||||
let prefix = maybe "" (++ ".") mAlias
|
||||
Right (lcols ++ map (prefix ++) (tableCols table))
|
||||
|
||||
-- | 检查数据库列明
|
||||
checkColumnsFrom :: Database -> FromClause -> [String] -> Either String ()
|
||||
checkColumnsFrom db fromC requested = do
|
||||
available <- availableColumns db fromC
|
||||
checkColumns available requested
|
||||
import ChuSQL.Syntax.AST
|
||||
|
||||
-- 内部查询语句转执行计划
|
||||
fromToRelOp :: FromClause -> RelOp
|
||||
@@ -46,8 +9,8 @@ fromToRelOp (FromTable mAlias tbl) = Scan mAlias tbl
|
||||
fromToRelOp (FromJoin left mAlias tbl cond) =
|
||||
Join (fromToRelOp left) (Scan mAlias tbl) cond
|
||||
|
||||
translate :: Database -> Query -> Either String RelOp
|
||||
translate db q = case q of
|
||||
translate :: Query -> Either String RelOp
|
||||
translate q = case q of
|
||||
Select
|
||||
{ selectCols = cols
|
||||
, selectFrom = fromC
|
||||
@@ -55,10 +18,6 @@ translate db q = case q of
|
||||
, selectOrderBy = orderBy
|
||||
, selectLimit = mLimit
|
||||
} -> do
|
||||
-- 检查所有表和列
|
||||
_ <- checkFrom db fromC
|
||||
_ <- checkColumnsFrom db fromC cols
|
||||
_ <- checkColumnsFrom db fromC (map fst orderBy)
|
||||
let base = fromToRelOp fromC
|
||||
filtered = case mWhere of
|
||||
Nothing -> base
|
||||
|
||||
+2
-2
@@ -1,7 +1,7 @@
|
||||
module ChuSQL.SQLSyntax.Sort where
|
||||
module ChuSQL.Algebra.Sort (sortRows) where
|
||||
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.SQLSyntax.AST
|
||||
import ChuSQL.Syntax.AST
|
||||
import Data.List (sortBy)
|
||||
|
||||
-- | 反向排序
|
||||
+30
-28
@@ -1,19 +1,27 @@
|
||||
module ChuSQL.SQLSyntax.Executor where
|
||||
module ChuSQL.Engine (runQuery, rowsOf) where
|
||||
|
||||
import ChuSQL.Algebra.Eval (evalRelOp)
|
||||
import ChuSQL.Algebra.Expr (evalCondForRow, evalExpr)
|
||||
import ChuSQL.Algebra.Optimize (optimize)
|
||||
import ChuSQL.Algebra.Planner (translate)
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.SQLSyntax.AST
|
||||
import ChuSQL.SQLSyntax.Expr (evalCondForRow, evalExpr)
|
||||
import ChuSQL.Semantic (check)
|
||||
import ChuSQL.Syntax.AST
|
||||
import Control.Monad (filterM)
|
||||
|
||||
-- 表里加新行
|
||||
updateTable :: String -> (Table -> Table) -> Database -> Either String Database
|
||||
updateTable name f db = do
|
||||
table <- maybe (Left ("unknown table: " ++ name)) Right (lookup name db)
|
||||
let table' = f table
|
||||
Right (map (\(n, t) -> if n == name then (n, table') else (n, t)) db)
|
||||
-- | 带检查的查询入口:先做语义检查,再交给下面的执行
|
||||
runQuery :: Database -> Query -> Either String (Database, [Row])
|
||||
runQuery db q = do
|
||||
_ <- check db q
|
||||
runQueryUnchecked db q
|
||||
|
||||
-- | 只要结果行(丢掉更新后的数据库),给演示和测试用
|
||||
rowsOf :: Either String (Database, [Row]) -> Either String [Row]
|
||||
rowsOf = fmap snd
|
||||
|
||||
-- 把表整体换掉(调用方已经查过,表一定存在)
|
||||
replaceTable :: String -> Table -> Database -> Database
|
||||
replaceTable name table = map (\(n, t) -> if n == name then (n, table) else (n, t))
|
||||
|
||||
-- 修改表
|
||||
applyUpdates :: [(String, Expr)] -> Row -> Either String Row
|
||||
@@ -25,46 +33,40 @@ applyUpdates ((col, e) : rest) row = do
|
||||
where
|
||||
setColumn c v r = map (\(k, val) -> if k == c then (k, v) else (k, val)) r
|
||||
|
||||
-- 处理查询
|
||||
runQuery :: Database -> Query -> Either String (Database, [Row])
|
||||
runQuery db q@Select{} = do
|
||||
relOp <- translate db q
|
||||
-- 实际执行(调用方请确保已过 check)
|
||||
runQueryUnchecked :: Database -> Query -> Either String (Database, [Row])
|
||||
runQueryUnchecked db q@Select{} = do
|
||||
relOp <- translate q
|
||||
rows <- evalRelOp db (optimize db relOp)
|
||||
Right (db, rows)
|
||||
|
||||
-- 处理插入
|
||||
runQuery db (Insert tbl cols vals) = do
|
||||
runQueryUnchecked db (Insert tbl cols vals) = do
|
||||
values <- mapM (\e -> evalExpr e []) vals
|
||||
if length cols /= length values
|
||||
then Left "column count does not match value count"
|
||||
else do
|
||||
table <- lookupTable db tbl
|
||||
let newRow = zip cols values
|
||||
db' <-
|
||||
updateTable
|
||||
tbl
|
||||
(\t -> t{tableRows = tableRows t ++ [newRow]})
|
||||
db
|
||||
Right (db', [])
|
||||
Right (replaceTable tbl table{tableRows = tableRows table ++ [newRow]} db, [])
|
||||
|
||||
-- 处理删除
|
||||
runQuery db (Delete tbl mWhere) = do
|
||||
table <- maybe (Left ("unknown table: " ++ tbl)) Right (lookup tbl db)
|
||||
runQueryUnchecked db (Delete tbl mWhere) = do
|
||||
table <- lookupTable db tbl
|
||||
rows <- case mWhere of
|
||||
Nothing -> Right []
|
||||
Just e -> filterM (shouldKeep e) (tableRows table)
|
||||
db' <- updateTable tbl (\t -> t{tableRows = rows}) db
|
||||
Right (db', [])
|
||||
Right (replaceTable tbl table{tableRows = rows} db, [])
|
||||
where
|
||||
-- 保留 = 条件不成立
|
||||
shouldKeep :: Expr -> Row -> Either String Bool
|
||||
shouldKeep e row = not <$> evalCondForRow e row
|
||||
|
||||
-- 处理表更新
|
||||
runQuery db (Update tbl assigns mWhere) = do
|
||||
table <- maybe (Left ("unknown table: " ++ tbl)) Right (lookup tbl db)
|
||||
runQueryUnchecked db (Update tbl assigns mWhere) = do
|
||||
table <- lookupTable db tbl
|
||||
rows <- mapM (updateRow mWhere assigns) (tableRows table)
|
||||
db' <- updateTable tbl (\t -> t{tableRows = rows}) db
|
||||
Right (db', [])
|
||||
Right (replaceTable tbl table{tableRows = rows} db, [])
|
||||
where
|
||||
updateRow :: Maybe Expr -> [(String, Expr)] -> Row -> Either String Row
|
||||
updateRow cond asgns row = do
|
||||
@@ -1,4 +1,11 @@
|
||||
module ChuSQL.Model where
|
||||
module ChuSQL.Model (Column (..), Value (..), Row, Table (..), Database, colNames, colType, lookupTable, allColumns) where
|
||||
|
||||
-- 列的类型
|
||||
data Column
|
||||
= TInt
|
||||
| TStr
|
||||
| TBool
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- 列的值:整数、字符串、布尔
|
||||
data Value
|
||||
@@ -13,10 +20,26 @@ type Row = [(String, Value)]
|
||||
-- 一张表
|
||||
data Table = Table
|
||||
{ tableName :: String
|
||||
, tableCols :: [String]
|
||||
, tableCols :: [(String, Column)]
|
||||
, tableRows :: [Row]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- 数据库:多张表
|
||||
type Database = [(String, Table)]
|
||||
|
||||
-- 获取列名
|
||||
colNames :: Table -> [String]
|
||||
colNames = map fst . tableCols
|
||||
|
||||
-- | 查某一列的类型
|
||||
colType :: Table -> String -> Maybe Column
|
||||
colType t c = lookup c (tableCols t)
|
||||
|
||||
-- | 按名字查表;表不存在就报错
|
||||
lookupTable :: Database -> String -> Either String Table
|
||||
lookupTable db t = maybe (Left ("unknown table: " ++ t)) Right (lookup t db)
|
||||
|
||||
-- | 投影列清单里的哨兵值:它表示"全部列,不用挑",不是列名
|
||||
allColumns :: String
|
||||
allColumns = "*"
|
||||
@@ -0,0 +1,128 @@
|
||||
module ChuSQL.Semantic (check) where
|
||||
|
||||
import ChuSQL.Algebra.Expr (colsInExpr)
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.Syntax.AST
|
||||
import Data.List (intercalate)
|
||||
|
||||
-- * 表与列名解析
|
||||
|
||||
-- | 给一批列加上"别名."前缀
|
||||
prefixColumns :: Maybe String -> [(String, Column)] -> [(String, Column)]
|
||||
prefixColumns mAlias cols = [(prefix ++ c, ty) | (c, ty) <- cols]
|
||||
where
|
||||
prefix = maybe "" (++ ".") mAlias
|
||||
|
||||
-- | 走一遍 FROM:算出可用列(带别名前缀),顺手把每个 ON 条件也查了
|
||||
checkFrom :: Database -> FromClause -> Either String [(String, Column)]
|
||||
checkFrom db (FromTable mAlias tbl) = do
|
||||
t <- lookupTable db tbl
|
||||
Right (prefixColumns mAlias (tableCols t))
|
||||
checkFrom db (FromJoin left mAlias tbl cond) = do
|
||||
lcols <- checkFrom db left
|
||||
t <- lookupTable db tbl
|
||||
let env = lcols ++ prefixColumns mAlias (tableCols t)
|
||||
checkBool "ON" env cond
|
||||
Right env
|
||||
|
||||
-- * 列检查与报错
|
||||
|
||||
-- | 统一拼一条带"可用列清单"的报错
|
||||
missingColumn :: String -> String -> [(String, Column)] -> String
|
||||
missingColumn place c env =
|
||||
"unknown column in " ++ place ++ ": " ++ c ++ hint
|
||||
where
|
||||
hint
|
||||
| null env = ""
|
||||
| otherwise = " (available: " ++ intercalate ", " (map fst env) ++ ")"
|
||||
|
||||
-- | 请求的列必须都在可用清单里;哨兵 allColumns 表示"全部列",放行
|
||||
checkColumns :: String -> [(String, Column)] -> [String] -> Either String ()
|
||||
checkColumns place env requested =
|
||||
case [c | c <- requested, c /= allColumns, c `notElem` map fst env] of
|
||||
[] -> Right ()
|
||||
(c : _) -> Left (missingColumn place c env)
|
||||
|
||||
-- * 表达式类型推导
|
||||
|
||||
-- | 推出一个表达式的结果类型;列不存在、或类型对不上,都报错
|
||||
inferExpr :: String -> [(String, Column)] -> Expr -> Either String Column
|
||||
inferExpr place env (Col c) = maybe (Left (missingColumn place c env)) Right (lookup c env)
|
||||
inferExpr _ _ (LitInt _) = Right TInt
|
||||
inferExpr _ _ (LitStr _) = Right TStr
|
||||
inferExpr _ _ (LitBool _) = Right TBool
|
||||
inferExpr place env (Gt a b) = operands place env TInt a b
|
||||
inferExpr place env (Lt a b) = operands place env TInt a b
|
||||
inferExpr place env (And a b) = operands place env TBool a b
|
||||
inferExpr place env (Or a b) = operands place env TBool a b
|
||||
inferExpr place env (Eq a b) = do
|
||||
ta <- inferExpr place env a
|
||||
tb <- inferExpr place env b
|
||||
if ta == tb
|
||||
then Right TBool
|
||||
else Left (place ++ ": both sides of = must have the same type, got " ++ show ta ++ " and " ++ show tb)
|
||||
|
||||
-- | 二元运算的通用检查:两边都必须是同一种期望类型,结果都是布尔
|
||||
operands :: String -> [(String, Column)] -> Column -> Expr -> Expr -> Either String Column
|
||||
operands place env want a b = do
|
||||
ta <- inferExpr place env a
|
||||
tb <- inferExpr place env b
|
||||
if ta == want && tb == want
|
||||
then Right TBool
|
||||
else Left (place ++ ": operator needs " ++ show want ++ " on both sides, got " ++ show ta ++ " and " ++ show tb)
|
||||
|
||||
-- | 这个表达式必须能算成一个条件(布尔)
|
||||
checkBool :: String -> [(String, Column)] -> Expr -> Either String ()
|
||||
checkBool place env e = do
|
||||
checkColumns place env (colsInExpr e)
|
||||
t <- inferExpr place env e
|
||||
if t == TBool
|
||||
then Right ()
|
||||
else Left (place ++ ": condition must be a boolean, got " ++ show t)
|
||||
|
||||
-- * 写入语句
|
||||
|
||||
-- | 一条赋值的通用检查:目标列必须存在,右边表达式的类型要对得上
|
||||
checkTyped :: String -> [(String, Column)] -> Table -> (String, Expr) -> Either String ()
|
||||
checkTyped place env t (c, e) = do
|
||||
want <- maybe (Left (missingColumn place c (tableCols t))) Right (colType t c)
|
||||
got <- inferExpr place env e
|
||||
if want == got
|
||||
then Right ()
|
||||
else Left (place ++ ": column " ++ c ++ " needs " ++ show want ++ ", got " ++ show got)
|
||||
|
||||
-- | INSERT 的一个值:环境是空的 —— 值必须是字面量,写列名会被拦下
|
||||
checkValue :: Table -> (String, Expr) -> Either String ()
|
||||
checkValue = checkTyped "INSERT" []
|
||||
|
||||
-- | UPDATE 的一个赋值:环境是整张表 —— 右边可以引用本行的列
|
||||
checkAssign :: Table -> (String, Expr) -> Either String ()
|
||||
checkAssign t = checkTyped "UPDATE" (tableCols t) t
|
||||
|
||||
-- * 总入口
|
||||
|
||||
-- | 语义检查总入口:合法返回 Right (),不合法返回 Left(带人话解释)
|
||||
check :: Database -> Query -> Either String ()
|
||||
check db q = case q of
|
||||
Select
|
||||
{ selectCols = cols
|
||||
, selectFrom = fromC
|
||||
, selectWhere = mWhere
|
||||
, selectOrderBy = orderBy
|
||||
} -> do
|
||||
env <- checkFrom db fromC
|
||||
checkColumns "SELECT" env cols
|
||||
checkColumns "ORDER BY" env (map fst orderBy)
|
||||
mapM_ (checkBool "WHERE" env) mWhere
|
||||
Insert tbl cols vals -> do
|
||||
t <- lookupTable db tbl
|
||||
checkColumns "INSERT" (tableCols t) cols
|
||||
mapM_ (checkValue t) (zip cols vals)
|
||||
Delete tbl mWhere -> do
|
||||
t <- lookupTable db tbl
|
||||
mapM_ (checkBool "WHERE" (tableCols t)) mWhere
|
||||
Update tbl assigns mWhere -> do
|
||||
t <- lookupTable db tbl
|
||||
checkColumns "UPDATE" (tableCols t) (map fst assigns)
|
||||
mapM_ (checkAssign t) assigns
|
||||
mapM_ (checkBool "WHERE" (tableCols t)) mWhere
|
||||
@@ -1,4 +1,4 @@
|
||||
module ChuSQL.SQLSyntax.AST where
|
||||
module ChuSQL.Syntax.AST (Query (..), FromClause (..), Expr (..), SortDir (..), makeSelect) where
|
||||
|
||||
-- 查询语句
|
||||
data Query
|
||||
+3
-10
@@ -1,20 +1,13 @@
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
|
||||
{- | SQL 语法分析器:把 SQL 文本解析为 'ChuSQL.SQLSyntax.AST.Query'。
|
||||
{- | SQL 语法分析器:把 SQL 文本解析为 'ChuSQL.Syntax.AST.Query'。
|
||||
|
||||
词法层负责空白、关键字、标识符、字面量与符号;语法层按
|
||||
优先级 比较 > AND > OR 自底向上组装表达式。
|
||||
-}
|
||||
module ChuSQL.SQLSyntax.Parser (
|
||||
Parser,
|
||||
parseQuery,
|
||||
expr,
|
||||
identifier,
|
||||
integer,
|
||||
stringLit,
|
||||
) where
|
||||
module ChuSQL.Syntax.Parser (parseQuery) where
|
||||
|
||||
import ChuSQL.SQLSyntax.AST
|
||||
import ChuSQL.Syntax.AST
|
||||
import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
|
||||
import Data.Char (isAlpha, isAlphaNum, toLower)
|
||||
import Data.List (intercalate)
|
||||
+171
-22
@@ -1,13 +1,13 @@
|
||||
module Main where
|
||||
|
||||
import ChuSQL.Algebra.Eval (evalRelOp)
|
||||
import ChuSQL.Algebra.Op (RelOp (..))
|
||||
import ChuSQL.Algebra.Op (RelOp (..), renderPlan)
|
||||
import ChuSQL.Algebra.Optimize (optimize, pushProject)
|
||||
import ChuSQL.Algebra.Planner (translate)
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.SQLSyntax.AST
|
||||
import ChuSQL.SQLSyntax.Executor
|
||||
import ChuSQL.SQLSyntax.Parser
|
||||
import ChuSQL.Syntax.AST
|
||||
import ChuSQL.Engine
|
||||
import ChuSQL.Syntax.Parser
|
||||
import Test.Hspec
|
||||
|
||||
-- ============================================================
|
||||
@@ -17,7 +17,7 @@ users :: Table
|
||||
users =
|
||||
Table
|
||||
{ tableName = "users"
|
||||
, tableCols = ["id", "name", "age"]
|
||||
, tableCols = [("id", TInt), ("name", TStr), ("age", TInt)]
|
||||
, tableRows =
|
||||
[ [("id", VInt 1), ("name", VStr "Alice"), ("age", VInt 25)]
|
||||
, [("id", VInt 2), ("name", VStr "Bob"), ("age", VInt 17)]
|
||||
@@ -29,7 +29,7 @@ orders :: Table
|
||||
orders =
|
||||
Table
|
||||
{ tableName = "orders"
|
||||
, tableCols = ["id", "user_id", "product"]
|
||||
, tableCols = [("id", TInt), ("user_id", TInt), ("product", TStr)]
|
||||
, tableRows =
|
||||
[ [("id", VInt 1), ("user_id", VInt 1), ("product", VStr "Book")]
|
||||
, [("id", VInt 2), ("user_id", VInt 2), ("product", VStr "Pen")]
|
||||
@@ -48,7 +48,7 @@ main = hspec $ do
|
||||
-- ============================================================
|
||||
-- AST
|
||||
-- ============================================================
|
||||
describe "ChuSQL.Syntax.Ast" $ do
|
||||
describe "ChuSQL.Syntax.AST" $ do
|
||||
it "equal Selects are equal" $ do
|
||||
makeSelect ["name"] "users" Nothing
|
||||
`shouldBe` makeSelect ["name"] "users" Nothing
|
||||
@@ -247,7 +247,7 @@ main = hspec $ do
|
||||
-- ============================================================
|
||||
-- Engine: SELECT
|
||||
-- ============================================================
|
||||
describe "ChuSQL.Eval.Engine (SELECT)" $ do
|
||||
describe "ChuSQL.Engine (SELECT)" $ do
|
||||
it "returns all rows without WHERE" $ do
|
||||
rowsOf (runQuery testDB (makeSelect ["*"] "users" Nothing))
|
||||
`shouldBe` Right
|
||||
@@ -304,7 +304,7 @@ main = hspec $ do
|
||||
-- ============================================================
|
||||
-- Engine: INSERT
|
||||
-- ============================================================
|
||||
describe "ChuSQL.Eval.Engine (INSERT)" $ do
|
||||
describe "ChuSQL.Engine (INSERT)" $ do
|
||||
it "parses a simple INSERT" $ do
|
||||
parseQuery "INSERT INTO users (name, age) VALUES ('Dave', 22)"
|
||||
`shouldBe` Right (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22])
|
||||
@@ -353,7 +353,7 @@ main = hspec $ do
|
||||
-- ============================================================
|
||||
-- Engine: DELETE
|
||||
-- ============================================================
|
||||
describe "ChuSQL.Eval.Engine (DELETE)" $ do
|
||||
describe "ChuSQL.Engine (DELETE)" $ do
|
||||
it "parses DELETE with WHERE" $ do
|
||||
parseQuery "DELETE FROM users WHERE age < 18"
|
||||
`shouldBe` Right (Delete "users" (Just (Lt (Col "age") (LitInt 18))))
|
||||
@@ -403,7 +403,7 @@ main = hspec $ do
|
||||
-- ============================================================
|
||||
-- Engine: UPDATE
|
||||
-- ============================================================
|
||||
describe "ChuSQL.Eval.Engine (UPDATE)" $ do
|
||||
describe "ChuSQL.Engine (UPDATE)" $ do
|
||||
it "parses UPDATE with WHERE" $ do
|
||||
parseQuery "UPDATE users SET age = 26 WHERE name = 'Alice'"
|
||||
`shouldBe` Right
|
||||
@@ -495,7 +495,7 @@ main = hspec $ do
|
||||
-- ============================================================
|
||||
-- Engine: ORDER BY
|
||||
-- ============================================================
|
||||
describe "ChuSQL.Eval.Engine (ORDER BY)" $ do
|
||||
describe "ChuSQL.Engine (ORDER BY)" $ do
|
||||
it "parses ORDER BY ASC" $ do
|
||||
case parseQuery "SELECT name FROM users ORDER BY age ASC" of
|
||||
Right q -> selectOrderBy q `shouldBe` [("age", Asc)]
|
||||
@@ -583,7 +583,7 @@ main = hspec $ do
|
||||
-- ============================================================
|
||||
-- Engine: LIMIT
|
||||
-- ============================================================
|
||||
describe "ChuSQL.Eval.Engine (LIMIT)" $ do
|
||||
describe "ChuSQL.Engine (LIMIT)" $ do
|
||||
it "parses LIMIT" $ do
|
||||
case parseQuery "SELECT * FROM users LIMIT 2" of
|
||||
Right q -> selectLimit q `shouldBe` Just 2
|
||||
@@ -666,7 +666,7 @@ main = hspec $ do
|
||||
-- ============================================================
|
||||
-- Engine: JOIN
|
||||
-- ============================================================
|
||||
describe "ChuSQL.Eval.Engine (JOIN)" $ do
|
||||
describe "ChuSQL.Engine (JOIN)" $ do
|
||||
it "executes a two-table JOIN with aliases" $ do
|
||||
rowsOf (parseQuery "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id" >>= runQuery testDB)
|
||||
`shouldBe` Right
|
||||
@@ -834,7 +834,7 @@ main = hspec $ do
|
||||
case parseQuery "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20" of
|
||||
Left err -> expectationFailure err
|
||||
Right q ->
|
||||
case translate testDB q of
|
||||
case translate q of
|
||||
Left err -> expectationFailure err
|
||||
Right relOp ->
|
||||
filterPushedIntoLeft (optimize testDB relOp) `shouldBe` True
|
||||
@@ -843,7 +843,7 @@ main = hspec $ do
|
||||
case parseQuery "SELECT * FROM users" of
|
||||
Left err -> expectationFailure err
|
||||
Right q ->
|
||||
case translate testDB q of
|
||||
case translate q of
|
||||
Left err -> expectationFailure err
|
||||
Right relOp ->
|
||||
optimize testDB relOp `shouldBe` Scan Nothing "users"
|
||||
@@ -857,7 +857,7 @@ main = hspec $ do
|
||||
case parseQuery "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20" of
|
||||
Left err -> expectationFailure err
|
||||
Right q ->
|
||||
case translate testDB q of
|
||||
case translate q of
|
||||
Left err -> expectationFailure err
|
||||
Right relOp ->
|
||||
optimize testDB (optimize testDB relOp) `shouldBe` optimize testDB relOp
|
||||
@@ -980,6 +980,154 @@ main = hspec $ do
|
||||
it "keeps projection with ORDER BY and LIMIT results identical" $ do
|
||||
sameResultAsUnoptimized "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id ORDER BY o.product DESC LIMIT 2"
|
||||
|
||||
-- ============================================================
|
||||
-- Semantic
|
||||
-- ============================================================
|
||||
describe "ChuSQL.Semantic" $ do
|
||||
it "rejects an unknown column in WHERE" $ do
|
||||
(parseQuery "SELECT name FROM users WHERE nope > 18" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects an unknown column in WHERE even when the table is empty" $ do
|
||||
(parseQuery "SELECT name FROM users WHERE nope > 18" >>= runQuery emptyDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects an unknown column in an ON condition" $ do
|
||||
(parseQuery "SELECT u.name FROM users u JOIN orders o ON u.nope = o.user_id" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects a type mismatch inside a comparison" $ do
|
||||
(parseQuery "SELECT name FROM users WHERE name > 18" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects a type mismatch even when the table is empty" $ do
|
||||
(parseQuery "SELECT name FROM users WHERE name > 18" >>= runQuery emptyDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects a WHERE clause that is not a condition" $ do
|
||||
(parseQuery "SELECT name FROM users WHERE age" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects a non-boolean WHERE even when the table is empty" $ do
|
||||
(parseQuery "SELECT name FROM users WHERE age" >>= runQuery emptyDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects comparing two different types with =" $ do
|
||||
(parseQuery "SELECT name FROM users WHERE name = 18" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects an unknown column in INSERT" $ do
|
||||
(parseQuery "INSERT INTO users (nickname) VALUES (1)" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects a value whose type does not match the column" $ do
|
||||
(parseQuery "INSERT INTO users (name, age) VALUES ('Dave', 'abc')" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects an unknown column in UPDATE SET" $ do
|
||||
(parseQuery "UPDATE users SET nope = 1" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects an unknown column in DELETE WHERE" $ do
|
||||
(parseQuery "DELETE FROM users WHERE nope > 1" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "still accepts a valid query" $ do
|
||||
rowsOf (parseQuery "SELECT name FROM users WHERE age > 18" >>= runQuery testDB)
|
||||
`shouldBe` Right
|
||||
[ [("name", VStr "Alice")]
|
||||
, [("name", VStr "Carol")]
|
||||
]
|
||||
|
||||
it "rejects an UPDATE whose value has the wrong type" $ do
|
||||
(parseQuery "UPDATE users SET age = 'abc'" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects a type mismatch in an ON condition" $ do
|
||||
(parseQuery "SELECT u.name FROM users u JOIN orders o ON u.name = o.user_id" >>= runQuery testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects an unknown column in DELETE WHERE even when the table is empty" $ do
|
||||
(parseQuery "DELETE FROM users WHERE nope > 1" >>= runQuery emptyDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "rejects an unknown column in UPDATE SET even when the table is empty" $ do
|
||||
(parseQuery "UPDATE users SET nope = 1" >>= runQuery emptyDB)
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
it "currently allows an INSERT that leaves a column out (known gap)" $ do
|
||||
(parseQuery "INSERT INTO users (name) VALUES ('Eve')" >>= runQuery testDB)
|
||||
`shouldSatisfy` isRight
|
||||
|
||||
it "says which clause is wrong and which columns are available" $ do
|
||||
case parseQuery "SELECT name FROM users WHERE nope > 18" >>= runQuery testDB of
|
||||
Right _ -> expectationFailure "expected a Left"
|
||||
Left err -> do
|
||||
err `shouldContain` "unknown column in WHERE"
|
||||
err `shouldContain` "available: id, name, age"
|
||||
|
||||
it "names INSERT when a target column does not exist" $ do
|
||||
case parseQuery "INSERT INTO users (nickname) VALUES (1)" >>= runQuery testDB of
|
||||
Right _ -> expectationFailure "expected a Left"
|
||||
Left err -> err `shouldContain` "unknown column in INSERT"
|
||||
|
||||
it "names ORDER BY when a sort key does not exist" $ do
|
||||
case parseQuery "SELECT name FROM users ORDER BY nope" >>= runQuery testDB of
|
||||
Right _ -> expectationFailure "expected a Left"
|
||||
Left err -> err `shouldContain` "unknown column in ORDER BY"
|
||||
|
||||
it "names ON and both types when a join condition mismatches" $ do
|
||||
case parseQuery "SELECT u.name FROM users u JOIN orders o ON u.name = o.user_id" >>= runQuery testDB of
|
||||
Right _ -> expectationFailure "expected a Left"
|
||||
Left err -> do
|
||||
err `shouldContain` "ON: both sides of ="
|
||||
err `shouldContain` "TStr and TInt"
|
||||
|
||||
it "names the column and the expected type when an assignment has the wrong type" $ do
|
||||
case parseQuery "UPDATE users SET age = 'abc'" >>= runQuery testDB of
|
||||
Right _ -> expectationFailure "expected a Left"
|
||||
Left err -> err `shouldContain` "UPDATE: column age needs TInt, got TStr"
|
||||
|
||||
it "accepts SELECT * across a join (the sentinel is not a column)" $ do
|
||||
(parseQuery "SELECT * FROM users u JOIN orders o ON u.id = o.user_id" >>= runQuery testDB)
|
||||
`shouldSatisfy` isRight
|
||||
|
||||
-- ============================================================
|
||||
-- Op
|
||||
-- ============================================================
|
||||
describe "ChuSQL.Algebra.Op" $ do
|
||||
it "renders a plan as indented text" $ do
|
||||
case parseQuery "SELECT name FROM users WHERE age > 18" >>= translate of
|
||||
Left err -> expectationFailure err
|
||||
Right plan ->
|
||||
renderPlan plan
|
||||
`shouldBe` "Project [\"name\"]\n Filter Gt (Col \"age\") (LitInt 18)\n Scan Nothing \"users\""
|
||||
|
||||
it "renders a join plan with indentation" $ do
|
||||
case parseQuery "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id" >>= translate of
|
||||
Left err -> expectationFailure err
|
||||
Right plan ->
|
||||
lines (renderPlan plan)
|
||||
`shouldBe` [ "Project [\"u.name\"]"
|
||||
, " Join on Eq (Col \"u.id\") (Col \"o.user_id\")"
|
||||
, " Scan Just \"u\" \"users\""
|
||||
, " Scan Just \"o\" \"orders\""
|
||||
]
|
||||
|
||||
it "renders a sort and limit plan" $ do
|
||||
case parseQuery "SELECT name FROM users ORDER BY age DESC LIMIT 2" >>= translate of
|
||||
Left err -> expectationFailure err
|
||||
Right plan ->
|
||||
lines (renderPlan plan)
|
||||
`shouldBe` [ "Project [\"name\"]"
|
||||
, " Limit 2"
|
||||
, " Sort [(\"age\",Desc)]"
|
||||
, " Scan Nothing \"users\""
|
||||
]
|
||||
|
||||
emptyDB :: Database
|
||||
emptyDB = [(n, t {tableRows = []}) | (n, t) <- testDB]
|
||||
|
||||
-- ============================================================
|
||||
-- Helpers
|
||||
-- ============================================================
|
||||
@@ -987,15 +1135,16 @@ isLeft :: Either a b -> Bool
|
||||
isLeft (Left _) = True
|
||||
isLeft (Right _) = False
|
||||
|
||||
rowsOf :: Either String (Database, [Row]) -> Either String [Row]
|
||||
rowsOf = fmap snd
|
||||
isRight :: Either a b -> Bool
|
||||
isRight (Right _) = True
|
||||
isRight (Left _) = False
|
||||
|
||||
sameResultAsUnoptimized :: String -> Expectation
|
||||
sameResultAsUnoptimized sql =
|
||||
case parseQuery sql of
|
||||
Left err -> expectationFailure err
|
||||
Right q ->
|
||||
case translate testDB q of
|
||||
case translate q of
|
||||
Left err -> expectationFailure err
|
||||
Right relOp ->
|
||||
evalRelOp testDB (optimize testDB relOp) `shouldBe` evalRelOp testDB relOp
|
||||
@@ -1007,7 +1156,7 @@ filterPushedIntoLeft _ = False
|
||||
optimizedPlan :: String -> Either String RelOp
|
||||
optimizedPlan sql = do
|
||||
q <- parseQuery sql
|
||||
optimize testDB <$> translate testDB q
|
||||
optimize testDB <$> translate q
|
||||
|
||||
firstFilterCond :: RelOp -> Maybe Expr
|
||||
firstFilterCond (Filter p _) = Just p
|
||||
@@ -1038,7 +1187,7 @@ stripProjects (Scan a t) = Scan a t
|
||||
projectedPlan :: String -> Either String RelOp
|
||||
projectedPlan sql = do
|
||||
q <- parseQuery sql
|
||||
plan <- translate testDB q
|
||||
plan <- translate q
|
||||
Right (pushProject testDB ["*"] plan)
|
||||
|
||||
sideCols :: RelOp -> Maybe [String]
|
||||
|
||||
@@ -1,87 +0,0 @@
|
||||
# 实现要点
|
||||
|
||||
完整的实现原理相对复杂,故不多赘述,这里阐述一些关键的实现要点
|
||||
|
||||
## Haskell -- 处理引擎
|
||||
|
||||
### 词法分析
|
||||
|
||||
词法层与语法层同处 `chusql-engine/src/ChuSQL/SQLSyntax/Parser.hs`,基于 **megaparsec** 实现。解析器类型为
|
||||
|
||||
```haskell
|
||||
type Parser = Parsec Void String
|
||||
```
|
||||
|
||||
即输入是 `String`,词法错误类型取 `Void`(不自定义错误类型),失败信息统一由 `errorBundlePretty` 渲染成人可读的报文。
|
||||
|
||||
#### 空白与词法单元骨架
|
||||
|
||||
| 组合子 | 定义 | 作用 |
|
||||
| -------- | ------------------------------ | ------------------------------------ |
|
||||
| `sc` | `Lxr.space space1 empty empty` | 跳过空白(含换行);暂不解析注释 |
|
||||
| `lexeme` | `Lxr.lexeme sc` | 解析一个词法单元,并吃掉其后的空白 |
|
||||
| `symbol` | `Lxr.symbol sc` | 固定符号 `*` `,` `=` `>` `<` `(` `)` |
|
||||
|
||||
所有词法单元都从 `lexeme` 出口,游标返回时必定停在下一个 token 的起始位置,因此语法层不需要感知空白。
|
||||
|
||||
#### 已实现的 token
|
||||
|
||||
| token | 组合子 | 词法规则 | 例 |
|
||||
| -------- | ------------ | ------------------------------------------ | ------------------------ |
|
||||
| 关键字 | `keyword` | 大小写不敏感;其后不能紧跟标识符字符 | `SELECT` / `select` |
|
||||
| 标识符 | `identifier` | 首字符为字母或 `_`,其后为字母、数字或 `_` | `users`、`user1`、`_tmp` |
|
||||
| 整数 | `integer` | 十进制,委托 `Lxr.decimal` | `18` |
|
||||
| 字符串 | `stringLit` | 单引号包裹,遵循标准 SQL 转义 | `'Alice'` |
|
||||
| 符号 | `symbol` | 字面匹配 | `>`、`(` |
|
||||
| 排序方向 | `sortDir` | `ASC` / `DESC`,缺省 `Asc` | `DESC` |
|
||||
|
||||
目前已接入语法的关键字:`SELECT`、`FROM`、`WHERE`、`ORDER`、`BY`、`LIMIT`、`AND`、`OR`、`ASC`、`DESC`、`INSERT`、`INTO`、`VALUES`、`DELETE`、`UPDATE`、`SET`。
|
||||
|
||||
#### 三个关键实现点
|
||||
|
||||
**1. 关键字要防前缀**
|
||||
|
||||
`keyword` 匹配完关键字后追加 `notFollowedBy (satisfy isIdentChar)`,否则 `selection` 会被读成 `SELECT`、`fromage` 会被读成 `FROM`。
|
||||
|
||||
**2. 关键字必须可回溯(`try`)**
|
||||
|
||||
```haskell
|
||||
keyword k = lexeme $ try $ do
|
||||
_ <- string' k
|
||||
notFollowedBy (satisfy isIdentChar)
|
||||
```
|
||||
|
||||
`string'` 大小写不敏感,匹配 `ORDER` 时会先吃掉前两个字符 `OR`;紧接着的前缀守卫因为遇到 `D` 而失败,此时输入已被消耗,这个失败就成了**已消耗失败**,调用方的 `many`(`AND` / `OR` 运算符层)不会回溯而是直接报错:
|
||||
|
||||
```text
|
||||
SELECT name FROM users WHERE age > 18 ORDER BY age DESC
|
||||
^ unexpected 'D'
|
||||
```
|
||||
|
||||
把整个 `keyword` 用 `try` 包住,失败即复位,`ORDER BY` 才能被后续子句正常识别。这同时消掉了一整类隐患:任何以 `AND` / `OR` 为前缀的子句关键字跟在表达式后面都不会再炸。
|
||||
|
||||
**3. 字符串字面量不能用 `manyTill`**
|
||||
|
||||
`manyTill p end` 每一步都先尝试结束符,`'It''s ok'` 会在 `''` 的第一个引号处提前收尾。正确做法是先读内容、再吃结尾引号:
|
||||
|
||||
```haskell
|
||||
stringLit = lexeme $ do
|
||||
_ <- char '\''
|
||||
s <- many stringChar
|
||||
_ <- char '\''
|
||||
return s
|
||||
|
||||
stringChar = choice [ '\'' <$ try (string "''"), satisfy (/= '\'') ]
|
||||
```
|
||||
|
||||
`stringChar` 的两个分支在失败时都不消耗输入,因此可以安全地放进 `many`。
|
||||
|
||||
#### 字符串字面量与标准 SQL 转义
|
||||
|
||||
| 写法 | 含义 |
|
||||
| --------- | ------------------------------------------------------- |
|
||||
| `'it''s'` | `''` 折叠为一个单引号,值为 `it's` |
|
||||
| `'a\b'` | 反斜杠是普通字符,值为 `a\b`(**不**做 `\n`/`\t` 转义) |
|
||||
| `''` | 空字符串 |
|
||||
| `''''` | 只含一个单引号的字符串 |
|
||||
| `'oops` | 未闭合,解析失败 |
|
||||
Reference in new issue
Block a user