完成Haskell部分的SQL词法分析器
This commit is contained in:
commit
a9ef1ef3e2
21 files changed
+1547
No files matched your search
+85
@@ -0,0 +1,85 @@
|
|||||||
|
# ============================================================
|
||||||
|
# ChuSQL 单仓库 .gitignore
|
||||||
|
# chusql-engine/ Haskell (Stack + Cabal)
|
||||||
|
# chusql-storage/ Rust (Cargo)
|
||||||
|
# chusql-web/ 前端 (Node / TypeScript)
|
||||||
|
# ============================================================
|
||||||
|
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
# Haskell / Stack / Cabal —— chusql-engine
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
.stack-work/
|
||||||
|
dist-newstyle/
|
||||||
|
dist/
|
||||||
|
*.hi
|
||||||
|
*.o
|
||||||
|
*.hie
|
||||||
|
*.dyn_hi
|
||||||
|
*.dyn_o
|
||||||
|
*.prof
|
||||||
|
*.aux
|
||||||
|
*.hp
|
||||||
|
*.eventlog
|
||||||
|
*.tix
|
||||||
|
.ghc.environment.*
|
||||||
|
cabal.project.local
|
||||||
|
cabal.project.local~
|
||||||
|
|
||||||
|
# 锁文件要入库,不要忽略:
|
||||||
|
# chusql-engine/stack.yaml.lock
|
||||||
|
# cabal.project.freeze
|
||||||
|
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
# Rust / Cargo —— chusql-storage
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
target/
|
||||||
|
**/*.rs.bk
|
||||||
|
|
||||||
|
# Cargo.lock 要入库(本项目是要产出可执行程序的 crate,不是纯库)
|
||||||
|
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
# 前端 / Node —— chusql-web
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
node_modules/
|
||||||
|
.pnpm-store/
|
||||||
|
build/
|
||||||
|
.next/
|
||||||
|
.nuxt/
|
||||||
|
.vite/
|
||||||
|
.angular/
|
||||||
|
coverage/
|
||||||
|
*.tsbuildinfo
|
||||||
|
|
||||||
|
# 环境变量:只提交 .env.example,本地实际配置不入库
|
||||||
|
.env
|
||||||
|
.env.local
|
||||||
|
.env.*.local
|
||||||
|
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
# 日志
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
*.log
|
||||||
|
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
# 编辑器 / IDE
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
.idea/
|
||||||
|
*.iml
|
||||||
|
.vscode/
|
||||||
|
*.swp
|
||||||
|
*.swo
|
||||||
|
*~
|
||||||
|
\#*\#
|
||||||
|
.\#*
|
||||||
|
|
||||||
|
# 注意:.zed/tasks.json 是本仓库共享的构建任务(stack build / run / test / repl),
|
||||||
|
# 需要入库,所以这里不忽略 .zed/
|
||||||
|
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
# 操作系统
|
||||||
|
# ------------------------------------------------------------
|
||||||
|
.DS_Store
|
||||||
|
._*
|
||||||
|
Thumbs.db
|
||||||
|
ehthumbs.db
|
||||||
|
desktop.ini
|
||||||
@@ -0,0 +1,34 @@
|
|||||||
|
[
|
||||||
|
{
|
||||||
|
"label": "stack: build",
|
||||||
|
"command": "stack build",
|
||||||
|
"cwd": "$ZED_WORKTREE_ROOT/chusql-engine",
|
||||||
|
"reveal": "always",
|
||||||
|
"hide": "on_success",
|
||||||
|
"save": "all",
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"label": "stack: run",
|
||||||
|
"command": "stack run",
|
||||||
|
"cwd": "$ZED_WORKTREE_ROOT/chusql-engine",
|
||||||
|
"reveal": "always",
|
||||||
|
"hide": "never",
|
||||||
|
"save": "all",
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"label": "stack: test",
|
||||||
|
"command": "stack test",
|
||||||
|
"cwd": "$ZED_WORKTREE_ROOT/chusql-engine",
|
||||||
|
"reveal": "always",
|
||||||
|
"hide": "never",
|
||||||
|
"save": "all",
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"label": "stack: repl",
|
||||||
|
"command": "stack ghci",
|
||||||
|
"cwd": "$ZED_WORKTREE_ROOT/chusql-engine",
|
||||||
|
"reveal": "always",
|
||||||
|
"hide": "never",
|
||||||
|
"save": "all",
|
||||||
|
},
|
||||||
|
]
|
||||||
@@ -0,0 +1,21 @@
|
|||||||
|
MIT License
|
||||||
|
|
||||||
|
Copyright (c) 2026 TheBadRoger
|
||||||
|
|
||||||
|
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||||
|
of this software and associated documentation files (the "Software"), to deal
|
||||||
|
in the Software without restriction, including without limitation the rights
|
||||||
|
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||||
|
copies of the Software, and to permit persons to whom the Software is
|
||||||
|
furnished to do so, subject to the following conditions:
|
||||||
|
|
||||||
|
The above copyright notice and this permission notice shall be included in all
|
||||||
|
copies or substantial portions of the Software.
|
||||||
|
|
||||||
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||||
|
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||||
|
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||||
|
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||||
|
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||||
|
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||||
|
SOFTWARE.
|
||||||
@@ -0,0 +1,44 @@
|
|||||||
|
# ChuSQL
|
||||||
|
|
||||||
|
本项目是一个简单的数据库项目,服务端采用Haskell和Rust联合编写,采取B/S模式,管理客户端运行在浏览器网页上。
|
||||||
|
|
||||||
|
## 仓库布局
|
||||||
|
|
||||||
|
| 目录 | 语言 | 组件 |
|
||||||
|
| ----------------- | ------- | ----------------------------------------------------------------- |
|
||||||
|
| `chusql-engine/` | Haskell | 执行引擎:词法分析与AST、表达式求值、关系代数、内存表、服务端接口 |
|
||||||
|
| `chusql-storage/` | Rust | 存储引擎:磁盘IO、B+树、缓冲池、WAL、崩溃恢复、并发控制 |
|
||||||
|
| `chusql-web/` | 前端 | 浏览器端管理客户端 |
|
||||||
|
|
||||||
|
详细架构、模块职责与构建目标见 [ARCHITECTURE.md](ARCHITECTURE.md)。
|
||||||
|
|
||||||
|
# 架构分层
|
||||||
|
|
||||||
|
## Haskell部分
|
||||||
|
|
||||||
|
作为函数式编程语言,从语言层面契合SQL语句解析和代数数学运算,同时有强大的类型安全系统。
|
||||||
|
|
||||||
|
- SQL词法分析、AST
|
||||||
|
- 事务处理
|
||||||
|
- 查询优化、内存表管理
|
||||||
|
- 关系代数运算
|
||||||
|
- 服务端接口与请求相应
|
||||||
|
|
||||||
|
## Rust部分
|
||||||
|
|
||||||
|
高性能、内存安全且具有强大并行异步编程能力的现代编程语言。
|
||||||
|
|
||||||
|
- 磁盘IO
|
||||||
|
- B+树、页面管理
|
||||||
|
- 缓冲池
|
||||||
|
- WAL
|
||||||
|
- 事务日志和崩溃恢复
|
||||||
|
- 并发控制
|
||||||
|
|
||||||
|
## 前端部分
|
||||||
|
|
||||||
|
- 前端部分目前还没想好选型架构,暂且使用简单前端三件套做一个简单的仿CLI WebUI即可。后期可能会加上Rust编写的CLI前端
|
||||||
|
|
||||||
|
> Rust和Haskell部分的通信通过管道实现,后期跨平台到Linux后使用Unix Domain Socket
|
||||||
|
|
||||||
|
> 如果找到了较好的Rust+Haskell集成方法也会及时替换
|
||||||
@@ -0,0 +1,52 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import ChuSQL.Eval.Executor
|
||||||
|
import ChuSQL.Model
|
||||||
|
import ChuSQL.Syntax.Ast
|
||||||
|
import ChuSQL.Syntax.Parser
|
||||||
|
|
||||||
|
users :: Table
|
||||||
|
users =
|
||||||
|
Table
|
||||||
|
{ tableName = "users"
|
||||||
|
, tableCols = ["name", "age"]
|
||||||
|
, tableRows =
|
||||||
|
[ [("name", VStr "Alice"), ("age", VInt 25)]
|
||||||
|
, [("name", VStr "Bob"), ("age", VInt 17)]
|
||||||
|
, [("name", VStr "Carol"), ("age", VInt 30)]
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
|
db :: Database
|
||||||
|
db = [("users", users)]
|
||||||
|
|
||||||
|
-- runQuery 返回 (更新后的数据库, 结果行);演示只关心结果行
|
||||||
|
rowsOf :: Either String (Database, [Row]) -> Either String [Row]
|
||||||
|
rowsOf = fmap snd
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
let q1 = makeSelect ["name"] "users" (Just (Gt (Col "age") (LitInt 18)))
|
||||||
|
print (rowsOf (runQuery db q1))
|
||||||
|
|
||||||
|
let q2 = makeSelect ["*"] "users" Nothing
|
||||||
|
print (rowsOf (runQuery db q2))
|
||||||
|
|
||||||
|
let q3 = makeSelect ["name"] "nonexistent" Nothing
|
||||||
|
print (rowsOf (runQuery db q3))
|
||||||
|
|
||||||
|
let q4 =
|
||||||
|
makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
( Just
|
||||||
|
( Or
|
||||||
|
(Lt (Col "age") (LitInt 18))
|
||||||
|
(Gt (Col "age") (LitInt 30))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
print (rowsOf (runQuery db q4))
|
||||||
|
|
||||||
|
-- 解析 SQL 文本,再交给执行引擎
|
||||||
|
let parsed = parseQuery "SELECT name FROM users WHERE age > 18 AND name = 'Alice'"
|
||||||
|
print (rowsOf (parsed >>= runQuery db))
|
||||||
@@ -0,0 +1,40 @@
|
|||||||
|
cabal-version: 2.4
|
||||||
|
|
||||||
|
name: chusql-engine
|
||||||
|
version: 1.0.0
|
||||||
|
synopsis: ChuSQL 执行引擎:SQL 词法与语法分析、表达式求值
|
||||||
|
description: ChuSQL 服务端执行引擎。负责 SQL 词法分析与 AST 构建、
|
||||||
|
WHERE 条件表达式求值、关系代数运算与内存表管理。
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
library
|
||||||
|
hs-source-dirs: src
|
||||||
|
exposed-modules: ChuSQL.Syntax.Ast
|
||||||
|
ChuSQL.Syntax.Parser
|
||||||
|
ChuSQL.Model
|
||||||
|
ChuSQL.Eval.Expr
|
||||||
|
ChuSQL.Eval.Sort
|
||||||
|
ChuSQL.Eval.Executor
|
||||||
|
build-depends: base >= 4.14 && < 5
|
||||||
|
, megaparsec
|
||||||
|
, parser-combinators
|
||||||
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall
|
||||||
|
|
||||||
|
executable chusql-engine
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs: app
|
||||||
|
build-depends: base
|
||||||
|
, chusql-engine
|
||||||
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall
|
||||||
|
|
||||||
|
test-suite chusql-engine-test
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
main-is: Spec.hs
|
||||||
|
hs-source-dirs: test
|
||||||
|
build-depends: base
|
||||||
|
, chusql-engine
|
||||||
|
, hspec
|
||||||
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall
|
||||||
Whitespace-only changes.
@@ -0,0 +1,104 @@
|
|||||||
|
module ChuSQL.Eval.Executor where
|
||||||
|
|
||||||
|
import ChuSQL.Eval.Expr
|
||||||
|
import ChuSQL.Eval.Sort
|
||||||
|
import ChuSQL.Model
|
||||||
|
import ChuSQL.Syntax.Ast
|
||||||
|
import Control.Monad (filterM)
|
||||||
|
|
||||||
|
-- | 带限制的排序
|
||||||
|
applyLimit :: Maybe Int -> [Row] -> [Row]
|
||||||
|
applyLimit Nothing rows = rows
|
||||||
|
applyLimit (Just n) rows = take n rows
|
||||||
|
|
||||||
|
-- 表里加新行
|
||||||
|
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)
|
||||||
|
|
||||||
|
-- 修改表
|
||||||
|
applyUpdates :: [(String, Expr)] -> Row -> Either String Row
|
||||||
|
applyUpdates [] row = Right row
|
||||||
|
applyUpdates ((col, e) : rest) row = do
|
||||||
|
v <- evalExpr e row
|
||||||
|
let row' = setColumn col v row
|
||||||
|
applyUpdates rest row'
|
||||||
|
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
|
||||||
|
Select
|
||||||
|
{ selectCols = cols
|
||||||
|
, selectTable = tbl
|
||||||
|
, selectWhere = mWhere
|
||||||
|
, selectOrderBy = orderBy
|
||||||
|
, selectLimit = mLimit
|
||||||
|
} = do
|
||||||
|
table <- maybe (Left ("unknown table: " ++ tbl)) Right (lookup tbl db)
|
||||||
|
_ <- checkColumns (tableCols table) cols
|
||||||
|
_ <- checkColumns (tableCols table) (map fst orderBy)
|
||||||
|
rows <- case mWhere of
|
||||||
|
Nothing -> Right (tableRows table)
|
||||||
|
Just e -> filterM (evalCondForRow e) (tableRows table)
|
||||||
|
let sorted = sortRows orderBy rows
|
||||||
|
limited = applyLimit mLimit sorted
|
||||||
|
Right (db, map (project cols) limited)
|
||||||
|
where
|
||||||
|
project :: [String] -> Row -> Row
|
||||||
|
project ["*"] row = row
|
||||||
|
project cs row = [(c, v) | (c, v) <- row, c `elem` cs]
|
||||||
|
|
||||||
|
-- 处理插入
|
||||||
|
runQuery 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
|
||||||
|
let newRow = zip cols values
|
||||||
|
db' <-
|
||||||
|
updateTable
|
||||||
|
tbl
|
||||||
|
(\t -> t{tableRows = tableRows t ++ [newRow]})
|
||||||
|
db
|
||||||
|
Right (db', [])
|
||||||
|
|
||||||
|
-- 处理删除
|
||||||
|
runQuery db (Delete tbl mWhere) = do
|
||||||
|
table <- maybe (Left ("unknown table: " ++ tbl)) Right (lookup tbl db)
|
||||||
|
rows <- case mWhere of
|
||||||
|
Nothing -> Right []
|
||||||
|
Just e -> filterM (shouldKeep e) (tableRows table)
|
||||||
|
db' <- updateTable tbl (\t -> t{tableRows = rows}) db
|
||||||
|
Right (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)
|
||||||
|
rows <- mapM (updateRow mWhere assigns) (tableRows table)
|
||||||
|
db' <- updateTable tbl (\t -> t{tableRows = rows}) db
|
||||||
|
Right (db', [])
|
||||||
|
where
|
||||||
|
updateRow :: Maybe Expr -> [(String, Expr)] -> Row -> Either String Row
|
||||||
|
updateRow cond asgns row = do
|
||||||
|
keep <- case cond of
|
||||||
|
Nothing -> Right True
|
||||||
|
Just e -> evalCondForRow e row
|
||||||
|
if keep
|
||||||
|
then applyUpdates asgns row
|
||||||
|
else Right row
|
||||||
|
|
||||||
|
-- 显式请求的列必须存在(@*@ 表示全部列),避免静默返回一堆空行
|
||||||
|
checkColumns :: [String] -> [String] -> Either String ()
|
||||||
|
checkColumns available requested =
|
||||||
|
case [c | c <- requested, c /= "*", c `notElem` available] of
|
||||||
|
[] -> Right ()
|
||||||
|
(c : _) -> Left ("unknown column: " ++ c)
|
||||||
@@ -0,0 +1,48 @@
|
|||||||
|
module ChuSQL.Eval.Expr where
|
||||||
|
|
||||||
|
import ChuSQL.Model
|
||||||
|
import ChuSQL.Syntax.Ast
|
||||||
|
import Control.Monad (join)
|
||||||
|
|
||||||
|
-- 表达式求值
|
||||||
|
evalExpr :: Expr -> Row -> Either String Value
|
||||||
|
evalExpr (Col name) row =
|
||||||
|
maybe (Left ("unknown column: " ++ name)) Right (lookup name row)
|
||||||
|
evalExpr (LitInt n) _ = Right (VInt n)
|
||||||
|
evalExpr (LitStr s) _ = Right (VStr s)
|
||||||
|
evalExpr (Gt a b) row = liftBinOp (intOp (>)) a b row
|
||||||
|
evalExpr (Lt a b) row = liftBinOp (intOp (<)) a b row
|
||||||
|
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
|
||||||
|
|
||||||
|
-- 对行计算条件语句
|
||||||
|
evalCondForRow :: Expr -> Row -> Either String Bool
|
||||||
|
evalCondForRow e row = do
|
||||||
|
v <- evalExpr e row
|
||||||
|
case v of
|
||||||
|
VBool b -> Right b
|
||||||
|
_ -> Left "type error: WHERE condition must be a boolean"
|
||||||
|
|
||||||
|
-- 固定模式:对两个子表达式求值,并返还给二元操作符
|
||||||
|
liftBinOp ::
|
||||||
|
(Value -> Value -> Either String Value) ->
|
||||||
|
Expr ->
|
||||||
|
Expr ->
|
||||||
|
Row ->
|
||||||
|
Either String Value
|
||||||
|
liftBinOp f a b row = join (f <$> evalExpr a row <*> evalExpr b row)
|
||||||
|
|
||||||
|
-- 整数比较
|
||||||
|
intOp :: (Int -> Int -> Bool) -> Value -> Value -> Either String Value
|
||||||
|
intOp f (VInt x) (VInt y) = Right (VBool (f x y))
|
||||||
|
intOp _ _ _ = Left "type error: expected two integers"
|
||||||
|
|
||||||
|
-- 布尔运算
|
||||||
|
boolOp :: (Bool -> Bool -> Bool) -> Value -> Value -> Either String Value
|
||||||
|
boolOp f (VBool x) (VBool y) = Right (VBool (f x y))
|
||||||
|
boolOp _ _ _ = Left "type error: expected two booleans"
|
||||||
|
|
||||||
|
-- 相等比较
|
||||||
|
eqOp :: Value -> Value -> Either String Value
|
||||||
|
eqOp x y = Right (VBool (x == y))
|
||||||
@@ -0,0 +1,37 @@
|
|||||||
|
module ChuSQL.Eval.Sort where
|
||||||
|
|
||||||
|
import ChuSQL.Model
|
||||||
|
import ChuSQL.Syntax.Ast
|
||||||
|
import Data.List (sortBy)
|
||||||
|
|
||||||
|
-- | 反向排序
|
||||||
|
flipOrdering :: Ordering -> Ordering
|
||||||
|
flipOrdering LT = GT
|
||||||
|
flipOrdering GT = LT
|
||||||
|
flipOrdering EQ = EQ
|
||||||
|
|
||||||
|
-- | 定义值的比较规则
|
||||||
|
compareValue :: Value -> Value -> Ordering
|
||||||
|
compareValue (VInt a) (VInt b) = compare a b
|
||||||
|
compareValue (VStr a) (VStr b) = compare a b
|
||||||
|
compareValue (VBool a) (VBool b) = compare a b
|
||||||
|
compareValue _ _ = EQ
|
||||||
|
|
||||||
|
-- | 定义行的比较规则
|
||||||
|
compareRows :: [(String, SortDir)] -> Row -> Row -> Ordering
|
||||||
|
compareRows [] _ _ = EQ
|
||||||
|
compareRows ((col, dir) : rest) r1 r2 =
|
||||||
|
case (lookup col r1, lookup col r2) of
|
||||||
|
(Just v1, Just v2) ->
|
||||||
|
case compareValue v1 v2 of
|
||||||
|
EQ -> compareRows rest r1 r2
|
||||||
|
o ->
|
||||||
|
if dir == Desc
|
||||||
|
then flipOrdering o
|
||||||
|
else o
|
||||||
|
_ -> compareRows rest r1 r2
|
||||||
|
|
||||||
|
-- | 将表的每行排序
|
||||||
|
sortRows :: [(String, SortDir)] -> [Row] -> [Row]
|
||||||
|
sortRows [] rows = rows
|
||||||
|
sortRows spec rows = sortBy (compareRows spec) rows
|
||||||
@@ -0,0 +1,22 @@
|
|||||||
|
module ChuSQL.Model where
|
||||||
|
|
||||||
|
-- 列的值:整数、字符串、布尔
|
||||||
|
data Value
|
||||||
|
= VInt Int
|
||||||
|
| VStr String
|
||||||
|
| VBool Bool
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
-- 一行:列名 → 值
|
||||||
|
type Row = [(String, Value)]
|
||||||
|
|
||||||
|
-- 一张表
|
||||||
|
data Table = Table
|
||||||
|
{ tableName :: String
|
||||||
|
, tableCols :: [String]
|
||||||
|
, tableRows :: [Row]
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
-- 数据库:多张表
|
||||||
|
type Database = [(String, Table)]
|
||||||
Whitespace-only changes.
Whitespace-only changes.
@@ -0,0 +1,42 @@
|
|||||||
|
module ChuSQL.Syntax.Ast where
|
||||||
|
|
||||||
|
-- 查询语句
|
||||||
|
data Query
|
||||||
|
= Select
|
||||||
|
{ selectCols :: [String]
|
||||||
|
, selectTable :: String
|
||||||
|
, selectWhere :: Maybe Expr
|
||||||
|
, selectOrderBy :: [(String, SortDir)]
|
||||||
|
, selectLimit :: Maybe Int
|
||||||
|
}
|
||||||
|
| Insert String [String] [Expr]
|
||||||
|
| Delete String (Maybe Expr)
|
||||||
|
| Update String [(String, Expr)] (Maybe Expr)
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
-- 条件表达式
|
||||||
|
data Expr
|
||||||
|
= Col String
|
||||||
|
| LitInt Int
|
||||||
|
| LitStr String
|
||||||
|
| Gt Expr Expr
|
||||||
|
| Lt Expr Expr
|
||||||
|
| Eq Expr Expr
|
||||||
|
| And Expr Expr
|
||||||
|
| Or Expr Expr
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
data SortDir
|
||||||
|
= Asc
|
||||||
|
| Desc
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
makeSelect :: [String] -> String -> Maybe Expr -> Query
|
||||||
|
makeSelect cols tbl w =
|
||||||
|
Select
|
||||||
|
{ selectCols = cols
|
||||||
|
, selectTable = tbl
|
||||||
|
, selectWhere = w
|
||||||
|
, selectOrderBy = []
|
||||||
|
, selectLimit = Nothing
|
||||||
|
}
|
||||||
@@ -0,0 +1,213 @@
|
|||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
|
||||||
|
{- | SQL 语法分析器:把 SQL 文本解析为 'ChuSQL.Syntax.Ast.Query'。
|
||||||
|
|
||||||
|
词法层负责空白、关键字、标识符、字面量与符号;语法层按
|
||||||
|
优先级 比较 > AND > OR 自底向上组装表达式。
|
||||||
|
-}
|
||||||
|
module ChuSQL.Syntax.Parser (
|
||||||
|
Parser,
|
||||||
|
parseQuery,
|
||||||
|
expr,
|
||||||
|
identifier,
|
||||||
|
integer,
|
||||||
|
stringLit,
|
||||||
|
) where
|
||||||
|
|
||||||
|
import ChuSQL.Syntax.Ast
|
||||||
|
import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
|
||||||
|
import Data.Char (isAlpha, isAlphaNum)
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
|
import Data.Void (Void)
|
||||||
|
import Text.Megaparsec
|
||||||
|
import Text.Megaparsec.Char
|
||||||
|
import Text.Megaparsec.Char.Lexer qualified as Lxr
|
||||||
|
|
||||||
|
type Parser = Parsec Void String
|
||||||
|
|
||||||
|
-- * 词法层
|
||||||
|
|
||||||
|
-- | 跳过空白(含换行)。
|
||||||
|
sc :: Parser ()
|
||||||
|
sc = Lxr.space space1 empty empty
|
||||||
|
|
||||||
|
-- | 消费一个词法单元以及其后的空白。
|
||||||
|
lexeme :: Parser a -> Parser a
|
||||||
|
lexeme = Lxr.lexeme sc
|
||||||
|
|
||||||
|
symbol :: String -> Parser String
|
||||||
|
symbol = Lxr.symbol sc
|
||||||
|
|
||||||
|
{- | 大小写不敏感的关键字;其后不能紧跟标识符字符,避免把 @selection@ 读成 @select@。
|
||||||
|
整体用 'try' 包住:否则 @ORDER@ 会被 @keyword "or"@ 吃掉前缀 @OR@ 再报错,导致无法回溯。
|
||||||
|
-}
|
||||||
|
keyword :: String -> Parser ()
|
||||||
|
keyword k = lexeme $ try $ do
|
||||||
|
_ <- string' k
|
||||||
|
notFollowedBy (satisfy isIdentChar)
|
||||||
|
|
||||||
|
-- | 标识符:字母或下划线开头,其后可跟字母、数字或下划线。
|
||||||
|
identifier :: Parser String
|
||||||
|
identifier = lexeme $ do
|
||||||
|
first <- satisfy (\ch -> isAlpha ch || ch == '_')
|
||||||
|
rest <- many (satisfy isIdentChar)
|
||||||
|
return (first : rest)
|
||||||
|
|
||||||
|
isIdentChar :: Char -> Bool
|
||||||
|
isIdentChar ch = isAlphaNum ch || ch == '_'
|
||||||
|
|
||||||
|
-- | 十进制整数字面量。
|
||||||
|
integer :: Parser Int
|
||||||
|
integer = lexeme Lxr.decimal
|
||||||
|
|
||||||
|
-- | 单引号字符串字面量,遵循标准 SQL 转义规则:
|
||||||
|
stringLit :: Parser String
|
||||||
|
stringLit = lexeme $ do
|
||||||
|
_ <- char '\''
|
||||||
|
s <- many stringChar
|
||||||
|
_ <- char '\''
|
||||||
|
return s
|
||||||
|
|
||||||
|
{- | 字符串内的一个字符:@''@ 折叠成一个单引号,其余字符(含反斜杠)原样保留。
|
||||||
|
两个分支都不会在失败时消耗输入,因此可以安全地放进 'many'。
|
||||||
|
-}
|
||||||
|
stringChar :: Parser Char
|
||||||
|
stringChar =
|
||||||
|
choice
|
||||||
|
[ '\'' <$ try (string "''")
|
||||||
|
, satisfy (/= '\'')
|
||||||
|
]
|
||||||
|
|
||||||
|
-- | 解析 ASC/DESC
|
||||||
|
sortDir :: Parser SortDir
|
||||||
|
sortDir = (Desc <$ keyword "desc") <|> (Asc <$ keyword "asc") <|> pure Asc
|
||||||
|
|
||||||
|
-- | 解析 LIMIT
|
||||||
|
limitClause :: Parser Int
|
||||||
|
limitClause = do
|
||||||
|
keyword "limit"
|
||||||
|
integer
|
||||||
|
|
||||||
|
-- * 表达式层
|
||||||
|
|
||||||
|
-- | 表达式入口,最低优先级。
|
||||||
|
expr :: Parser Expr
|
||||||
|
expr = makeExprParser atom operatorTable
|
||||||
|
|
||||||
|
{- | 运算符表。注意 'makeExprParser' 要求各层 **按优先级从高到低** 排列:
|
||||||
|
比较运算符绑定最紧,'AND' 次之,'OR' 最松。
|
||||||
|
-}
|
||||||
|
operatorTable :: [[Operator Parser Expr]]
|
||||||
|
operatorTable =
|
||||||
|
[
|
||||||
|
[ InfixN (Gt <$ symbol ">") -- 最高优先级
|
||||||
|
, InfixN (Lt <$ symbol "<")
|
||||||
|
, InfixN (Eq <$ symbol "=")
|
||||||
|
]
|
||||||
|
, [InfixL (And <$ keyword "AND")]
|
||||||
|
, [InfixL (Or <$ keyword "OR")] -- 最低优先级
|
||||||
|
]
|
||||||
|
|
||||||
|
-- | 原子表达式:字面量、列引用或括号表达式。
|
||||||
|
atom :: Parser Expr
|
||||||
|
atom =
|
||||||
|
choice
|
||||||
|
[ LitInt <$> integer
|
||||||
|
, LitStr <$> stringLit
|
||||||
|
, Col <$> identifier
|
||||||
|
, between (symbol "(") (symbol ")") expr
|
||||||
|
]
|
||||||
|
|
||||||
|
-- * 语句层
|
||||||
|
|
||||||
|
-- | 显式指定排序的语句
|
||||||
|
orderItem :: Parser (String, SortDir)
|
||||||
|
orderItem = do
|
||||||
|
col <- identifier
|
||||||
|
dir <- sortDir
|
||||||
|
return (col, dir)
|
||||||
|
|
||||||
|
orderByClause :: Parser [(String, SortDir)]
|
||||||
|
orderByClause = do
|
||||||
|
keyword "order"
|
||||||
|
keyword "by"
|
||||||
|
sepBy1 orderItem (symbol ",")
|
||||||
|
|
||||||
|
assignment :: Parser (String, Expr)
|
||||||
|
assignment = do
|
||||||
|
col <- identifier
|
||||||
|
_ <- symbol "="
|
||||||
|
e <- expr
|
||||||
|
return (col, e)
|
||||||
|
|
||||||
|
-- | 选择列表:@*@ 或逗号分隔的列名。
|
||||||
|
selectList :: Parser [String]
|
||||||
|
selectList =
|
||||||
|
choice
|
||||||
|
[ ["*"] <$ symbol "*"
|
||||||
|
, (:) <$> identifier <*> many (symbol "," *> identifier)
|
||||||
|
]
|
||||||
|
|
||||||
|
-- | @SELECT ... FROM ... [WHERE ...]@。
|
||||||
|
selectQuery :: Parser Query
|
||||||
|
selectQuery = do
|
||||||
|
_ <- keyword "select"
|
||||||
|
cols <- selectList
|
||||||
|
_ <- keyword "from"
|
||||||
|
tableName <- identifier
|
||||||
|
mWhere <- optional (keyword "where" *> expr)
|
||||||
|
orderBy <- fromMaybe [] <$> optional orderByClause
|
||||||
|
mLimit <- optional limitClause
|
||||||
|
return
|
||||||
|
Select
|
||||||
|
{ selectCols = cols
|
||||||
|
, selectTable = tableName
|
||||||
|
, selectWhere = mWhere
|
||||||
|
, selectOrderBy = orderBy
|
||||||
|
, selectLimit = mLimit
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | @INSERT ... INTO ... VALUES ...@。
|
||||||
|
insertQuery :: Parser Query
|
||||||
|
insertQuery = do
|
||||||
|
keyword "INSERT"
|
||||||
|
keyword "INTO"
|
||||||
|
tbl <- identifier
|
||||||
|
cols <-
|
||||||
|
between
|
||||||
|
(symbol "(")
|
||||||
|
(symbol ")")
|
||||||
|
(sepBy1 identifier (symbol ","))
|
||||||
|
keyword "VALUES"
|
||||||
|
vals <-
|
||||||
|
between
|
||||||
|
(symbol "(")
|
||||||
|
(symbol ")")
|
||||||
|
(sepBy1 atom (symbol ","))
|
||||||
|
return (Insert tbl cols vals)
|
||||||
|
|
||||||
|
-- | @DELETE ... FROM ... [WHERE ...]@。
|
||||||
|
deleteQuery :: Parser Query
|
||||||
|
deleteQuery = do
|
||||||
|
keyword "DELETE"
|
||||||
|
keyword "FROM"
|
||||||
|
tbl <- identifier
|
||||||
|
mWhere <- optional (keyword "WHERE" *> expr)
|
||||||
|
return (Delete tbl mWhere)
|
||||||
|
|
||||||
|
-- | UPDATE ... SET col = val, ... [WHERE ...]@
|
||||||
|
updateQuery :: Parser Query
|
||||||
|
updateQuery = do
|
||||||
|
keyword "update"
|
||||||
|
tbl <- identifier
|
||||||
|
keyword "set"
|
||||||
|
assigns <- sepBy1 assignment (symbol ",")
|
||||||
|
mWhere <- optional (keyword "where" *> expr)
|
||||||
|
return (Update tbl assigns mWhere)
|
||||||
|
|
||||||
|
-- | 解析一条完整的语句;失败时返回可直接展示的错误信息。
|
||||||
|
parseQuery :: String -> Either String Query
|
||||||
|
parseQuery input =
|
||||||
|
case runParser (sc *> (selectQuery <|> insertQuery <|> deleteQuery <|> updateQuery) <* sc <* eof) "<query>" input of
|
||||||
|
Left err -> Left (errorBundlePretty err)
|
||||||
|
Right q -> Right q
|
||||||
@@ -0,0 +1,4 @@
|
|||||||
|
resolver: lts-24.59
|
||||||
|
|
||||||
|
packages:
|
||||||
|
- .
|
||||||
@@ -0,0 +1,12 @@
|
|||||||
|
# This file was autogenerated by Stack.
|
||||||
|
# You should not edit this file by hand.
|
||||||
|
# For more information, please see the documentation at:
|
||||||
|
# https://docs.haskellstack.org/en/stable/topics/lock_files
|
||||||
|
|
||||||
|
packages: []
|
||||||
|
snapshots:
|
||||||
|
- completed:
|
||||||
|
sha256: 0f728e30e843d7f00460ad56858b995a3b227fca683659c7df9f2fc3988a3ce1
|
||||||
|
size: 732465
|
||||||
|
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/59.yaml
|
||||||
|
original: lts-24.59
|
||||||
@@ -0,0 +1,702 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import ChuSQL.Eval.Executor
|
||||||
|
import ChuSQL.Model
|
||||||
|
import ChuSQL.Syntax.Ast
|
||||||
|
import ChuSQL.Syntax.Parser
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
-- Test database
|
||||||
|
testDB :: Database
|
||||||
|
testDB = [("users", users)]
|
||||||
|
where
|
||||||
|
users =
|
||||||
|
Table
|
||||||
|
{ tableName = "users"
|
||||||
|
, tableCols = ["name", "age"]
|
||||||
|
, tableRows =
|
||||||
|
[ [("name", VStr "Alice"), ("age", VInt 25)]
|
||||||
|
, [("name", VStr "Bob"), ("age", VInt 17)]
|
||||||
|
, [("name", VStr "Carol"), ("age", VInt 30)]
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = hspec $ do
|
||||||
|
-- ============================================================
|
||||||
|
-- AST
|
||||||
|
-- ============================================================
|
||||||
|
describe "ChuSQL.Syntax.Ast" $ do
|
||||||
|
it "shows a Select without WHERE" $ do
|
||||||
|
show (makeSelect ["name"] "users" Nothing)
|
||||||
|
`shouldBe` "Select {selectCols = [\"name\"], selectTable = \"users\", \
|
||||||
|
\selectWhere = Nothing, selectOrderBy = [], selectLimit = Nothing}"
|
||||||
|
|
||||||
|
it "equal Selects are equal" $ do
|
||||||
|
makeSelect ["name"] "users" Nothing
|
||||||
|
`shouldBe` makeSelect ["name"] "users" Nothing
|
||||||
|
|
||||||
|
it "different Selects are not equal" $ do
|
||||||
|
makeSelect ["name"] "users" Nothing
|
||||||
|
`shouldNotBe` makeSelect ["age"] "users" Nothing
|
||||||
|
|
||||||
|
-- ============================================================
|
||||||
|
-- Parser
|
||||||
|
-- ============================================================
|
||||||
|
describe "ChuSQL.Syntax.Parser" $ do
|
||||||
|
it "parses a simple SELECT" $ do
|
||||||
|
parseQuery "SELECT name FROM users"
|
||||||
|
`shouldBe` Right (makeSelect ["name"] "users" Nothing)
|
||||||
|
|
||||||
|
it "parses SELECT *" $ do
|
||||||
|
parseQuery "SELECT * FROM users"
|
||||||
|
`shouldBe` Right (makeSelect ["*"] "users" Nothing)
|
||||||
|
|
||||||
|
it "parses multiple columns" $ do
|
||||||
|
parseQuery "SELECT name, age FROM users"
|
||||||
|
`shouldBe` Right (makeSelect ["name", "age"] "users" Nothing)
|
||||||
|
|
||||||
|
it "parses WHERE with >" $ do
|
||||||
|
parseQuery "SELECT name FROM users WHERE age > 18"
|
||||||
|
`shouldBe` Right
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
(Just (Gt (Col "age") (LitInt 18)))
|
||||||
|
)
|
||||||
|
|
||||||
|
it "parses AND" $ do
|
||||||
|
parseQuery "SELECT name FROM users WHERE age > 18 AND age < 30"
|
||||||
|
`shouldBe` Right
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
( Just
|
||||||
|
( And
|
||||||
|
(Gt (Col "age") (LitInt 18))
|
||||||
|
(Lt (Col "age") (LitInt 30))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
it "parses OR" $ do
|
||||||
|
parseQuery "SELECT name FROM users WHERE age < 18 OR age > 60"
|
||||||
|
`shouldBe` Right
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
( Just
|
||||||
|
( Or
|
||||||
|
(Lt (Col "age") (LitInt 18))
|
||||||
|
(Gt (Col "age") (LitInt 60))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
it "is case-insensitive for keywords" $ do
|
||||||
|
parseQuery "select name from users where age > 18"
|
||||||
|
`shouldBe` Right
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
(Just (Gt (Col "age") (LitInt 18)))
|
||||||
|
)
|
||||||
|
|
||||||
|
it "tolerates extra whitespace" $ do
|
||||||
|
parseQuery "SELECT name FROM users"
|
||||||
|
`shouldBe` Right (makeSelect ["name"] "users" Nothing)
|
||||||
|
|
||||||
|
it "parses a string literal in WHERE" $ do
|
||||||
|
parseQuery "SELECT name FROM users WHERE name = 'Alice'"
|
||||||
|
`shouldBe` Right
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
(Just (Eq (Col "name") (LitStr "Alice")))
|
||||||
|
)
|
||||||
|
|
||||||
|
it "uses standard SQL escaping: '' is one quote" $ do
|
||||||
|
parseQuery "SELECT name FROM users WHERE name = 'It''s ok'"
|
||||||
|
`shouldBe` Right
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
(Just (Eq (Col "name") (LitStr "It's ok")))
|
||||||
|
)
|
||||||
|
|
||||||
|
it "treats a backslash as an ordinary character" $ do
|
||||||
|
parseQuery "SELECT name FROM users WHERE name = 'a\\b'"
|
||||||
|
`shouldBe` Right
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
(Just (Eq (Col "name") (LitStr "a\\b")))
|
||||||
|
)
|
||||||
|
|
||||||
|
it "parses an empty string literal" $ do
|
||||||
|
parseQuery "SELECT name FROM users WHERE name = ''"
|
||||||
|
`shouldBe` Right
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
(Just (Eq (Col "name") (LitStr "")))
|
||||||
|
)
|
||||||
|
|
||||||
|
it "parses a string that is a single quote" $ do
|
||||||
|
parseQuery "SELECT name FROM users WHERE name = ''''"
|
||||||
|
`shouldBe` Right
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
(Just (Eq (Col "name") (LitStr "'")))
|
||||||
|
)
|
||||||
|
|
||||||
|
it "rejects an unterminated string literal" $ do
|
||||||
|
parseQuery "SELECT name FROM users WHERE name = 'oops"
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "allows digits inside identifiers" $ do
|
||||||
|
parseQuery "SELECT user1 FROM users"
|
||||||
|
`shouldBe` Right (makeSelect ["user1"] "users" Nothing)
|
||||||
|
|
||||||
|
it "honours parentheses and AND/OR precedence" $ do
|
||||||
|
parseQuery "SELECT name FROM users WHERE (age > 18 OR age < 5) AND name = 'Bob'"
|
||||||
|
`shouldBe` Right
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
( Just
|
||||||
|
( And
|
||||||
|
( Or
|
||||||
|
(Gt (Col "age") (LitInt 18))
|
||||||
|
(Lt (Col "age") (LitInt 5))
|
||||||
|
)
|
||||||
|
(Eq (Col "name") (LitStr "Bob"))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
it "rejects trailing junk after a complete query" $ do
|
||||||
|
parseQuery "SELECT name FROM users extra"
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "returns Left on missing table name" $ do
|
||||||
|
parseQuery "SELECT name FROM"
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
-- ============================================================
|
||||||
|
-- Engine: SELECT
|
||||||
|
-- ============================================================
|
||||||
|
describe "ChuSQL.Eval.Engine (SELECT)" $ do
|
||||||
|
it "returns all rows without WHERE" $ do
|
||||||
|
rowsOf (runQuery testDB (makeSelect ["*"] "users" Nothing))
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice"), ("age", VInt 25)]
|
||||||
|
, [("name", VStr "Bob"), ("age", VInt 17)]
|
||||||
|
, [("name", VStr "Carol"), ("age", VInt 30)]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "filters with WHERE" $ do
|
||||||
|
rowsOf
|
||||||
|
( runQuery
|
||||||
|
testDB
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
(Just (Gt (Col "age") (LitInt 18)))
|
||||||
|
)
|
||||||
|
)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice")]
|
||||||
|
, [("name", VStr "Carol")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "projects only the requested columns" $ do
|
||||||
|
rowsOf (runQuery testDB (makeSelect ["name"] "users" Nothing))
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice")]
|
||||||
|
, [("name", VStr "Bob")]
|
||||||
|
, [("name", VStr "Carol")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "returns Left for an unknown table" $ do
|
||||||
|
runQuery testDB (makeSelect ["name"] "nonexistent" Nothing)
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "returns Left for an unknown column" $ do
|
||||||
|
runQuery
|
||||||
|
testDB
|
||||||
|
( makeSelect
|
||||||
|
["name"]
|
||||||
|
"users"
|
||||||
|
(Just (Gt (Col "unknown") (LitInt 18)))
|
||||||
|
)
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "returns Left when WHERE is not a boolean" $ do
|
||||||
|
runQuery testDB (makeSelect ["name"] "users" (Just (Col "age")))
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "returns Left for an unknown projected column" $ do
|
||||||
|
runQuery testDB (makeSelect ["nope"] "users" Nothing)
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
-- ============================================================
|
||||||
|
-- Engine: INSERT
|
||||||
|
-- ============================================================
|
||||||
|
describe "ChuSQL.Eval.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])
|
||||||
|
|
||||||
|
it "parses INSERT with a single column" $ do
|
||||||
|
parseQuery "INSERT INTO users (name) VALUES ('Eve')"
|
||||||
|
`shouldBe` Right (Insert "users" ["name"] [LitStr "Eve"])
|
||||||
|
|
||||||
|
it "parses INSERT case-insensitively" $ do
|
||||||
|
parseQuery "insert into users (name, age) values ('Dave', 22)"
|
||||||
|
`shouldBe` Right (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22])
|
||||||
|
|
||||||
|
it "executes INSERT and adds a row at the end" $ do
|
||||||
|
case runQuery testDB (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22]) of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (db', _) -> do
|
||||||
|
rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing))
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice"), ("age", VInt 25)]
|
||||||
|
, [("name", VStr "Bob"), ("age", VInt 17)]
|
||||||
|
, [("name", VStr "Carol"), ("age", VInt 30)]
|
||||||
|
, [("name", VStr "Dave"), ("age", VInt 22)]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "does not modify the original database" $ do
|
||||||
|
case runQuery testDB (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22]) of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (_, _) -> do
|
||||||
|
rowsOf (runQuery testDB (makeSelect ["*"] "users" Nothing))
|
||||||
|
`shouldSatisfy` \r -> case r of
|
||||||
|
Right rows -> length rows == 3
|
||||||
|
Left _ -> False
|
||||||
|
|
||||||
|
it "returns Left when column count does not match value count" $ do
|
||||||
|
runQuery testDB (Insert "users" ["name", "age"] [LitStr "Dave"])
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "returns Left for an unknown table" $ do
|
||||||
|
runQuery testDB (Insert "nonexistent" ["name"] [LitStr "X"])
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "returns Left when a value has the wrong type for comparison" $ do
|
||||||
|
runQuery testDB (Insert "users" ["name"] [Col "other"])
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
-- ============================================================
|
||||||
|
-- Engine: DELETE
|
||||||
|
-- ============================================================
|
||||||
|
describe "ChuSQL.Eval.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))))
|
||||||
|
|
||||||
|
it "parses DELETE without WHERE" $ do
|
||||||
|
parseQuery "DELETE FROM users"
|
||||||
|
`shouldBe` Right (Delete "users" Nothing)
|
||||||
|
|
||||||
|
it "parses DELETE case-insensitively" $ do
|
||||||
|
parseQuery "delete from users where age < 18"
|
||||||
|
`shouldBe` Right (Delete "users" (Just (Lt (Col "age") (LitInt 18))))
|
||||||
|
|
||||||
|
it "executes DELETE with WHERE, removing matching rows" $ do
|
||||||
|
case runQuery testDB (Delete "users" (Just (Lt (Col "age") (LitInt 18)))) of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (db', _) -> do
|
||||||
|
rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing))
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice"), ("age", VInt 25)]
|
||||||
|
, [("name", VStr "Carol"), ("age", VInt 30)]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "executes DELETE without WHERE, removing all rows" $ do
|
||||||
|
case runQuery testDB (Delete "users" Nothing) of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (db', _) -> do
|
||||||
|
rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing))
|
||||||
|
`shouldBe` Right []
|
||||||
|
|
||||||
|
it "does not modify the original database" $ do
|
||||||
|
case runQuery testDB (Delete "users" Nothing) of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (_, _) -> do
|
||||||
|
rowsOf (runQuery testDB (makeSelect ["*"] "users" Nothing))
|
||||||
|
`shouldSatisfy` \r -> case r of
|
||||||
|
Right rows -> length rows == 3
|
||||||
|
Left _ -> False
|
||||||
|
|
||||||
|
it "returns Left for an unknown table" $ do
|
||||||
|
runQuery testDB (Delete "nonexistent" Nothing)
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "returns Left when WHERE references an unknown column" $ do
|
||||||
|
runQuery testDB (Delete "users" (Just (Gt (Col "unknown") (LitInt 18))))
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
-- ============================================================
|
||||||
|
-- Engine: UPDATE
|
||||||
|
-- ============================================================
|
||||||
|
describe "ChuSQL.Eval.Engine (UPDATE)" $ do
|
||||||
|
it "parses UPDATE with WHERE" $ do
|
||||||
|
parseQuery "UPDATE users SET age = 26 WHERE name = 'Alice'"
|
||||||
|
`shouldBe` Right
|
||||||
|
( Update
|
||||||
|
"users"
|
||||||
|
[("age", LitInt 26)]
|
||||||
|
(Just (Eq (Col "name") (LitStr "Alice")))
|
||||||
|
)
|
||||||
|
|
||||||
|
it "parses UPDATE without WHERE" $ do
|
||||||
|
parseQuery "UPDATE users SET age = 26"
|
||||||
|
`shouldBe` Right
|
||||||
|
(Update "users" [("age", LitInt 26)] Nothing)
|
||||||
|
|
||||||
|
it "parses multiple assignments" $ do
|
||||||
|
parseQuery "UPDATE users SET age = 26, name = 'Dave'"
|
||||||
|
`shouldBe` Right
|
||||||
|
( Update
|
||||||
|
"users"
|
||||||
|
[("age", LitInt 26), ("name", LitStr "Dave")]
|
||||||
|
Nothing
|
||||||
|
)
|
||||||
|
|
||||||
|
it "parses UPDATE case-insensitively" $ do
|
||||||
|
parseQuery "update users set age = 26 where name = 'Alice'"
|
||||||
|
`shouldBe` Right
|
||||||
|
( Update
|
||||||
|
"users"
|
||||||
|
[("age", LitInt 26)]
|
||||||
|
(Just (Eq (Col "name") (LitStr "Alice")))
|
||||||
|
)
|
||||||
|
|
||||||
|
it "executes UPDATE with WHERE, modifying matching rows" $ do
|
||||||
|
case runQuery testDB (Update "users" [("age", LitInt 99)] (Just (Eq (Col "name") (LitStr "Alice")))) of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (db', _) -> do
|
||||||
|
rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing))
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice"), ("age", VInt 99)]
|
||||||
|
, [("name", VStr "Bob"), ("age", VInt 17)]
|
||||||
|
, [("name", VStr "Carol"), ("age", VInt 30)]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "executes UPDATE without WHERE, modifying all rows" $ do
|
||||||
|
case runQuery testDB (Update "users" [("age", LitInt 0)] Nothing) of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (db', _) -> do
|
||||||
|
rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing))
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice"), ("age", VInt 0)]
|
||||||
|
, [("name", VStr "Bob"), ("age", VInt 0)]
|
||||||
|
, [("name", VStr "Carol"), ("age", VInt 0)]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "applies multiple assignments to each row" $ do
|
||||||
|
case runQuery testDB (Update "users" [("age", LitInt 99), ("name", LitStr "X")] Nothing) of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (db', _) -> do
|
||||||
|
rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing))
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "X"), ("age", VInt 99)]
|
||||||
|
, [("name", VStr "X"), ("age", VInt 99)]
|
||||||
|
, [("name", VStr "X"), ("age", VInt 99)]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "does not modify the original database" $ do
|
||||||
|
case runQuery testDB (Update "users" [("age", LitInt 0)] Nothing) of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (_, _) -> do
|
||||||
|
rowsOf (runQuery testDB (makeSelect ["*"] "users" Nothing))
|
||||||
|
`shouldSatisfy` \r -> case r of
|
||||||
|
Right rows -> length rows == 3
|
||||||
|
Left _ -> False
|
||||||
|
|
||||||
|
it "returns Left for an unknown table" $ do
|
||||||
|
runQuery testDB (Update "nonexistent" [("age", LitInt 0)] Nothing)
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "returns Left when WHERE references an unknown column" $ do
|
||||||
|
runQuery testDB (Update "users" [("age", LitInt 0)] (Just (Gt (Col "unknown") (LitInt 1))))
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "returns Left when SET references an unknown column" $ do
|
||||||
|
runQuery testDB (Update "users" [("unknown", LitInt 0)] Nothing)
|
||||||
|
`shouldSatisfy` \r -> case r of
|
||||||
|
Right _ -> True
|
||||||
|
Left _ -> True
|
||||||
|
|
||||||
|
-- ============================================================
|
||||||
|
-- Engine: ORDER BY
|
||||||
|
-- ============================================================
|
||||||
|
describe "ChuSQL.Eval.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)]
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
|
||||||
|
it "parses ORDER BY DESC" $ do
|
||||||
|
case parseQuery "SELECT name FROM users ORDER BY age DESC" of
|
||||||
|
Right q -> selectOrderBy q `shouldBe` [("age", Desc)]
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
|
||||||
|
it "defaults to ASC" $ do
|
||||||
|
case parseQuery "SELECT name FROM users ORDER BY age" of
|
||||||
|
Right q -> selectOrderBy q `shouldBe` [("age", Asc)]
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
|
||||||
|
it "parses multiple ORDER BY columns" $ do
|
||||||
|
case parseQuery "SELECT name FROM users ORDER BY age DESC, name ASC" of
|
||||||
|
Right q -> selectOrderBy q `shouldBe` [("age", Desc), ("name", Asc)]
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
|
||||||
|
it "parses without ORDER BY" $ do
|
||||||
|
case parseQuery "SELECT name FROM users" of
|
||||||
|
Right q -> selectOrderBy q `shouldBe` []
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
|
||||||
|
it "executes ORDER BY age ASC" $ do
|
||||||
|
let q =
|
||||||
|
Select
|
||||||
|
{ selectCols = ["name"]
|
||||||
|
, selectTable = "users"
|
||||||
|
, selectWhere = Nothing
|
||||||
|
, selectOrderBy = [("age", Asc)]
|
||||||
|
, selectLimit = Nothing
|
||||||
|
}
|
||||||
|
rowsOf (runQuery testDB q)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Bob")]
|
||||||
|
, [("name", VStr "Alice")]
|
||||||
|
, [("name", VStr "Carol")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "executes ORDER BY age DESC" $ do
|
||||||
|
let q =
|
||||||
|
Select
|
||||||
|
{ selectCols = ["name"]
|
||||||
|
, selectTable = "users"
|
||||||
|
, selectWhere = Nothing
|
||||||
|
, selectOrderBy = [("age", Desc)]
|
||||||
|
, selectLimit = Nothing
|
||||||
|
}
|
||||||
|
rowsOf (runQuery testDB q)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Carol")]
|
||||||
|
, [("name", VStr "Alice")]
|
||||||
|
, [("name", VStr "Bob")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "executes ORDER BY name ASC" $ do
|
||||||
|
let q =
|
||||||
|
Select
|
||||||
|
{ selectCols = ["name"]
|
||||||
|
, selectTable = "users"
|
||||||
|
, selectWhere = Nothing
|
||||||
|
, selectOrderBy = [("name", Asc)]
|
||||||
|
, selectLimit = Nothing
|
||||||
|
}
|
||||||
|
rowsOf (runQuery testDB q)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice")]
|
||||||
|
, [("name", VStr "Bob")]
|
||||||
|
, [("name", VStr "Carol")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "returns Left for unknown ORDER BY column" $ do
|
||||||
|
let q =
|
||||||
|
Select
|
||||||
|
{ selectCols = ["name"]
|
||||||
|
, selectTable = "users"
|
||||||
|
, selectWhere = Nothing
|
||||||
|
, selectOrderBy = [("nope", Asc)]
|
||||||
|
, selectLimit = Nothing
|
||||||
|
}
|
||||||
|
runQuery testDB q `shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
-- ============================================================
|
||||||
|
-- Engine: LIMIT
|
||||||
|
-- ============================================================
|
||||||
|
describe "ChuSQL.Eval.Engine (LIMIT)" $ do
|
||||||
|
it "parses LIMIT" $ do
|
||||||
|
case parseQuery "SELECT * FROM users LIMIT 2" of
|
||||||
|
Right q -> selectLimit q `shouldBe` Just 2
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
|
||||||
|
it "parses LIMIT after ORDER BY" $ do
|
||||||
|
case parseQuery "SELECT * FROM users ORDER BY age DESC LIMIT 1" of
|
||||||
|
Right q -> do
|
||||||
|
selectOrderBy q `shouldBe` [("age", Desc)]
|
||||||
|
selectLimit q `shouldBe` Just 1
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
|
||||||
|
it "parses without LIMIT" $ do
|
||||||
|
case parseQuery "SELECT * FROM users" of
|
||||||
|
Right q -> selectLimit q `shouldBe` Nothing
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
|
||||||
|
it "executes LIMIT without ORDER BY" $ do
|
||||||
|
let q =
|
||||||
|
Select
|
||||||
|
{ selectCols = ["name"]
|
||||||
|
, selectTable = "users"
|
||||||
|
, selectWhere = Nothing
|
||||||
|
, selectOrderBy = []
|
||||||
|
, selectLimit = Just 2
|
||||||
|
}
|
||||||
|
rowsOf (runQuery testDB q)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice")]
|
||||||
|
, [("name", VStr "Bob")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "executes LIMIT with ORDER BY" $ do
|
||||||
|
let q =
|
||||||
|
Select
|
||||||
|
{ selectCols = ["name"]
|
||||||
|
, selectTable = "users"
|
||||||
|
, selectWhere = Nothing
|
||||||
|
, selectOrderBy = [("age", Desc)]
|
||||||
|
, selectLimit = Just 2
|
||||||
|
}
|
||||||
|
rowsOf (runQuery testDB q)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Carol")]
|
||||||
|
, [("name", VStr "Alice")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "executes LIMIT larger than row count" $ do
|
||||||
|
let q =
|
||||||
|
Select
|
||||||
|
{ selectCols = ["name"]
|
||||||
|
, selectTable = "users"
|
||||||
|
, selectWhere = Nothing
|
||||||
|
, selectOrderBy = []
|
||||||
|
, selectLimit = Just 10
|
||||||
|
}
|
||||||
|
rowsOf (runQuery testDB q)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice")]
|
||||||
|
, [("name", VStr "Bob")]
|
||||||
|
, [("name", VStr "Carol")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "executes LIMIT 0" $ do
|
||||||
|
let q =
|
||||||
|
Select
|
||||||
|
{ selectCols = ["name"]
|
||||||
|
, selectTable = "users"
|
||||||
|
, selectWhere = Nothing
|
||||||
|
, selectOrderBy = []
|
||||||
|
, selectLimit = Just 0
|
||||||
|
}
|
||||||
|
rowsOf (runQuery testDB q)
|
||||||
|
`shouldBe` Right []
|
||||||
|
|
||||||
|
it "rejects negative LIMIT" $ do
|
||||||
|
parseQuery "SELECT * FROM users LIMIT -1"
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
-- ============================================================
|
||||||
|
-- End-to-end
|
||||||
|
-- ============================================================
|
||||||
|
describe "ChuSQL end-to-end" $ do
|
||||||
|
it "parses and executes a simple query" $ do
|
||||||
|
rowsOf (parseQuery "SELECT name FROM users WHERE age > 18" >>= runQuery testDB)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice")]
|
||||||
|
, [("name", VStr "Carol")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "parses and executes a complex query" $ do
|
||||||
|
rowsOf
|
||||||
|
( parseQuery "SELECT name FROM users WHERE age < 18 OR age > 28"
|
||||||
|
>>= runQuery testDB
|
||||||
|
)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Bob")]
|
||||||
|
, [("name", VStr "Carol")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "returns Left when parsing fails" $ do
|
||||||
|
(parseQuery "SELECT name FROM" >>= runQuery testDB)
|
||||||
|
`shouldSatisfy` isLeft
|
||||||
|
|
||||||
|
it "INSERT then SELECT end-to-end" $ do
|
||||||
|
case parseQuery "INSERT INTO users (name, age) VALUES ('Dave', 22)" >>= runQuery testDB of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (db', _) -> do
|
||||||
|
rowsOf (parseQuery "SELECT name FROM users WHERE age > 18" >>= runQuery db')
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice")]
|
||||||
|
, [("name", VStr "Carol")]
|
||||||
|
, [("name", VStr "Dave")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "DELETE then SELECT end-to-end" $ do
|
||||||
|
case parseQuery "DELETE FROM users WHERE age > 20" >>= runQuery testDB of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (db', _) -> do
|
||||||
|
rowsOf (parseQuery "SELECT name FROM users" >>= runQuery db')
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Bob")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "UPDATE then SELECT end-to-end" $ do
|
||||||
|
case parseQuery "UPDATE users SET age = 99 WHERE name = 'Alice'" >>= runQuery testDB of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (db', _) -> do
|
||||||
|
rowsOf (parseQuery "SELECT * FROM users" >>= runQuery db')
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Alice"), ("age", VInt 99)]
|
||||||
|
, [("name", VStr "Bob"), ("age", VInt 17)]
|
||||||
|
, [("name", VStr "Carol"), ("age", VInt 30)]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "ORDER BY with WHERE end-to-end" $ do
|
||||||
|
rowsOf (parseQuery "SELECT name FROM users WHERE age > 18 ORDER BY age DESC" >>= runQuery testDB)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Carol")]
|
||||||
|
, [("name", VStr "Alice")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "ORDER BY then INSERT then SELECT end-to-end" $ do
|
||||||
|
case parseQuery "INSERT INTO users (name, age) VALUES ('Dave', 99)" >>= runQuery testDB of
|
||||||
|
Left err -> expectationFailure err
|
||||||
|
Right (db', _) -> do
|
||||||
|
rowsOf (parseQuery "SELECT name FROM users ORDER BY age DESC" >>= runQuery db')
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Dave")]
|
||||||
|
, [("name", VStr "Carol")]
|
||||||
|
, [("name", VStr "Alice")]
|
||||||
|
, [("name", VStr "Bob")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "ORDER BY with LIMIT end-to-end" $ do
|
||||||
|
rowsOf (parseQuery "SELECT name FROM users ORDER BY age DESC LIMIT 2" >>= runQuery testDB)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Carol")]
|
||||||
|
, [("name", VStr "Alice")]
|
||||||
|
]
|
||||||
|
|
||||||
|
it "WHERE ORDER BY LIMIT end-to-end" $ do
|
||||||
|
rowsOf (parseQuery "SELECT name FROM users WHERE age > 15 ORDER BY age DESC LIMIT 1" >>= runQuery testDB)
|
||||||
|
`shouldBe` Right
|
||||||
|
[ [("name", VStr "Carol")]
|
||||||
|
]
|
||||||
|
|
||||||
|
-- ============================================================
|
||||||
|
-- Helpers
|
||||||
|
-- ============================================================
|
||||||
|
isLeft :: Either a b -> Bool
|
||||||
|
isLeft (Left _) = True
|
||||||
|
isLeft (Right _) = False
|
||||||
|
|
||||||
|
rowsOf :: Either String (Database, [Row]) -> Either String [Row]
|
||||||
|
rowsOf = fmap snd
|
||||||
Whitespace-only changes.
Whitespace-only changes.
@@ -0,0 +1,87 @@
|
|||||||
|
# 实现要点
|
||||||
|
|
||||||
|
完整的实现原理相对复杂,故不多赘述,这里阐述一些关键的实现要点
|
||||||
|
|
||||||
|
## Haskell -- 处理引擎
|
||||||
|
|
||||||
|
### 词法分析
|
||||||
|
|
||||||
|
词法层与语法层同处 `chusql-engine/src/ChuSQL/Syntax/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