ChuNa7a/ChuSQL
1
0 Fork 0
Code Issues Pull Requests Actions 7 Packages Projects Releases Wiki Activity

做完rust全链路

Browse Source
This commit is contained in:
LIm1tZz7 committed 2026-09-24 21:28:49 +08:00
1 parent e428265357
commit 2a4b446252
34 files changed
+1756 -1031
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

chusql-engine/app/Main.hs
+11 -9
View File
@@ -8,6 +8,8 @@ import ChuSQL.Model
import ChuSQL.Syntax.AST
import ChuSQL.Syntax.Parser
-- 命令行演示：跑几条语句，打印结果与优化前后的计划。
users :: Table
users =
Table
@@ -35,17 +37,18 @@ orders =
db :: Database
db = [("users", users), ("orders", orders)]
-- | 演示入口
main :: IO ()
main = do
putStrLn "==================== Engine ====================="
let q1 = makeSelect ["name"] "users" (Just (Gt (Col "age") (LitInt 18)))
print (rowsOf (runQuery db q1))
print (rowsOf (runStatement db q1))
let q2 = makeSelect ["*"] "users" Nothing
print (rowsOf (runQuery db q2))
print (rowsOf (runStatement db q2))
let q3 = makeSelect ["name"] "nonexistent" Nothing
print (rowsOf (runQuery db q3))
print (rowsOf (runStatement db q3))
let q4 =
makeSelect
@@ -57,17 +60,16 @@ main = do
(Gt (Col "age") (LitInt 30))
)
)
print (rowsOf (runQuery db q4))
print (rowsOf (runStatement db q4))
-- 解析 SQL 文本，再交给执行引擎
let parsed = parseQuery "SELECT name FROM users WHERE age > 18 AND name = 'Alice'"
print (rowsOf (parsed >>= runQuery db))
let parsed = parseStatement "SELECT name FROM users WHERE age > 18 AND name = 'Alice'"
print (rowsOf (parsed >>= runStatement db))
putStrLn "\n==================== Optimizer ====================="
let planSql =
"SELECT u.name, o.product FROM users u \
\JOIN orders o ON u.id = o.user_id WHERE u.age > 18"
case parseQuery planSql of
case parseStatement planSql of
Left err -> putStrLn err
Right query -> case translate query of
Left err -> putStrLn err
@@ -77,4 +79,4 @@ main = do
putStrLn "--- plan after optimization ---"
putStrLn (renderPlan (optimize db plan))
putStrLn "--- rows ---"
print (rowsOf (runQuery db query))
print (rowsOf (runStatement db query))
chusql-engine/src/ChuSQL/Algebra/Eval.hs
+11 -9
View File
@@ -8,29 +8,31 @@ import ChuSQL.Storage (MonadStorage (..))
import ChuSQL.Syntax.AST (Expr (..))
import Control.Monad (filterM)
-- 执行：按关系算子树真正算出结果行（Scan 阶段会给列名加上别名前缀）。
-- 执行：按算子树算出结果行（Scan 阶段会加别名前缀）。
-- 投影：只保留清单里的列；哨兵 "*" 表示全部列。
-- * 工具
-- | 只保留清单里的列
project :: [String] -> Row -> Row
project ["*"] row = row
project cs row = [(c, v) | (c, v) <- row, c `elem` cs]
-- 给一行里的每个列名加上别名前缀（如 "u."）。
-- | 给列名加别名前缀
addPrefix :: String -> Row -> Row
addPrefix prefix = map (\(k, v) -> (prefix ++ k, v))
-- 索引查找的约定：主键列名是 "id"（优化器只在这种情况下才把过滤改写成 Lookup）。
-- | 主键匹配条件（id = k）
keyCondition :: Int -> Expr
keyCondition k = Eq (Col "id") (LitInt k)
-- 扫描一张表；有别名就给每个列名加上前缀，JOIN 两边同名列靠它区分。
-- | 扫描一张表
evalScan :: Database -> Maybe String -> String -> Either String [Row]
evalScan db mAlias tbl = do
table <- lookupTable db tbl
let prefix = maybe "" (++ ".") mAlias
Right (map (addPrefix prefix) (tableRows table))
-- 执行关系代数运算：Scan / Lookup / Filter / Project / Sort / Limit / Join 各一支。
-- * 求值
-- | 纯求值（不需要存储）
evalRelOp :: Database -> RelOp -> Either String [Row]
evalRelOp db (Scan mAlias tbl) = evalScan db mAlias tbl
evalRelOp db (Lookup tbl k) = do
@@ -51,18 +53,18 @@ evalRelOp db (Limit n op) = do
evalRelOp db (Join left right cond) = do
lrows <- evalRelOp db left
rrows <- evalRelOp db right
let cross = [l ++ r | l <- lrows, r <- rrows] -- 笛卡尔积
let cross = [l ++ r | l <- lrows, r <- rrows]
filterM (evalCondForRow cond) cross
-- | Monadic 版本：Lookup 直接问存储要一行（走索引），其余算子照原样递归。
-- | 单子求值：Lookup 问存储
evalRelOpM :: (MonadStorage m) => Database -> RelOp -> m (Either String [Row])
evalRelOpM db (Scan a t) = pure (evalScan db a t)
evalRelOpM _ (Lookup t k) = do
result <- lookupByKey t k
pure $ case result of
Left e -> Left e
Right Nothing -> Right []
Right (Just r) -> Right [r]
evalRelOpM db (Scan a t) = pure (evalScan db a t)
evalRelOpM db (Filter p x) = do
result <- evalRelOpM db x
pure $ do
chusql-engine/src/ChuSQL/Algebra/Expr.hs
+11 -8
View File
@@ -4,9 +4,10 @@ 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)
@@ -19,7 +20,8 @@ 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
@@ -29,7 +31,7 @@ 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
v <- evalExpr e row
@@ -37,7 +39,8 @@ evalCondForRow e row = do
VBool b -> Right b
_ -> Left "type error: WHERE condition must be a boolean"
-- 固定模式：对两个子表达式求值，并返还给二元操作符
-- * 内部
-- | 把二元运算提升到 Either
liftBinOp ::
(Value -> Value -> Either String Value) ->
Expr ->
@@ -46,16 +49,16 @@ liftBinOp ::
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))
chusql-engine/src/ChuSQL/Algebra/Op.hs
+4 -4
View File
@@ -2,9 +2,9 @@ module ChuSQL.Algebra.Op (RelOp (..), renderPlan) where
import ChuSQL.Syntax.AST (Expr, SortDir)
-- 关系代数算子：执行计划用 RelOp 表示；另外提供一个把计划打印成缩进文本的辅助函数。
-- 关系代数算子，以及把算子树渲染成文本。
-- 关系代数算子
-- | 算子树的一个节点
data RelOp
= Scan (Maybe String) String
| Lookup String Int
@@ -15,13 +15,13 @@ data RelOp
| Join RelOp RelOp Expr
deriving (Show, Eq)
-- 把算子树画成缩进文本（演示和调试用）
-- | 渲染成缩进文本
renderPlan :: RelOp -> String
renderPlan = go 0
where
go ind op = case op of
Lookup t k -> "Lookup " ++ show t ++ " " ++ show k
Scan a t -> pad ++ "Scan " ++ show a ++ " " ++ show t
Lookup t k -> pad ++ "Lookup " ++ show t ++ " " ++ show k
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
chusql-engine/src/ChuSQL/Algebra/Optimize.hs
+28 -29
View File
@@ -5,42 +5,41 @@ import ChuSQL.Algebra.Op (RelOp (..))
import ChuSQL.Model
import ChuSQL.Syntax.AST (Expr (..))
-- 查询优化：谓词下推 + 投影下推 + 常量折叠，反复应用规则直到算子树形状不再变化。
-- 查询优化：谓词下推 + 投影下推 + 常量折叠，跑到不动点。
-- * 谓词下推
-- | 一个算子会产出哪些列；返回 ["*"] 表示"全部列，不用挑"
-- | 算子会产出哪些列
relOpCols :: Database -> RelOp -> [String]
relOpCols db (Filter _ x) = relOpCols db x
relOpCols db (Sort _ x) = relOpCols db x
relOpCols db (Limit _ x) = relOpCols db x
relOpCols _ (Project ["*"] _) = ["*"]
relOpCols _ (Project cols _) = cols
relOpCols db (Join l r _) = relOpCols db l ++ relOpCols db r
relOpCols db (Lookup tbl _) = relOpCols db (Scan Nothing tbl)
relOpCols db (Scan mAlias tbl) =
case lookup tbl db of
Nothing -> []
Just t -> map (prefix ++) (colNames t)
where
prefix = maybe "" (++ ".") mAlias
relOpCols db (Lookup tbl _) = relOpCols db (Scan Nothing tbl)
relOpCols db (Filter _ x) = relOpCols db x
relOpCols _ (Project ["*"] _) = ["*"]
relOpCols _ (Project cols _) = cols
relOpCols db (Sort _ x) = relOpCols db x
relOpCols db (Limit _ x) = relOpCols db x
relOpCols db (Join l r _) = relOpCols db l ++ relOpCols db r
-- | need 里的列是不是都能在 have 里找到；have 为 ["*"] 时一律为真
-- | need 是否都在 have 里
isSubsetOf :: [String] -> [String] -> Bool
isSubsetOf _ ["*"] = True
isSubsetOf need have = all (`elem` have) need
-- | 把一个用 AND 串起来的条件拆成清单：a AND b AND c 变成 [a, b, c]
-- | 把 AND 链拆成清单
splitConj :: Expr -> [Expr]
splitConj (And a b) = splitConj a ++ splitConj b
splitConj e = [e]
-- | 反过来：把条件清单用 AND 重新串成一个；空清单表示"没有条件"，返回 Nothing
-- | 把条件清单用 AND 串起来
combineConj :: [Expr] -> Maybe Expr
combineConj [] = Nothing
combineConj (e : es) = Just (foldl And e es)
-- | 把条件按"只用到哪一边的列"分成两堆：能下推过去的 / 必须留在原地的
-- | 条件按列归属分两边
partitionPred :: [String] -> [Expr] -> ([Expr], [Expr])
partitionPred have = foldr pick ([], [])
where
@@ -48,12 +47,12 @@ partitionPred have = foldr pick ([], [])
| colsInExpr e `isSubsetOf` have = (e : yes, no)
| otherwise = (yes, e : no)
-- | 把一组条件依次套到算子上，一个条件一层 Filter
-- | 依次套上若干 Filter
applyFilters :: [Expr] -> RelOp -> RelOp
applyFilters [] op = op
applyFilters (e : es) op = applyFilters es (Filter e op)
-- | Filter 压在 Join 上时的下推规则：条件按列归属拆到左右两侧，跨两边的才留在 Join 上方
-- | Filter 压在 Join 上时下推
pushJoin :: Database -> Expr -> RelOp -> RelOp -> Expr -> RelOp
pushJoin db p l r c =
let preds = splitConj p
@@ -68,26 +67,26 @@ pushJoin db p l r c =
Nothing -> joined
Just p' -> Filter p' joined
-- | Filter 压在 Filter / Sort 上时的下推规则：合并上下两层 Filter，或把 Filter 挪到 Sort 下面
-- | 合并两层 Filter 或挪到 Sort 下
pushOne :: Database -> RelOp -> RelOp
pushOne _ (Filter p (Filter q x)) = Filter (And p q) x
pushOne _ (Filter p (Sort spec x)) = Sort spec (Filter p x)
pushOne _ op = op
-- * 投影下推
-- | 是不是要拿全部列（need 里含哨兵 "*"）。
-- * 投影下推
-- | 是否要全部列
needsAll :: [String] -> Bool
needsAll = elem allColumns
-- | 叶子算子（扫描 / 索引查找）的投影下推：需要全部列就原样保留，缺列才套一层 Project
-- | 叶子算子的投影下推
pushProjectLeaf :: Database -> [String] -> RelOp -> RelOp
pushProjectLeaf db need leaf
| needsAll need = leaf
| all (`elem` need) (relOpCols db leaf) = leaf
| otherwise = Project need leaf
-- | 投影下推：把"上层需要哪些列"一路往下传，JOIN 两侧各自只保留自己需要的列。
-- | 把需要哪些列往下传
pushProject :: Database -> [String] -> RelOp -> RelOp
pushProject db _ (Project cols x) = case pushProject db cols x of
Project cols' y | cols' == cols -> Project cols y
@@ -107,9 +106,9 @@ pushProject db need (Join l r c)
pushProject db need leaf@(Scan _ _) = pushProjectLeaf db need leaf
pushProject db need leaf@(Lookup _ _) = pushProjectLeaf db need leaf
-- * 常量折叠
-- | 折一个表达式：不含列就直接求值替换成字面量，含列或求值失败则原样返回
-- * 常量折叠
-- | 折一个表达式节点
foldNode :: Expr -> Expr
foldNode e
| null (colsInExpr e) = case evalExpr e [] of
@@ -119,7 +118,7 @@ foldNode e
Left _ -> e
| otherwise = e
-- | 自底向上折叠整个表达式：先把子表达式折干净，再折自己
-- | 自底向上折整棵表达式
foldConstants :: Expr -> Expr
foldConstants (Gt a b) = foldNode (Gt (foldConstants a) (foldConstants b))
foldConstants (Lt a b) = foldNode (Lt (foldConstants a) (foldConstants b))
@@ -128,9 +127,9 @@ foldConstants (And a b) = foldNode (And (foldConstants a) (foldConstants b))
foldConstants (Or a b) = foldNode (Or (foldConstants a) (foldConstants b))
foldConstants e = e
-- * 执行优化
-- | 单节点重写：把 Filter 分派给上面几条规则，另外负责恒真条件删除与恒等投影消除
-- * 执行优化
-- | 单节点重写
rewriteNode :: Database -> RelOp -> RelOp
rewriteNode _ (Filter (Eq (Col k) (LitInt v)) (Scan _ t))
| k == "id" = Lookup t v
@@ -141,7 +140,7 @@ rewriteNode db (Filter p x) = case foldConstants p of
rewriteNode _ (Project ["*"] x) = x
rewriteNode db op = pushOne db op
-- | 自底向上遍历整棵算子树，每个节点套一次 rewriteNode
-- | 自底向上遍历一次
optimizeRelOp :: Database -> RelOp -> RelOp
optimizeRelOp db = rewriteNode db . descend
where
@@ -152,12 +151,12 @@ optimizeRelOp db = rewriteNode db . descend
descend (Join l r c) = Join (optimizeRelOp db l) (optimizeRelOp db r) c
descend x = x
-- | 谓词下推 + 常量折叠：反复应用规则，直到算子树的形状不再变化（到不动点为止）
-- | 反复跑到不动点
optimizePredicates :: Database -> RelOp -> RelOp
optimizePredicates db op =
let op' = optimizeRelOp db op
in if op' == op then op else optimizePredicates db op'
-- | 优化器总入口：先把谓词下推与常量折叠跑到不动点，再做一次投影下推
-- | 优化总入口
optimize :: Database -> RelOp -> RelOp
optimize db op = pushProject db ["*"] (optimizePredicates db op)
chusql-engine/src/ChuSQL/Algebra/Planner.hs
+4 -4
View File
@@ -3,16 +3,16 @@ module ChuSQL.Algebra.Planner (translate) where
import ChuSQL.Algebra.Op
import ChuSQL.Syntax.AST
-- 计划翻译：把 AST 里的 SELECT 翻译成关系代数算子树（只翻译，不做合法性检查）。
-- 计划生成：把语句翻译成算子树。
-- 把 FROM 从句转成 Scan / Join 算子。
-- | 把 FROM 子句翻成 Scan / Join
fromToRelOp :: FromClause -> RelOp
fromToRelOp (FromTable mAlias tbl) = Scan mAlias tbl
fromToRelOp (FromJoin left mAlias tbl cond) =
Join (fromToRelOp left) (Scan mAlias tbl) cond
-- 翻译入口：把 SELECT 翻译成算子树；其它语句类型不支持（返回 Left）。
translate :: Query -> Either String RelOp
-- | 翻成：过滤 -> 排序 -> 截断 -> 取列
translate :: Statement -> Either String RelOp
translate q = case q of
Select
{ selectCols = cols
chusql-engine/src/ChuSQL/Algebra/Sort.hs
+5 -5
View File
@@ -4,22 +4,22 @@ import ChuSQL.Model
import ChuSQL.Syntax.AST
import Data.List (sortBy)
-- 排序：按 ORDER BY 的列清单逐列比较（支持 ASC / DESC），供执行 Sort 算子时使用。
-- 排序：按多列排序，每列可升可降。
-- 反向排序
-- | 反转比较结果
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 =
@@ -33,7 +33,7 @@ compareRows ((col, dir) : rest) r1 r2 =
else o
_ -> compareRows rest r1 r2
-- 将表的每行排序
-- | 排序若干行
sortRows :: [(String, SortDir)] -> [Row] -> [Row]
sortRows [] rows = rows
sortRows spec rows = sortBy (compareRows spec) rows
chusql-engine/src/ChuSQL/Engine.hs
+31 -23
View File
@@ -1,4 +1,4 @@
module ChuSQL.Engine (runQuery, runQueryM, rowsOf) where
module ChuSQL.Engine (runStatement, runStatementM, rowsOf) where
import ChuSQL.Algebra.Eval (evalRelOpM)
import ChuSQL.Algebra.Expr (evalCondForRow, evalExpr)
@@ -11,37 +11,39 @@ import ChuSQL.Storage.Memory (MemoryStorage (runMemoryStorage))
import ChuSQL.Syntax.AST
import Control.Monad (filterM)
-- | 对外入口：签名不变，内部走内存实现。
runQuery :: Database -> Query -> Either String (Database, [Row])
runQuery db q = do
(result, db') <- runMemoryStorage (runQueryM q) db
-- 引擎入口：语义检查 + 分发执行，以及内存实现与泛型版本。
-- * 对外入口
-- | 跑一条语句（内存实现）
runStatement :: Database -> Statement -> Either String (Database, [Row])
runStatement db q = do
(result, db') <- runMemoryStorage (runStatementM q) db
rows <- result
Right (db', rows)
-- | 只要结果行（丢掉更新后的数据库），给演示和测试用。
-- | 只要结果行
rowsOf :: Either String (Database, [Row]) -> Either String [Row]
rowsOf = fmap snd
-- * 泛型入口：走 MonadStorage，未来 IPCStorage 复用同一份代码
-- | 语义检查 + 分发到具体语句。
runQueryM :: (MonadStorage m) => Query -> m (Either String [Row])
runQueryM q = do
-- | 泛型入口：先检查再执行
runStatementM :: (MonadStorage m) => Statement -> m (Either String [Row])
runStatementM q = do
db <- snapshot
case check db q of
Left err -> pure (Left err)
Right _ -> runQueryUncheckedM q
Right _ -> runStatementUncheckedM q
-- | SELECT：拿快照，跑 translate → optimize → evalRelOp。
runQueryUncheckedM :: (MonadStorage m) => Query -> m (Either String [Row])
runQueryUncheckedM q@Select{} = do
-- * 分发执行
-- | 按语句类型分发（已检查过）
runStatementUncheckedM :: (MonadStorage m) => Statement -> m (Either String [Row])
runStatementUncheckedM q@Select{} = do
db <- snapshot
case translate q of
Left e -> pure (Left e)
Right relOp -> evalRelOpM db (optimize db relOp)
-- \| INSERT：求值后追加一行。
runQueryUncheckedM (Insert tbl cols vals) =
runStatementUncheckedM (Insert tbl cols vals) =
case mapM (\e -> evalExpr e []) vals of
Left err -> pure (Left err)
Right values
@@ -51,8 +53,7 @@ runQueryUncheckedM (Insert tbl cols vals) =
result <- insert tbl (zip cols values)
pure (result >> Right [])
-- \| DELETE：扫表、筛掉命中行、整体写回。
runQueryUncheckedM (Delete tbl mWhere) = do
runStatementUncheckedM (Delete tbl mWhere) = do
rowsResult <- scan tbl
case rowsResult of
Left err -> pure (Left err)
@@ -66,12 +67,11 @@ runQueryUncheckedM (Delete tbl mWhere) = do
result <- replaceAll tbl keptRows
pure (result >> Right [])
where
-- \| 保留 = 条件不成立。
-- \| 保留 = 条件不成立
shouldKeep :: Expr -> Row -> Either String Bool
shouldKeep e row = not <$> evalCondForRow e row
-- \| UPDATE：扫表、逐行改、整体写回。
runQueryUncheckedM (Update tbl assigns mWhere) = do
runStatementUncheckedM (Update tbl assigns mWhere) = do
rowsResult <- scan tbl
case rowsResult of
Left err -> pure (Left err)
@@ -83,7 +83,7 @@ runQueryUncheckedM (Update tbl assigns mWhere) = do
result <- replaceAll tbl rs
pure (result >> Right [])
where
-- \| 命中条件就套用赋值，否则原样返回。
-- \| 命中条件就套用赋值
updateRow :: Maybe Expr -> [(String, Expr)] -> Row -> Either String Row
updateRow cond asgns row = do
keep <- case cond of
@@ -91,7 +91,15 @@ runQueryUncheckedM (Update tbl assigns mWhere) = do
Just e -> evalCondForRow e row
if keep then applyUpdates asgns row else Right row
-- | 按 assignments 依次求值并覆盖对应列。
runStatementUncheckedM (CreateTable name cols) = do
result <- createTable name cols
pure (result >> Right [])
runStatementUncheckedM (DropTable name) = do
result <- dropTable name
pure (result >> Right [])
-- * 更新辅助
-- | 依次求值并覆盖列
applyUpdates :: [(String, Expr)] -> Row -> Either String Row
applyUpdates [] row = Right row
applyUpdates ((col, e) : rest) row = do
chusql-engine/src/ChuSQL/Model.hs
+12 -10
View File
@@ -1,25 +1,26 @@
module ChuSQL.Model (Column (..), Value (..), Row, Table (..), Database, colNames, colType, lookupTable, allColumns) where
-- 数据模型：列类型、值、行、表、数据库，外加"按名查表 / 查列类型"这类通用小工具。
-- 数据模型：列类型、值、行、表、数据库，外加几个查表小工具。
-- 列的类型
-- * 类型
-- | 列的类型
data Column
= TInt
| TStr
| TBool
deriving (Show, Eq)
-- 列的值：整数、字符串、布尔
-- | 列的值
data Value
= VInt Int
| VStr String
| VBool Bool
deriving (Show, Eq)
-- 一行：列名 → 值
-- | 一行：列名 -> 值
type Row = [(String, Value)]
-- 一张表
-- | 一张表
data Table = Table
{ tableName :: String
, tableCols :: [(String, Column)]
@@ -27,21 +28,22 @@ data Table = Table
}
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 = "*"
chusql-engine/src/ChuSQL/Semantic.hs
+30 -20
View File
@@ -3,19 +3,18 @@ module ChuSQL.Semantic (check) where
import ChuSQL.Algebra.Expr (colsInExpr)
import ChuSQL.Model
import ChuSQL.Syntax.AST
import Data.List (intercalate)
import Data.List (intercalate, nub)
-- 语义检查：执行前的关卡 —— 表和列存不存在、表达式类型对不对、写入的值类型是否匹配。
-- 语义检查：表和列在不在、类型对不对，全部在执行前查。
-- * 表与列名解析
-- | 给一批列加上"别名."前缀
-- * 环境
-- | 给列名加上别名前缀
prefixColumns :: Maybe String -> [(String, Column)] -> [(String, Column)]
prefixColumns mAlias cols = [(prefix ++ c, ty) | (c, ty) <- cols]
where
prefix = maybe "" (++ ".") mAlias
-- | 走一遍 FROM：算出可用列（带别名前缀），顺手把每个 ON 条件也查了
-- | 收集 FROM 能提供的列
checkFrom :: Database -> FromClause -> Either String [(String, Column)]
checkFrom db (FromTable mAlias tbl) = do
t <- lookupTable db tbl
@@ -27,9 +26,9 @@ checkFrom db (FromJoin left mAlias tbl cond) = do
checkBool "ON" env cond
Right env
-- * 列检查与报错
-- | 统一拼一条带"可用列清单"的报错
-- * 检查
-- | 拼“列不存在”的报错
missingColumn :: String -> String -> [(String, Column)] -> String
missingColumn place c env =
"unknown column in " ++ place ++ ": " ++ c ++ hint
@@ -38,16 +37,15 @@ missingColumn place c env =
| 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
@@ -64,7 +62,7 @@ inferExpr place env (Eq a b) = do
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
@@ -73,7 +71,7 @@ operands place env want a b = do
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)
@@ -82,9 +80,9 @@ checkBool place env e = do
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)
@@ -93,18 +91,18 @@ checkTyped place env t (c, e) = do
then Right ()
else Left (place ++ ": column " ++ c ++ " needs " ++ show want ++ ", got " ++ show got)
-- | INSERT 的一个值：环境是空的 —— 值必须是字面量，写列名会被拦下
-- | 检查插入值的类型
checkValue :: Table -> (String, Expr) -> Either String ()
checkValue = checkTyped "INSERT" []
-- | UPDATE 的一个赋值：环境是整张表 —— 右边可以引用本行的列
-- | 检查 UPDATE 的赋值
checkAssign :: Table -> (String, Expr) -> Either String ()
checkAssign t = checkTyped "UPDATE" (tableCols t) t
-- * 总入口
-- | 语义检查总入口：合法返回 Right ()，不合法返回 Left（带人话解释）
check :: Database -> Query -> Either String ()
-- * 入口
-- | 按语句类型分派检查
check :: Database -> Statement -> Either String ()
check db q = case q of
Select
{ selectCols = cols
@@ -128,3 +126,15 @@ check db q = case q of
checkColumns "UPDATE" (tableCols t) (map fst assigns)
mapM_ (checkAssign t) assigns
mapM_ (checkBool "WHERE" (tableCols t)) mWhere
CreateTable name cols -> do
if null name
then Left "CREATE TABLE: empty table name"
else do
let names = map fst cols
if length names /= length (nub names)
then Left ("CREATE TABLE: duplicate column names in " ++ name)
else Right ()
DropTable name ->
if null name
then Left "DROP TABLE: empty table name"
else Right ()
chusql-engine/src/ChuSQL/Storage.hs
+18 -8
View File
@@ -1,20 +1,30 @@
module ChuSQL.Storage (MonadStorage (..)) where
module ChuSQL.Storage (
MonadStorage (..),
) where
import ChuSQL.Model (Database, Row)
import ChuSQL.Model (Column, Database, Row)
-- 存储层抽象：上层只认 domain 类型，不关心底层是内存还是 IPC。
-- 存储层抽象：上层只认 domain 类型，不关心底层实现。
-- | 存储接口：读写表、按主键取行、取快照
class (Monad m) => MonadStorage m where
-- 全表扫描；表不存在返回 Left。
-- \| 全表扫描
scan :: String -> m (Either String [Row])
-- 追加一行到表尾；表不存在返回 Left。
-- \| 追加一行
insert :: String -> Row -> m (Either String ())
-- 用新行列表整体替换一张表。
-- \| 整表替换
replaceAll :: String -> [Row] -> m (Either String ())
-- 按主键查一行；命中返回 Just，未命中返回 Nothing。
-- \| 按主键取一行
lookupByKey :: String -> Int -> m (Either String (Maybe Row))
-- 取全库快照，喂给还接收 Database 的语义检查 / 优化器 / evalRelOp。
-- \| 建一张空表
createTable :: String -> [(String, Column)] -> m (Either String ())
-- \| 删除表
dropTable :: String -> m (Either String ())
-- \| 取全库快照
snapshot :: m Database
chusql-engine/src/ChuSQL/Storage/IPC.hs
+120 -60
View File
@@ -11,11 +11,13 @@ module ChuSQL.Storage.IPC (
doLookupByKey,
doInsertKeyed,
doDescribeTable,
doCreateTable,
doDropTable,
) where
import ChuSQL.Model
import ChuSQL.Storage
import Control.Exception (bracket)
import Control.Exception (IOException, bracket, try)
import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecodeStrict, encode, object, withObject, (.:), (.=))
import Data.Aeson qualified as A
import Data.Aeson.Key qualified as K
@@ -29,39 +31,41 @@ import Data.Text qualified as T
import System.Environment (lookupEnv)
import System.IO
-- IPC 存储实现：每个 MonadStorage 方法翻译成管道上的一条 JSON 请求。
-- IPC 存储实现：每个存储方法翻成管道上的一条 JSON 请求。
-- | IPC 实现：通过命名管道连 Rust 存储进程。
-- * 存储实现
-- | 命名管道上的存储
newtype IPCStorage a = IPCStorage
{ runIPCStorage :: IO a
}
-- | Functor：把 fmap 转发给底下的 IO。
-- | Functor：转发给 IO
instance Functor IPCStorage where
fmap f (IPCStorage m) = IPCStorage (fmap f m)
-- | Applicative：把 pure / <*> 转发给底下的 IO。
-- | Applicative：转发给 IO
instance Applicative IPCStorage where
pure = IPCStorage . pure
IPCStorage mf <*> IPCStorage ma = IPCStorage (mf <*> ma)
-- | Monad：顺序执行，转发给底下的 IO。
-- | Monad：顺序执行
instance Monad IPCStorage where
IPCStorage m >>= k = IPCStorage $ do
a <- m
runIPCStorage (k a)
-- | 管道路径；默认 \\.\pipe\chusql-storage，可用 CHUSQL_PIPE 覆盖。
-- * 管道
-- | 管道路径
pipePath :: IO String
pipePath = do
name <- maybe "chusql-storage" id <$> lookupEnv "CHUSQL_PIPE"
pure ("\\\\.\\pipe\\" ++ name)
-- | 打开管道、跑闭包、关闭。
-- | 开管道跑闭包
withPipe :: (Handle -> IO a) -> IO a
withPipe = bracket openPipe hClose
where
-- \| 二进制读写、不做换行翻译，跟 Rust 侧对齐。
-- \| 打开管道句柄
openPipe = do
path <- pipePath
h <- openFile path ReadWriteMode
@@ -69,39 +73,46 @@ withPipe = bracket openPipe hClose
hSetNewlineMode h noNewlineTranslation
pure h
-- | 发一条请求，读一条响应。
-- | 发一条请求读一条响应
sendRequest :: Request -> IO Response
sendRequest req = withPipe $ \h -> do
BL.hPutStr h (encode req)
BSC.hPutStr h "\n"
hFlush h
line <- BSC.hGetLine h
let cleaned = BSC.dropWhileEnd (== '\r') line
case eitherDecodeStrict cleaned of
Left err -> pure (RespError ("decode: " ++ err))
Right r -> pure r
sendRequest req = do
result <- try (withPipe roundTrip) :: IO (Either IOException Response)
pure $ case result of
Left e -> RespError ("pipe error: " ++ show e)
Right r -> r
where
roundTrip h = do
BL.hPutStr h (encode req)
BSC.hPutStr h "\n"
hFlush h
line <- BSC.hGetLine h
let cleaned = BSC.dropWhileEnd (== '\r') line
case eitherDecodeStrict cleaned of
Left err -> pure (RespError ("decode: " ++ err))
Right r -> pure r
-- * JSON 编解码
-- | 一列的 schema；对应 Rust 侧的 SchemaColumn。
-- * 编解码
-- | 一列的 schema
data SchemaColumn = SchemaColumn
{ scName :: String
, scType :: String
}
deriving (Show, Eq)
-- | SchemaColumn 编码；Haskell 侧只发 DescribeTable，编码用不上，暂存实现。
-- | SchemaColumn 编码
instance ToJSON SchemaColumn where
toJSON (SchemaColumn n t) = object ["name" .= n, "ty" .= t]
-- | SchemaColumn 解码：从 {"name": "...", "ty": "int"|"str"|"bool"} 读回。
-- | SchemaColumn 解码
instance FromJSON SchemaColumn where
parseJSON = withObject "SchemaColumn" $ \o -> do
n <- o .: "name"
t <- o .: "ty"
pure (SchemaColumn n t)
-- | 请求；对应 Rust 侧带 method tag 的 enum。
-- * 请求
-- | 请求类型
data Request
= ReqPing
| ReqScan String
@@ -110,8 +121,10 @@ data Request
| ReqListTables
| ReqLookupByKey String Int
| ReqDescribeTable String
| ReqCreateTable String [SchemaColumn]
| ReqDropTable String
-- | 请求编码：method 字段 + 各自参数。
-- | 请求编码
instance ToJSON Request where
toJSON ReqPing = object ["method" .= ("ping" :: T.Text)]
toJSON (ReqScan t) = object ["method" .= ("scan" :: T.Text), "table" .= t]
@@ -142,17 +155,26 @@ instance ToJSON Request where
[ "method" .= ("describe_table" :: T.Text)
, "table" .= t
]
toJSON (ReqCreateTable t cols) =
object
[ "method" .= ("create_table" :: T.Text)
, "table" .= t
, "columns" .= cols
]
toJSON (ReqDropTable t) =
object ["method" .= ("drop_table" :: T.Text), "table" .= t]
-- | 响应；对应 Rust 侧带 status tag 的 enum。
-- | 响应类型
data Response
= RespPong
| RespRows [Row]
| RespTables [String]
| RespSchema [SchemaColumn]
| RespSchema [SchemaColumn] Int
| RespOk
| RespError String
-- | 响应解码：按 status 字段分派。
-- | 响应解码
instance FromJSON Response where
parseJSON = withObject "Response" $ \o -> do
status <- o .: "status"
@@ -161,17 +183,20 @@ instance FromJSON Response where
"ok" -> pure RespOk
"rows" -> RespRows <$> (o .: "rows" >>= mapM rowFromJSON)
"tables" -> RespTables <$> o .: "tables"
"schema" -> RespSchema <$> o .: "columns"
"error" -> RespError <$> o .: "message"
"schema" -> do
cols <- o .: "columns"
cnt <- o .: "row_count"
pure (RespSchema cols cnt)
other -> fail ("unknown status: " ++ T.unpack other)
-- | Value 编码成 JSON 的 number / string / bool。
-- | 值编码成 JSON
valueToJSON :: Value -> A.Value
valueToJSON (VInt n) = A.Number (fromIntegral n)
valueToJSON (VStr s) = A.String (T.pack s)
valueToJSON (VBool b) = A.Bool b
-- | JSON 解回 Value；number 只接受整数。
-- | JSON 解回值
valueFromJSON :: A.Value -> Parser Value
valueFromJSON (A.Number n) =
case floatingOrInteger n :: Either Double Integer of
@@ -181,24 +206,24 @@ valueFromJSON (A.String s) = pure (VStr (T.unpack s))
valueFromJSON (A.Bool b) = pure (VBool b)
valueFromJSON _ = fail "unsupported value type"
-- | 一行编成 JSON object。
-- | 一行编码成 JSON
rowToJSON :: Row -> A.Value
rowToJSON r =
A.Object (KM.fromList [(K.fromString k, valueToJSON v) | (k, v) <- r])
-- | JSON object 解成一行。
-- | JSON 解回一行
rowFromJSON :: A.Value -> Parser Row
rowFromJSON (A.Object o) = mapM toPair (KM.toList o)
where
-- \| 解一个键值对。
-- \| 解一个键值对
toPair (k, v) = do
val <- valueFromJSON v
pure (K.toString k, val)
rowFromJSON _ = fail "row must be a JSON object"
-- * 内部请求封装
-- | 发 Scan 并把结果取成 Either。
-- * 内部封装
-- | 发 Scan
doScan :: String -> IO (Either String [Row])
doScan t = do
resp <- sendRequest (ReqScan t)
@@ -207,16 +232,22 @@ doScan t = do
RespError e -> Left e
_ -> Left "unexpected response to scan"
-- | 发 Insert（不带索引键）。
-- | 发 Insert（带 id 键）
doInsert :: String -> Row -> IO (Either String ())
doInsert t r = do
resp <- sendRequest (ReqInsert t r Nothing)
resp <- sendRequest (ReqInsert t r (rowKey r))
pure $ case resp of
RespOk -> Right ()
RespError e -> Left e
_ -> Left "unexpected response to insert"
-- | 发 Insert（带索引键）。
-- | 取行里的 id 作索引键
rowKey :: Row -> Maybe Int
rowKey r = case lookup "id" r of
Just (VInt k) -> Just k
_ -> Nothing
-- | 发 Insert（指定键）
doInsertKeyed :: String -> Row -> Int -> IO (Either String ())
doInsertKeyed t r k = do
resp <- sendRequest (ReqInsert t r (Just k))
@@ -225,7 +256,7 @@ doInsertKeyed t r k = do
RespError e -> Left e
_ -> Left "unexpected response to insert"
-- | 发 ReplaceAll。
-- | 发 ReplaceAll
doReplaceAll :: String -> [Row] -> IO (Either String ())
doReplaceAll t rs = do
resp <- sendRequest (ReqReplaceAll t rs)
@@ -234,7 +265,7 @@ doReplaceAll t rs = do
RespError e -> Left e
_ -> Left "unexpected response to replace_all"
-- | 发 ListTables。
-- | 发 ListTables
doListTables :: IO (Either String [String])
doListTables = do
resp <- sendRequest ReqListTables
@@ -243,7 +274,7 @@ doListTables = do
RespError e -> Left e
_ -> Left "unexpected response to list_tables"
-- | 发 LookupByIndex。
-- | 发 LookupByIndex
doLookupByKey :: String -> Int -> IO (Either String (Maybe Row))
doLookupByKey t k = do
resp <- sendRequest (ReqLookupByKey t k)
@@ -253,45 +284,63 @@ doLookupByKey t k = do
RespError e -> Left e
_ -> Left "unexpected response to lookup_by_index"
-- | 发 DescribeTable。
doDescribeTable :: String -> IO (Either String [SchemaColumn])
-- | 发 DescribeTable
doDescribeTable :: String -> IO (Either String ([SchemaColumn], Int))
doDescribeTable t = do
resp <- sendRequest (ReqDescribeTable t)
pure $ case resp of
RespSchema cols -> Right cols
RespSchema cols n -> Right (cols, n)
RespError e -> Left e
_ -> Left "unexpected response to describe_table"
-- | 把 Rust 的 schema 列转成 Model 的 Column；未知类型降级为 TStr。
-- | 发 CreateTable
doCreateTable :: String -> [SchemaColumn] -> IO (Either String ())
doCreateTable t cols = do
resp <- sendRequest (ReqCreateTable t cols)
pure $ case resp of
RespOk -> Right ()
RespError e -> Left e
_ -> Left "unexpected response to create_table"
-- | 发 DropTable
doDropTable :: String -> IO (Either String ())
doDropTable t = do
resp <- sendRequest (ReqDropTable t)
pure $ case resp of
RespOk -> Right ()
RespError e -> Left e
_ -> Left "unexpected response to drop_table"
-- * 表结构
-- | 线上 schema 转本地列
schemaToColumns :: [SchemaColumn] -> [(String, Column)]
schemaToColumns = map go
where
-- \| 按 ty 字符串映射成 Column 构造子。
go (SchemaColumn n "int") = (n, TInt)
go (SchemaColumn n "str") = (n, TStr)
go (SchemaColumn n "bool") = (n, TBool)
go (SchemaColumn n _) = (n, TStr)
-- | 从若干行推断列名与类型；catalog 拿不到时的兜底。
-- | 从行推断列和类型
inferColumns :: [Row] -> [(String, Column)]
inferColumns rows = [(n, inferType n) | n <- names]
where
-- \| 全部出现过的列名。
-- \| 出现过的列名
names = nub (concatMap (map fst) rows)
-- \| 用第一个出现的值推断列类型；找不到就给 TStr。
-- \| 按第一个值推断类型
inferType n = case [v | r <- rows, Just v <- [lookup n r]] of
(VInt _ : _) -> TInt
(VStr _ : _) -> TStr
(VBool _ : _) -> TBool
[] -> TStr
-- | 先 describe 拿列，再 scan 拿行；describe 拿不到时退回扫行推断。
-- | 扫一张表拼成 Table
loadTable :: String -> IO Table
loadTable t = do
schemaR <- doDescribeTable t
case schemaR of
Right cols -> do
Right (cols, _n) -> do
rowsR <- doScan t
case rowsR of
Right rows -> pure (Table t (schemaToColumns cols) rows)
@@ -302,30 +351,41 @@ loadTable t = do
Right rows -> pure (Table t (inferColumns rows) rows)
Left _ -> pure (Table t [] [])
-- * MonadStorage 实例
-- | IPC 实现：所有方法都走管道。
-- * MonadStorage 实例
-- | 存储方法全走管道
instance MonadStorage IPCStorage where
-- \| 发 Scan。
-- \| 发 Scan
scan t = IPCStorage (doScan t)
-- \| 发 Insert，不带索引键。
-- \| 发 Insert
insert t r = IPCStorage (doInsert t r)
-- \| 发 ReplaceAll。
-- \| 发 ReplaceAll
replaceAll t rs = IPCStorage (doReplaceAll t rs)
-- \| 发 LookupByIndex。
-- \| 发 LookupByIndex
lookupByKey t k = IPCStorage (doLookupByKey t k)
-- \| ListTables + 逐表 (describe, scan)，拼成 Database。
-- \| 发 CreateTable
createTable name cols = IPCStorage (doCreateTable name (map toWire cols))
where
-- \| 本地列类型转线上字符串
toWire (n, TInt) = SchemaColumn n "int"
toWire (n, TStr) = SchemaColumn n "str"
toWire (n, TBool) = SchemaColumn n "bool"
-- \| 发 DropTable
dropTable name = IPCStorage (doDropTable name)
-- \| 列表 + 逐表扫描拼库
snapshot = IPCStorage $ do
result <- doListTables
case result of
Left _ -> pure []
Right ts -> mapM loadDbEntry ts
where
-- \| 加载一个 (表名, 表) 对。
-- \| 加载一个 (表名, 表) 对
loadDbEntry t = do
tbl <- loadTable t
pure (t, tbl)
chusql-engine/src/ChuSQL/Storage/Memory.hs
+29 -13
View File
@@ -3,16 +3,19 @@ module ChuSQL.Storage.Memory (MemoryStorage (runMemoryStorage)) where
import ChuSQL.Model
import ChuSQL.Storage
-- | 内存实现：本质是 Database 上的 State，错误通道是 Either String。
-- 内存实现：状态是 Database，错误通道是 Either String。
-- * 实例
-- | 内存存储：Database 上的状态
newtype MemoryStorage a = MemoryStorage {runMemoryStorage :: Database -> Either String (a, Database)}
-- | Functor：把 fmap 转发给底下的 State。
-- | Functor：转发给底层状态
instance Functor MemoryStorage where
fmap f (MemoryStorage m) = MemoryStorage $ \db -> do
(a, db') <- m db
Right (f a, db')
-- | Applicative：转发 pure / <*>。
-- | Applicative：转发 pure 和 <*>
instance Applicative MemoryStorage where
pure x = MemoryStorage $ \db -> Right (x, db)
MemoryStorage mf <*> MemoryStorage ma = MemoryStorage $ \db -> do
@@ -20,47 +23,60 @@ instance Applicative MemoryStorage where
(a, db2) <- ma db1
Right (f a, db2)
-- | Monad：顺序执行，把动作转发给底下的 State。
-- | Monad：顺序执行
instance Monad MemoryStorage where
MemoryStorage m >>= k = MemoryStorage $ \db -> do
(a, db') <- m db
runMemoryStorage (k a) db'
-- | MonadStorage 实例：内存里直接改 Database。
-- | MonadStorage：直接改内存库
instance MonadStorage MemoryStorage where
-- \| 按名查表，返回所有行。
-- \| 全表扫描
scan t = MemoryStorage $ \db -> do
tbl <- lookupTable db t
Right (Right (tableRows tbl), db)
-- \| 追加一行到表尾。
-- \| 追加一行
insert t r = MemoryStorage $ \db -> do
tbl <- lookupTable db t
Right (Right (), replaceTable t tbl{tableRows = tableRows tbl ++ [r]} db)
-- \| 用新行列表替换整表内容。
-- \| 整表替换
replaceAll t rows = MemoryStorage $ \db -> do
tbl <- lookupTable db t
Right (Right (), replaceTable t tbl{tableRows = rows} db)
-- \| 找 id 列等于 k 的第一行。
-- \| 按主键找第一行
lookupByKey t k = MemoryStorage $ \db -> do
tbl <- lookupTable db t
Right (Right (findRow tbl k), db)
-- \| 原样返回当前数据库。
-- \| 建空表；已存在报错
createTable name cols = MemoryStorage $ \db ->
if any ((== name) . fst) db
then Right (Left ("table already exists: " ++ name), db)
else Right (Right (), db ++ [(name, Table name cols [])])
-- \| 删表；不存在报错
dropTable name = MemoryStorage $ \db ->
if any ((== name) . fst) db
then Right (Right (), filter ((/= name) . fst) db)
else Right (Left ("unknown table: " ++ name), db)
-- \| 原样返回当前库
snapshot = MemoryStorage $ \db -> Right (db, db)
-- | 按 id 列匹配一个整数。
-- * 工具
-- | 按 id 列找一行
findRow :: Table -> Int -> Maybe Row
findRow tbl k = case filter matches (tableRows tbl) of
(r : _) -> Just r
[] -> Nothing
where
-- \| 这行的 id 列是否等于 k。
-- \| 这行的 id 是否等于 k
matches r = lookup "id" r == Just (VInt k)
-- | 用给定表替换同名表；不存在就原样返回。
-- | 用给定表替换同名表
replaceTable :: String -> Table -> Database -> Database
replaceTable name table =
map (\(n, t) -> if n == name then (n, table) else (n, t))
chusql-engine/src/ChuSQL/Syntax/AST.hs
+17 -9
View File
@@ -1,9 +1,12 @@
module ChuSQL.Syntax.AST (Query (..), FromClause (..), Expr (..), SortDir (..), makeSelect) where
module ChuSQL.Syntax.AST (Statement (..), FromClause (..), Expr (..), SortDir (..), makeSelect) where
-- SQL 语法树：四类语句（SELECT / INSERT / DELETE / UPDATE）+ 表达式、FROM 从句、排序方向。
import ChuSQL.Model (Column (..))
-- 查询语句
data Query
-- 语法树：语句、数据来源、条件表达式、排序方向。
-- * 语句
-- | 一条语句：查 / 加 / 删 / 改 / 建表 / 删表
data Statement
= Select
{ selectCols :: [String]
, selectFrom :: FromClause
@@ -14,15 +17,18 @@ data Query
| Insert String [String] [Expr]
| Delete String (Maybe Expr)
| Update String [(String, Expr)] (Maybe Expr)
| CreateTable String [(String, Column)]
| DropTable String
deriving (Show, Eq)
-- FROM 从句：单表或 JOIN。
-- | 数据来源：单表，或两表拼接
data FromClause
= FromTable (Maybe String) String
| FromJoin FromClause (Maybe String) String Expr
deriving (Show, Eq)
-- 条件表达式
-- * 表达式
-- | 条件表达式
data Expr
= Col String
| LitInt Int
@@ -35,14 +41,16 @@ data Expr
| Or Expr Expr
deriving (Show, Eq)
-- 排序方向
-- * 排序
-- | 排序方向
data SortDir
= Asc
| Desc
deriving (Show, Eq)
-- 便捷构造：造一条最简单的 SELECT（给测试和演示用）。
makeSelect :: [String] -> String -> Maybe Expr -> Query
-- * 构造
-- | 造一个最简单的 SELECT
makeSelect :: [String] -> String -> Maybe Expr -> Statement
makeSelect cols tbl w =
Select
{ selectCols = cols
chusql-engine/src/ChuSQL/Syntax/Parser.hs
+109 -52
View File
@@ -1,7 +1,8 @@
{-# LANGUAGE ImportQualifiedPost #-}
module ChuSQL.Syntax.Parser (parseQuery) where
module ChuSQL.Syntax.Parser (parseStatement) where
import ChuSQL.Model (Column (..))
import ChuSQL.Syntax.AST
import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
import Data.Char (isAlpha, isAlphaNum, toLower)
@@ -12,48 +13,50 @@ import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as Lxr
-- SQL 解析器：把 SQL 文本解析成 AST。词法层管空白、关键字、标识符、字面量与符号；
-- 语法层按优先级 比较 > AND > OR 自底向上组装表达式。
-- SQL 解析：词法 + 语法，把文本变成语句树。
-- * 词法
-- | 解析器类型
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@ 再报错，导致无法回溯。
{- | 大小写不敏感的关键字；其后不能紧跟标识符字符，避免把 @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 '\''
@@ -61,8 +64,10 @@ stringLit = lexeme $ do
_ <- char '\''
return s
-- | 字符串内的一个字符：@''@ 折叠成一个单引号，其余字符（含反斜杠）原样保留。
-- 两个分支都不会在失败时消耗输入，因此可以安全地放进 'many'。
{- | 字符串内的一个字符：@''@ 折叠成一个单引号，其余字符（含反斜杠）原样保留。
两个分支都不会在失败时消耗输入，因此可以安全地放进 'many'。
-}
-- | 字符串里的一个字符
stringChar :: Parser Char
stringChar =
choice
@@ -70,31 +75,34 @@ stringChar =
, satisfy (/= '\'')
]
-- | 解析 ASC/DESC
-- * 子句
-- | 升序或降序
sortDir :: Parser SortDir
sortDir = (Desc <$ keyword "desc") <|> (Asc <$ keyword "asc") <|> pure Asc
-- | 解析 LIMIT
-- | LIMIT 后面的整数
limitClause :: Parser Int
limitClause = do
keyword "limit"
integer
-- | 解析JOIN和限定列名
-- | 能带表名的列名
qualifiedName :: Parser String
qualifiedName = do
first <- identifier
rest <- many (symbol "." *> identifier)
return (intercalate "." (first : rest))
-- * 表达式层
-- | 表达式入口，最低优先级。
-- * 表达式
-- | 读一个表达式
expr :: Parser Expr
expr = makeExprParser atom operatorTable
-- | 运算符表。注意 'makeExprParser' 要求各层按优先级从高到低排列：
-- 比较运算符绑定最紧，'AND' 次之，'OR' 最松。
{- | 运算符表。注意 'makeExprParser' 要求各层按优先级从高到低排列：
比较运算符绑定最紧，'AND' 次之，'OR' 最松。
-}
-- | 运算符优先级（从紧到松）
operatorTable :: [[Operator Parser Expr]]
operatorTable =
[
@@ -106,7 +114,7 @@ operatorTable =
, [InfixL (Or <$ keyword "OR")] -- 最低优先级
]
-- | 原子表达式：字面量、列引用或括号表达式。
-- | 最小的表达式单位
atom :: Parser Expr
atom =
choice
@@ -116,23 +124,22 @@ atom =
, between (symbol "(") (symbol ")") expr
]
-- * 语句层
-- | 显式指定排序的语句
-- | 一个排序列
orderItem :: Parser (String, SortDir)
orderItem = do
col <- qualifiedName
dir <- sortDir
return (col, dir)
-- | @ORDER BY col [ASC|DESC], ...@。
-- | ORDER BY 的列表
orderByClause :: Parser [(String, SortDir)]
orderByClause = do
keyword "order"
keyword "by"
sepBy1 orderItem (symbol ",")
-- | @col = expr@，用于 UPDATE 的 SET 子句。
-- | SET 里的一条赋值
assignment :: Parser (String, Expr)
assignment = do
col <- identifier
@@ -140,9 +147,8 @@ assignment = do
e <- expr
return (col, e)
-- * 从句层
-- | SQL 保留字，不能用作表别名
-- | 保留字清单
reservedWords :: [String]
reservedWords =
[ "select"
@@ -163,24 +169,28 @@ reservedWords =
, "delete"
, "update"
, "set"
, "create"
, "table"
]
-- | 表别名。别名不能是保留字：否则 @FROM users WHERE age > 18@ 会把 @WHERE@
-- 当成 @users@ 的别名吃掉，后面真正的 WHERE 子句就再也解析不到。
-- 用 'try' 包住，一旦命中保留字就整体回溯，让 'optional' 正常返回 'Nothing'。
{- | 表别名。别名不能是保留字：否则 @FROM users WHERE age > 18@ 会把 @WHERE@
当成 @users@ 的别名吃掉，后面真正的 WHERE 子句就再也解析不到。
用 'try' 包住，一旦命中保留字就整体回溯，让 'optional' 正常返回 'Nothing'。
-}
-- | 别名（不许用保留字）
aliasName :: Parser String
aliasName = try $ do
name <- identifier
if map toLower name `elem` reservedWords then empty else return name
-- | @表名 [别名]@。
-- | 表名 + 可选别名
tableRef :: Parser (Maybe String, String)
tableRef = do
tbl <- identifier
mAlias <- optional aliasName
return (mAlias, tbl)
-- | @JOIN 表 [别名] ON 条件@。
-- | 一个 JOIN ... ON
joinClause :: Parser (Maybe String, String, Expr)
joinClause = do
keyword "join"
@@ -189,14 +199,14 @@ joinClause = do
cond <- expr
return (mAlias, tbl, cond)
-- | FROM 从句：一张表 + 任意多个 JOIN。
-- | FROM 子句（可含多个 JOIN）
fromClause :: Parser FromClause
fromClause = do
(mAlias, tbl) <- tableRef
joins <- many joinClause
return (foldl (\acc (a, t, c) -> FromJoin acc a t c) (FromTable mAlias tbl) joins)
-- | 选择列表：@*@ 或逗号分隔的列名。
-- | SELECT 的列清单
selectList :: Parser [String]
selectList =
choice
@@ -204,9 +214,46 @@ selectList =
, (:) <$> qualifiedName <*> many (symbol "," *> qualifiedName)
]
-- | @SELECT ... FROM ... [WHERE ...]@。
selectQuery :: Parser Query
selectQuery = do
-- | 读 CREATE TABLE
createTableStatement :: Parser Statement
createTableStatement = do
keyword "create"
keyword "table"
name <- identifier
cols <- between (symbol "(") (symbol ")") (sepBy1 columnDef (symbol ","))
return (CreateTable name cols)
-- | 读 DROP TABLE
dropTableStatement :: Parser Statement
dropTableStatement = do
keyword "drop"
keyword "table"
name <- identifier
return (DropTable name)
-- | 建表时的一列
columnDef :: Parser (String, Column)
columnDef = do
name <- identifier
ty <- columnType
return (name, ty)
-- | 列类型关键字
columnType :: Parser Column
columnType =
(keyword "integer" >> pure TInt)
<|> (keyword "int" >> pure TInt)
<|> (keyword "varchar" >> pure TStr)
<|> (keyword "text" >> pure TStr)
<|> (keyword "str" >> pure TStr)
<|> (keyword "boolean" >> pure TBool)
<|> (keyword "bool" >> pure TBool)
-- * 语句
-- | 读 SELECT
selectStatement :: Parser Statement
selectStatement = do
keyword "select"
cols <- selectList
keyword "from"
@@ -223,9 +270,9 @@ selectQuery = do
, selectLimit = mLimit
}
-- | @INSERT ... INTO ... VALUES ...@。
insertQuery :: Parser Query
insertQuery = do
-- | 读 INSERT
insertStatement :: Parser Statement
insertStatement = do
keyword "INSERT"
keyword "INTO"
tbl <- identifier
@@ -242,18 +289,18 @@ insertQuery = do
(sepBy1 atom (symbol ","))
return (Insert tbl cols vals)
-- | @DELETE ... FROM ... [WHERE ...]@。
deleteQuery :: Parser Query
deleteQuery = do
-- | 读 DELETE
deleteStatement :: Parser Statement
deleteStatement = 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
-- | 读 UPDATE
updateStatement :: Parser Statement
updateStatement = do
keyword "update"
tbl <- identifier
keyword "set"
@@ -261,9 +308,19 @@ updateQuery = do
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
-- * 入口
-- | 解析总入口
parseStatement :: String -> Either String Statement
parseStatement input =
case runParser (sc *> statementP <* sc <* eof) "<query>" input of
Left err -> Left (errorBundlePretty err)
Right q -> Right q
where
-- \| 依次尝试各种语句
statementP =
selectStatement
<|> insertStatement
<|> deleteStatement
<|> updateStatement
<|> createTableStatement
<|> dropTableStatement
chusql-engine/test/Spec.hs
+196 -136
View File
@@ -62,19 +62,19 @@ main = hspec $ do
describe "ChuSQL.Syntax.Parser" $ do
it "parses a simple SELECT" $ do
parseQuery "SELECT name FROM users"
parseStatement "SELECT name FROM users"
`shouldBe` Right (makeSelect ["name"] "users" Nothing)
it "parses SELECT *" $ do
parseQuery "SELECT * FROM users"
parseStatement "SELECT * FROM users"
`shouldBe` Right (makeSelect ["*"] "users" Nothing)
it "parses multiple columns" $ do
parseQuery "SELECT name, age FROM users"
parseStatement "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"
parseStatement "SELECT name FROM users WHERE age > 18"
`shouldBe` Right
( makeSelect
["name"]
@@ -83,7 +83,7 @@ main = hspec $ do
)
it "parses AND" $ do
parseQuery "SELECT name FROM users WHERE age > 18 AND age < 30"
parseStatement "SELECT name FROM users WHERE age > 18 AND age < 30"
`shouldBe` Right
( makeSelect
["name"]
@@ -97,7 +97,7 @@ main = hspec $ do
)
it "parses OR" $ do
parseQuery "SELECT name FROM users WHERE age < 18 OR age > 60"
parseStatement "SELECT name FROM users WHERE age < 18 OR age > 60"
`shouldBe` Right
( makeSelect
["name"]
@@ -111,7 +111,7 @@ main = hspec $ do
)
it "is case-insensitive for keywords" $ do
parseQuery "select name from users where age > 18"
parseStatement "select name from users where age > 18"
`shouldBe` Right
( makeSelect
["name"]
@@ -120,11 +120,11 @@ main = hspec $ do
)
it "tolerates extra whitespace" $ do
parseQuery "SELECT name FROM users"
parseStatement "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'"
parseStatement "SELECT name FROM users WHERE name = 'Alice'"
`shouldBe` Right
( makeSelect
["name"]
@@ -133,7 +133,7 @@ main = hspec $ do
)
it "uses standard SQL escaping: '' is one quote" $ do
parseQuery "SELECT name FROM users WHERE name = 'It''s ok'"
parseStatement "SELECT name FROM users WHERE name = 'It''s ok'"
`shouldBe` Right
( makeSelect
["name"]
@@ -142,7 +142,7 @@ main = hspec $ do
)
it "treats a backslash as an ordinary character" $ do
parseQuery "SELECT name FROM users WHERE name = 'a\\b'"
parseStatement "SELECT name FROM users WHERE name = 'a\\b'"
`shouldBe` Right
( makeSelect
["name"]
@@ -151,7 +151,7 @@ main = hspec $ do
)
it "parses an empty string literal" $ do
parseQuery "SELECT name FROM users WHERE name = ''"
parseStatement "SELECT name FROM users WHERE name = ''"
`shouldBe` Right
( makeSelect
["name"]
@@ -160,7 +160,7 @@ main = hspec $ do
)
it "parses a string that is a single quote" $ do
parseQuery "SELECT name FROM users WHERE name = ''''"
parseStatement "SELECT name FROM users WHERE name = ''''"
`shouldBe` Right
( makeSelect
["name"]
@@ -169,15 +169,15 @@ main = hspec $ do
)
it "rejects an unterminated string literal" $ do
parseQuery "SELECT name FROM users WHERE name = 'oops"
parseStatement "SELECT name FROM users WHERE name = 'oops"
`shouldSatisfy` isLeft
it "allows digits inside identifiers" $ do
parseQuery "SELECT user1 FROM users"
parseStatement "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'"
parseStatement "SELECT name FROM users WHERE (age > 18 OR age < 5) AND name = 'Bob'"
`shouldBe` Right
( makeSelect
["name"]
@@ -194,16 +194,16 @@ main = hspec $ do
)
it "rejects trailing junk after a complete query" $ do
parseQuery "SELECT name FROM users extra junk"
parseStatement "SELECT name FROM users extra junk"
`shouldSatisfy` isLeft
it "returns Left on missing table name" $ do
parseQuery "SELECT name FROM"
parseStatement "SELECT name FROM"
`shouldSatisfy` isLeft
describe "ChuSQL.Syntax.Parser (JOIN)" $ do
it "parses a simple JOIN without aliases" $ do
parseQuery "SELECT name FROM users JOIN orders ON id = user_id"
parseStatement "SELECT name FROM users JOIN orders ON id = user_id"
`shouldBe` Right
( Select
{ selectCols = ["name"]
@@ -220,7 +220,7 @@ main = hspec $ do
)
it "parses JOIN with aliases" $ do
parseQuery "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id"
parseStatement "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id"
`shouldBe` Right
( Select
{ selectCols = ["u.name"]
@@ -237,13 +237,13 @@ main = hspec $ do
)
it "parses qualified column names" $ do
case parseQuery "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id" of
case parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id" of
Right q -> selectCols q `shouldBe` ["u.name", "o.product"]
Left err -> expectationFailure err
describe "ChuSQL.Engine (SELECT)" $ do
it "returns all rows without WHERE" $ do
rowsOf (runQuery testDB (makeSelect ["*"] "users" Nothing))
rowsOf (runStatement testDB (makeSelect ["*"] "users" Nothing))
`shouldBe` Right
[ [("id", VInt 1), ("name", VStr "Alice"), ("age", VInt 25)]
, [("id", VInt 2), ("name", VStr "Bob"), ("age", VInt 17)]
@@ -252,7 +252,7 @@ main = hspec $ do
it "filters with WHERE" $ do
rowsOf
( runQuery
( runStatement
testDB
( makeSelect
["name"]
@@ -266,7 +266,7 @@ main = hspec $ do
]
it "projects only the requested columns" $ do
rowsOf (runQuery testDB (makeSelect ["name"] "users" Nothing))
rowsOf (runStatement testDB (makeSelect ["name"] "users" Nothing))
`shouldBe` Right
[ [("name", VStr "Alice")]
, [("name", VStr "Bob")]
@@ -274,11 +274,11 @@ main = hspec $ do
]
it "returns Left for an unknown table" $ do
runQuery testDB (makeSelect ["name"] "nonexistent" Nothing)
runStatement testDB (makeSelect ["name"] "nonexistent" Nothing)
`shouldSatisfy` isLeft
it "returns Left for an unknown column" $ do
runQuery
runStatement
testDB
( makeSelect
["name"]
@@ -288,31 +288,31 @@ main = hspec $ do
`shouldSatisfy` isLeft
it "returns Left when WHERE is not a boolean" $ do
runQuery testDB (makeSelect ["name"] "users" (Just (Col "age")))
runStatement testDB (makeSelect ["name"] "users" (Just (Col "age")))
`shouldSatisfy` isLeft
it "returns Left for an unknown projected column" $ do
runQuery testDB (makeSelect ["nope"] "users" Nothing)
runStatement testDB (makeSelect ["nope"] "users" Nothing)
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (INSERT)" $ do
it "parses a simple INSERT" $ do
parseQuery "INSERT INTO users (name, age) VALUES ('Dave', 22)"
parseStatement "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')"
parseStatement "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)"
parseStatement "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
case runStatement testDB (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22]) of
Left err -> expectationFailure err
Right (db', _) -> do
rowsOf (runQuery db' (makeSelect ["name", "age"] "users" Nothing))
rowsOf (runStatement db' (makeSelect ["name", "age"] "users" Nothing))
`shouldBe` Right
[ [("name", VStr "Alice"), ("age", VInt 25)]
, [("name", VStr "Bob"), ("age", VInt 17)]
@@ -321,76 +321,76 @@ main = hspec $ do
]
it "does not modify the original database" $ do
case runQuery testDB (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22]) of
case runStatement testDB (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22]) of
Left err -> expectationFailure err
Right (_, _) -> do
rowsOf (runQuery testDB (makeSelect ["name"] "users" Nothing))
rowsOf (runStatement testDB (makeSelect ["name"] "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"])
runStatement testDB (Insert "users" ["name", "age"] [LitStr "Dave"])
`shouldSatisfy` isLeft
it "returns Left for an unknown table" $ do
runQuery testDB (Insert "nonexistent" ["name"] [LitStr "X"])
runStatement 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"])
runStatement testDB (Insert "users" ["name"] [Col "other"])
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (DELETE)" $ do
it "parses DELETE with WHERE" $ do
parseQuery "DELETE FROM users WHERE age < 18"
parseStatement "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"
parseStatement "DELETE FROM users"
`shouldBe` Right (Delete "users" Nothing)
it "parses DELETE case-insensitively" $ do
parseQuery "delete from users where age < 18"
parseStatement "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
case runStatement testDB (Delete "users" (Just (Lt (Col "age") (LitInt 18)))) of
Left err -> expectationFailure err
Right (db', _) -> do
rowsOf (runQuery db' (makeSelect ["name"] "users" Nothing))
rowsOf (runStatement db' (makeSelect ["name"] "users" Nothing))
`shouldBe` Right
[ [("name", VStr "Alice")]
, [("name", VStr "Carol")]
]
it "executes DELETE without WHERE, removing all rows" $ do
case runQuery testDB (Delete "users" Nothing) of
case runStatement testDB (Delete "users" Nothing) of
Left err -> expectationFailure err
Right (db', _) -> do
rowsOf (runQuery db' (makeSelect ["name"] "users" Nothing))
rowsOf (runStatement db' (makeSelect ["name"] "users" Nothing))
`shouldBe` Right []
it "does not modify the original database" $ do
case runQuery testDB (Delete "users" Nothing) of
case runStatement testDB (Delete "users" Nothing) of
Left err -> expectationFailure err
Right (_, _) -> do
rowsOf (runQuery testDB (makeSelect ["name"] "users" Nothing))
rowsOf (runStatement testDB (makeSelect ["name"] "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)
runStatement 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))))
runStatement testDB (Delete "users" (Just (Gt (Col "unknown") (LitInt 18))))
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (UPDATE)" $ do
it "parses UPDATE with WHERE" $ do
parseQuery "UPDATE users SET age = 26 WHERE name = 'Alice'"
parseStatement "UPDATE users SET age = 26 WHERE name = 'Alice'"
`shouldBe` Right
( Update
"users"
@@ -399,12 +399,12 @@ main = hspec $ do
)
it "parses UPDATE without WHERE" $ do
parseQuery "UPDATE users SET age = 26"
parseStatement "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'"
parseStatement "UPDATE users SET age = 26, name = 'Dave'"
`shouldBe` Right
( Update
"users"
@@ -413,7 +413,7 @@ main = hspec $ do
)
it "parses UPDATE case-insensitively" $ do
parseQuery "update users set age = 26 where name = 'Alice'"
parseStatement "update users set age = 26 where name = 'Alice'"
`shouldBe` Right
( Update
"users"
@@ -422,10 +422,10 @@ main = hspec $ do
)
it "executes UPDATE with WHERE, modifying matching rows" $ do
case runQuery testDB (Update "users" [("age", LitInt 99)] (Just (Eq (Col "name") (LitStr "Alice")))) of
case runStatement testDB (Update "users" [("age", LitInt 99)] (Just (Eq (Col "name") (LitStr "Alice")))) of
Left err -> expectationFailure err
Right (db', _) -> do
rowsOf (runQuery db' (makeSelect ["name", "age"] "users" Nothing))
rowsOf (runStatement db' (makeSelect ["name", "age"] "users" Nothing))
`shouldBe` Right
[ [("name", VStr "Alice"), ("age", VInt 99)]
, [("name", VStr "Bob"), ("age", VInt 17)]
@@ -433,10 +433,10 @@ main = hspec $ do
]
it "executes UPDATE without WHERE, modifying all rows" $ do
case runQuery testDB (Update "users" [("age", LitInt 0)] Nothing) of
case runStatement testDB (Update "users" [("age", LitInt 0)] Nothing) of
Left err -> expectationFailure err
Right (db', _) -> do
rowsOf (runQuery db' (makeSelect ["name", "age"] "users" Nothing))
rowsOf (runStatement db' (makeSelect ["name", "age"] "users" Nothing))
`shouldBe` Right
[ [("name", VStr "Alice"), ("age", VInt 0)]
, [("name", VStr "Bob"), ("age", VInt 0)]
@@ -444,10 +444,10 @@ main = hspec $ do
]
it "applies multiple assignments to each row" $ do
case runQuery testDB (Update "users" [("age", LitInt 99), ("name", LitStr "X")] Nothing) of
case runStatement testDB (Update "users" [("age", LitInt 99), ("name", LitStr "X")] Nothing) of
Left err -> expectationFailure err
Right (db', _) -> do
rowsOf (runQuery db' (makeSelect ["name", "age"] "users" Nothing))
rowsOf (runStatement db' (makeSelect ["name", "age"] "users" Nothing))
`shouldBe` Right
[ [("name", VStr "X"), ("age", VInt 99)]
, [("name", VStr "X"), ("age", VInt 99)]
@@ -455,51 +455,51 @@ main = hspec $ do
]
it "does not modify the original database" $ do
case runQuery testDB (Update "users" [("age", LitInt 0)] Nothing) of
case runStatement testDB (Update "users" [("age", LitInt 0)] Nothing) of
Left err -> expectationFailure err
Right (_, _) -> do
rowsOf (runQuery testDB (makeSelect ["name"] "users" Nothing))
rowsOf (runStatement testDB (makeSelect ["name"] "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)
runStatement 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))))
runStatement 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)
runStatement testDB (Update "users" [("unknown", LitInt 0)] Nothing)
`shouldSatisfy` \r -> case r of
Right _ -> True
Left _ -> True
describe "ChuSQL.Engine (ORDER BY)" $ do
it "parses ORDER BY ASC" $ do
case parseQuery "SELECT name FROM users ORDER BY age ASC" of
case parseStatement "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
case parseStatement "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
case parseStatement "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
case parseStatement "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
case parseStatement "SELECT name FROM users" of
Right q -> selectOrderBy q `shouldBe` []
Left err -> expectationFailure err
@@ -512,7 +512,7 @@ main = hspec $ do
, selectOrderBy = [("age", Asc)]
, selectLimit = Nothing
}
rowsOf (runQuery testDB q)
rowsOf (runStatement testDB q)
`shouldBe` Right
[ [("name", VStr "Bob")]
, [("name", VStr "Alice")]
@@ -528,7 +528,7 @@ main = hspec $ do
, selectOrderBy = [("age", Desc)]
, selectLimit = Nothing
}
rowsOf (runQuery testDB q)
rowsOf (runStatement testDB q)
`shouldBe` Right
[ [("name", VStr "Carol")]
, [("name", VStr "Alice")]
@@ -544,7 +544,7 @@ main = hspec $ do
, selectOrderBy = [("name", Asc)]
, selectLimit = Nothing
}
rowsOf (runQuery testDB q)
rowsOf (runStatement testDB q)
`shouldBe` Right
[ [("name", VStr "Alice")]
, [("name", VStr "Bob")]
@@ -560,23 +560,23 @@ main = hspec $ do
, selectOrderBy = [("nope", Asc)]
, selectLimit = Nothing
}
runQuery testDB q `shouldSatisfy` isLeft
runStatement testDB q `shouldSatisfy` isLeft
describe "ChuSQL.Engine (LIMIT)" $ do
it "parses LIMIT" $ do
case parseQuery "SELECT * FROM users LIMIT 2" of
case parseStatement "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
case parseStatement "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
case parseStatement "SELECT * FROM users" of
Right q -> selectLimit q `shouldBe` Nothing
Left err -> expectationFailure err
@@ -589,7 +589,7 @@ main = hspec $ do
, selectOrderBy = []
, selectLimit = Just 2
}
rowsOf (runQuery testDB q)
rowsOf (runStatement testDB q)
`shouldBe` Right
[ [("name", VStr "Alice")]
, [("name", VStr "Bob")]
@@ -604,7 +604,7 @@ main = hspec $ do
, selectOrderBy = [("age", Desc)]
, selectLimit = Just 2
}
rowsOf (runQuery testDB q)
rowsOf (runStatement testDB q)
`shouldBe` Right
[ [("name", VStr "Carol")]
, [("name", VStr "Alice")]
@@ -619,7 +619,7 @@ main = hspec $ do
, selectOrderBy = []
, selectLimit = Just 10
}
rowsOf (runQuery testDB q)
rowsOf (runStatement testDB q)
`shouldBe` Right
[ [("name", VStr "Alice")]
, [("name", VStr "Bob")]
@@ -635,16 +635,16 @@ main = hspec $ do
, selectOrderBy = []
, selectLimit = Just 0
}
rowsOf (runQuery testDB q)
rowsOf (runStatement testDB q)
`shouldBe` Right []
it "rejects negative LIMIT" $ do
parseQuery "SELECT * FROM users LIMIT -1"
parseStatement "SELECT * FROM users LIMIT -1"
`shouldSatisfy` isLeft
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)
rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id" >>= runStatement testDB)
`shouldBe` Right
[ [("u.name", VStr "Alice"), ("o.product", VStr "Book")]
, [("u.name", VStr "Alice"), ("o.product", VStr "Cup")]
@@ -652,14 +652,14 @@ main = hspec $ do
]
it "executes JOIN with WHERE" $ do
rowsOf (parseQuery "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20" >>= runQuery testDB)
rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20" >>= runStatement testDB)
`shouldBe` Right
[ [("u.name", VStr "Alice"), ("o.product", VStr "Book")]
, [("u.name", VStr "Alice"), ("o.product", VStr "Cup")]
]
it "executes JOIN with ORDER BY" $ do
rowsOf (parseQuery "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id ORDER BY o.product DESC" >>= runQuery testDB)
rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id ORDER BY o.product DESC" >>= runStatement testDB)
`shouldBe` Right
[ [("u.name", VStr "Bob"), ("o.product", VStr "Pen")]
, [("u.name", VStr "Alice"), ("o.product", VStr "Cup")]
@@ -667,14 +667,14 @@ main = hspec $ do
]
it "executes JOIN with LIMIT" $ do
rowsOf (parseQuery "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id LIMIT 2" >>= runQuery testDB)
rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id LIMIT 2" >>= runStatement testDB)
`shouldBe` Right
[ [("u.name", VStr "Alice"), ("o.product", VStr "Book")]
, [("u.name", VStr "Alice"), ("o.product", VStr "Cup")]
]
it "returns Left when JOIN table not found" $ do
runQuery
runStatement
testDB
( Select
{ selectCols = ["u.name"]
@@ -692,7 +692,7 @@ main = hspec $ do
`shouldSatisfy` isLeft
it "returns Left when ON references an unknown column" $ do
runQuery
runStatement
testDB
( Select
{ selectCols = ["u.name"]
@@ -711,7 +711,7 @@ main = hspec $ do
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)
rowsOf (parseStatement "SELECT name FROM users WHERE age > 18" >>= runStatement testDB)
`shouldBe` Right
[ [("name", VStr "Alice")]
, [("name", VStr "Carol")]
@@ -719,8 +719,8 @@ main = hspec $ do
it "parses and executes a complex query" $ do
rowsOf
( parseQuery "SELECT name FROM users WHERE age < 18 OR age > 28"
>>= runQuery testDB
( parseStatement "SELECT name FROM users WHERE age < 18 OR age > 28"
>>= runStatement testDB
)
`shouldBe` Right
[ [("name", VStr "Bob")]
@@ -728,14 +728,14 @@ main = hspec $ do
]
it "returns Left when parsing fails" $ do
(parseQuery "SELECT name FROM" >>= runQuery testDB)
(parseStatement "SELECT name FROM" >>= runStatement testDB)
`shouldSatisfy` isLeft
it "INSERT then SELECT end-to-end" $ do
case parseQuery "INSERT INTO users (name, age) VALUES ('Dave', 22)" >>= runQuery testDB of
case parseStatement "INSERT INTO users (name, age) VALUES ('Dave', 22)" >>= runStatement testDB of
Left err -> expectationFailure err
Right (db', _) -> do
rowsOf (parseQuery "SELECT name FROM users WHERE age > 18" >>= runQuery db')
rowsOf (parseStatement "SELECT name FROM users WHERE age > 18" >>= runStatement db')
`shouldBe` Right
[ [("name", VStr "Alice")]
, [("name", VStr "Carol")]
@@ -743,19 +743,19 @@ main = hspec $ do
]
it "DELETE then SELECT end-to-end" $ do
case parseQuery "DELETE FROM users WHERE age > 20" >>= runQuery testDB of
case parseStatement "DELETE FROM users WHERE age > 20" >>= runStatement testDB of
Left err -> expectationFailure err
Right (db', _) -> do
rowsOf (parseQuery "SELECT name FROM users" >>= runQuery db')
rowsOf (parseStatement "SELECT name FROM users" >>= runStatement 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
case parseStatement "UPDATE users SET age = 99 WHERE name = 'Alice'" >>= runStatement testDB of
Left err -> expectationFailure err
Right (db', _) -> do
rowsOf (parseQuery "SELECT name, age FROM users" >>= runQuery db')
rowsOf (parseStatement "SELECT name, age FROM users" >>= runStatement db')
`shouldBe` Right
[ [("name", VStr "Alice"), ("age", VInt 99)]
, [("name", VStr "Bob"), ("age", VInt 17)]
@@ -763,27 +763,27 @@ main = hspec $ do
]
it "ORDER BY with WHERE end-to-end" $ do
rowsOf (parseQuery "SELECT name FROM users WHERE age > 18 ORDER BY age DESC" >>= runQuery testDB)
rowsOf (parseStatement "SELECT name FROM users WHERE age > 18 ORDER BY age DESC" >>= runStatement testDB)
`shouldBe` Right
[ [("name", VStr "Carol")]
, [("name", VStr "Alice")]
]
it "ORDER BY with LIMIT end-to-end" $ do
rowsOf (parseQuery "SELECT name FROM users ORDER BY age DESC LIMIT 2" >>= runQuery testDB)
rowsOf (parseStatement "SELECT name FROM users ORDER BY age DESC LIMIT 2" >>= runStatement 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)
rowsOf (parseStatement "SELECT name FROM users WHERE age > 15 ORDER BY age DESC LIMIT 1" >>= runStatement testDB)
`shouldBe` Right
[ [("name", VStr "Carol")]
]
it "JOIN with WHERE and ORDER BY end-to-end" $ do
rowsOf (parseQuery "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 15 ORDER BY o.product" >>= runQuery testDB)
rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 15 ORDER BY o.product" >>= runStatement testDB)
`shouldBe` Right
[ [("u.name", VStr "Alice"), ("o.product", VStr "Book")]
, [("u.name", VStr "Alice"), ("o.product", VStr "Cup")]
@@ -804,7 +804,7 @@ main = hspec $ do
sameResultAsUnoptimized "SELECT * FROM users"
it "pushes a single-side predicate into the left side of a JOIN" $ do
case parseQuery "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20" of
case parseStatement "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 q of
@@ -813,7 +813,7 @@ main = hspec $ do
filterPushedIntoLeft (optimize testDB relOp) `shouldBe` True
it "removes a redundant SELECT * projection" $ do
case parseQuery "SELECT * FROM users" of
case parseStatement "SELECT * FROM users" of
Left err -> expectationFailure err
Right q ->
case translate q of
@@ -827,7 +827,7 @@ main = hspec $ do
optimize testDB relOp `shouldBe` relOp
it "is idempotent after reaching a fixed point" $ 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
case parseStatement "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 q of
@@ -872,11 +872,11 @@ main = hspec $ do
sameResultAsUnoptimized "SELECT name FROM users WHERE 'abc' > 1"
it "returns no rows for a constant-false predicate" $ do
rowsOf (parseQuery "SELECT name FROM users WHERE 1 > 2" >>= runQuery testDB)
rowsOf (parseStatement "SELECT name FROM users WHERE 1 > 2" >>= runStatement testDB)
`shouldBe` Right []
it "returns every row for a constant-true predicate" $ do
rowsOf (parseQuery "SELECT name FROM users WHERE 1 = 1" >>= runQuery testDB)
rowsOf (parseStatement "SELECT name FROM users WHERE 1 = 1" >>= runStatement testDB)
`shouldBe` Right
[ [("name", VStr "Alice")]
, [("name", VStr "Bob")]
@@ -961,123 +961,123 @@ main = hspec $ do
describe "ChuSQL.Semantic" $ do
it "rejects an unknown column in WHERE" $ do
(parseQuery "SELECT name FROM users WHERE nope > 18" >>= runQuery testDB)
(parseStatement "SELECT name FROM users WHERE nope > 18" >>= runStatement 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)
(parseStatement "SELECT name FROM users WHERE nope > 18" >>= runStatement 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)
(parseStatement "SELECT u.name FROM users u JOIN orders o ON u.nope = o.user_id" >>= runStatement testDB)
`shouldSatisfy` isLeft
it "rejects a type mismatch inside a comparison" $ do
(parseQuery "SELECT name FROM users WHERE name > 18" >>= runQuery testDB)
(parseStatement "SELECT name FROM users WHERE name > 18" >>= runStatement 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)
(parseStatement "SELECT name FROM users WHERE name > 18" >>= runStatement emptyDB)
`shouldSatisfy` isLeft
it "rejects a WHERE clause that is not a condition" $ do
(parseQuery "SELECT name FROM users WHERE age" >>= runQuery testDB)
(parseStatement "SELECT name FROM users WHERE age" >>= runStatement 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)
(parseStatement "SELECT name FROM users WHERE age" >>= runStatement emptyDB)
`shouldSatisfy` isLeft
it "rejects comparing two different types with =" $ do
(parseQuery "SELECT name FROM users WHERE name = 18" >>= runQuery testDB)
(parseStatement "SELECT name FROM users WHERE name = 18" >>= runStatement testDB)
`shouldSatisfy` isLeft
it "rejects an unknown column in INSERT" $ do
(parseQuery "INSERT INTO users (nickname) VALUES (1)" >>= runQuery testDB)
(parseStatement "INSERT INTO users (nickname) VALUES (1)" >>= runStatement 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)
(parseStatement "INSERT INTO users (name, age) VALUES ('Dave', 'abc')" >>= runStatement testDB)
`shouldSatisfy` isLeft
it "rejects an unknown column in UPDATE SET" $ do
(parseQuery "UPDATE users SET nope = 1" >>= runQuery testDB)
(parseStatement "UPDATE users SET nope = 1" >>= runStatement testDB)
`shouldSatisfy` isLeft
it "rejects an unknown column in DELETE WHERE" $ do
(parseQuery "DELETE FROM users WHERE nope > 1" >>= runQuery testDB)
(parseStatement "DELETE FROM users WHERE nope > 1" >>= runStatement testDB)
`shouldSatisfy` isLeft
it "still accepts a valid query" $ do
rowsOf (parseQuery "SELECT name FROM users WHERE age > 18" >>= runQuery testDB)
rowsOf (parseStatement "SELECT name FROM users WHERE age > 18" >>= runStatement 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)
(parseStatement "UPDATE users SET age = 'abc'" >>= runStatement 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)
(parseStatement "SELECT u.name FROM users u JOIN orders o ON u.name = o.user_id" >>= runStatement 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)
(parseStatement "DELETE FROM users WHERE nope > 1" >>= runStatement 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)
(parseStatement "UPDATE users SET nope = 1" >>= runStatement 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)
(parseStatement "INSERT INTO users (name) VALUES ('Eve')" >>= runStatement 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
case parseStatement "SELECT name FROM users WHERE nope > 18" >>= runStatement 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
case parseStatement "INSERT INTO users (nickname) VALUES (1)" >>= runStatement 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
case parseStatement "SELECT name FROM users ORDER BY nope" >>= runStatement 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
case parseStatement "SELECT u.name FROM users u JOIN orders o ON u.name = o.user_id" >>= runStatement 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
case parseStatement "UPDATE users SET age = 'abc'" >>= runStatement 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)
(parseStatement "SELECT * FROM users u JOIN orders o ON u.id = o.user_id" >>= runStatement testDB)
`shouldSatisfy` isRight
describe "ChuSQL.Algebra.Op" $ do
it "renders a plan as indented text" $ do
case parseQuery "SELECT name FROM users WHERE age > 18" >>= translate of
case parseStatement "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
case parseStatement "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)
@@ -1088,7 +1088,7 @@ main = hspec $ do
]
it "renders a sort and limit plan" $ do
case parseQuery "SELECT name FROM users ORDER BY age DESC LIMIT 2" >>= translate of
case parseStatement "SELECT name FROM users ORDER BY age DESC LIMIT 2" >>= translate of
Left err -> expectationFailure err
Right plan ->
lines (renderPlan plan)
@@ -1180,7 +1180,67 @@ main = hspec $ do
withPipeName "chusql-no-such-server" $ do
result <- runIPCStorage (scan "users")
result `shouldSatisfy` isLeft
it "parses CREATE TABLE with two columns" $ do
parseStatement "CREATE TABLE users (id INT, name TEXT)"
`shouldBe` Right (CreateTable "users" [("id", TInt), ("name", TStr)])
it "parses CREATE TABLE case-insensitively" $ do
parseStatement "create table users (id int, name text)"
`shouldBe` Right (CreateTable "users" [("id", TInt), ("name", TStr)])
it "parses CREATE TABLE with BOOL column" $ do
parseStatement "CREATE TABLE t (flag BOOL)"
`shouldBe` Right (CreateTable "t" [("flag", TBool)])
it "parses CREATE TABLE with VARCHAR as TStr" $ do
parseStatement "CREATE TABLE t (name VARCHAR)"
`shouldBe` Right (CreateTable "t" [("name", TStr)])
it "parses CREATE TABLE with INTEGER" $ do
parseStatement "CREATE TABLE t (id INTEGER)"
`shouldBe` Right (CreateTable "t" [("id", TInt)])
it "rejects CREATE TABLE without columns" $ do
parseStatement "CREATE TABLE t ()"
`shouldSatisfy` isLeft
it "rejects CREATE TABLE with missing type" $ do
parseStatement "CREATE TABLE t (id)"
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (CREATE TABLE)" $ do
it "creates a table in memory" $ do
case runStatement testDB (CreateTable "newt" [("id", TInt), ("name", TStr)]) of
Left err -> expectationFailure err
Right (db', _) -> do
rowsOf (runStatement db' (makeSelect ["*"] "newt" Nothing))
`shouldBe` Right []
it "rejects creating an existing table" $ do
runStatement testDB (CreateTable "users" [("id", TInt)])
`shouldSatisfy` isLeft
it "rejects duplicate column names" $ do
runStatement testDB (CreateTable "dup" [("id", TInt), ("id", TStr)])
`shouldSatisfy` isLeft
it "rejects empty column list at parse time" $ do
parseStatement "CREATE TABLE t ()"
`shouldSatisfy` isLeft
it "parses DROP TABLE" $ do
parseStatement "DROP TABLE users"
`shouldBe` Right (DropTable "users")
it "drops a table in memory" $ do
case runStatement testDB (DropTable "users") of
Left e -> expectationFailure e
Right (db', _) -> do
runStatement db' (makeSelect ["*"] "users" Nothing)
`shouldSatisfy` isLeft
it "rejects dropping a nonexistent table" $ do
runStatement testDB (DropTable "nope")
`shouldSatisfy` isLeft
emptyDB :: Database
emptyDB = [(n, t{tableRows = []}) | (n, t) <- testDB]
@@ -1305,7 +1365,7 @@ isRight (Left _) = False
sameResultAsUnoptimized :: String -> Expectation
sameResultAsUnoptimized sql =
case parseQuery sql of
case parseStatement sql of
Left err -> expectationFailure err
Right q ->
case translate q of
@@ -1319,7 +1379,7 @@ filterPushedIntoLeft _ = False
optimizedPlan :: String -> Either String RelOp
optimizedPlan sql = do
q <- parseQuery sql
q <- parseStatement sql
optimize testDB <$> translate q
firstFilterCond :: RelOp -> Maybe Expr
@@ -1353,7 +1413,7 @@ stripProjects (Lookup t k) = Lookup t k
projectedPlan :: String -> Either String RelOp
projectedPlan sql = do
q <- parseQuery sql
q <- parseStatement sql
plan <- translate q
Right (pushProject testDB ["*"] plan)