完成Haskell部分的SQL词法分析器

This commit is contained in:
LIm1tZz7 committed 2026-09-19 19:22:50 +08:00
commit a9ef1ef3e2
21 files changed
+1547

No files matched your search

+52
View File
@@ -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))
+40
View File
@@ -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.
+104
View File
@@ -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)
+48
View File
@@ -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))
+37
View File
@@ -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
+22
View File
@@ -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.
+42
View File
@@ -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
}
+213
View File
@@ -0,0 +1,213 @@
{-# LANGUAGE ImportQualifiedPost #-}
{- | SQL 语法分析器:把 SQL 文本解析为 'ChuSQL.Syntax.Ast.Query'。
词法层负责空白、关键字、标识符、字面量与符号;语法层按
优先级 比较 &gt; AND &gt; 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
+4
View File
@@ -0,0 +1,4 @@
resolver: lts-24.59
packages:
- .
+12
View File
@@ -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
+702
View File
@@ -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