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

chusql-engine/src/ChuSQL/Eval/Executor.hs

@@ -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)

chusql-engine/src/ChuSQL/Eval/Expr.hs

@@ -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))

chusql-engine/src/ChuSQL/Eval/Sort.hs

@@ -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

chusql-engine/src/ChuSQL/Model.hs

@@ -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)]

chusql-engine/src/ChuSQL/Syntax/Ast.hs

@@ -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
+        }

chusql-engine/src/ChuSQL/Syntax/Parser.hs

@@ -0,0 +1,213 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+{- | SQL 语法分析器：把 SQL 文本解析为 'ChuSQL.Syntax.Ast.Query'。
+
+词法层负责空白、关键字、标识符、字面量与符号；语法层按
+优先级 比较 > AND > OR 自底向上组装表达式。
+-}
+module ChuSQL.Syntax.Parser (
+    Parser,
+    parseQuery,
+    expr,
+    identifier,
+    integer,
+    stringLit,
+) where
+
+import ChuSQL.Syntax.Ast
+import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
+import Data.Char (isAlpha, isAlphaNum)
+import Data.Maybe (fromMaybe)
+import Data.Void (Void)
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Text.Megaparsec.Char.Lexer qualified as Lxr
+
+type Parser = Parsec Void String
+
+-- * 词法层
+
+-- | 跳过空白（含换行）。
+sc :: Parser ()
+sc = Lxr.space space1 empty empty
+
+-- | 消费一个词法单元以及其后的空白。
+lexeme :: Parser a -> Parser a
+lexeme = Lxr.lexeme sc
+
+symbol :: String -> Parser String
+symbol = Lxr.symbol sc
+
+{- | 大小写不敏感的关键字；其后不能紧跟标识符字符，避免把 @selection@ 读成 @select@。
+整体用 'try' 包住：否则 @ORDER@ 会被 @keyword "or"@ 吃掉前缀 @OR@ 再报错，导致无法回溯。
+-}
+keyword :: String -> Parser ()
+keyword k = lexeme $ try $ do
+    _ <- string' k
+    notFollowedBy (satisfy isIdentChar)
+
+-- | 标识符：字母或下划线开头，其后可跟字母、数字或下划线。
+identifier :: Parser String
+identifier = lexeme $ do
+    first <- satisfy (\ch -> isAlpha ch || ch == '_')
+    rest <- many (satisfy isIdentChar)
+    return (first : rest)
+
+isIdentChar :: Char -> Bool
+isIdentChar ch = isAlphaNum ch || ch == '_'
+
+-- | 十进制整数字面量。
+integer :: Parser Int
+integer = lexeme Lxr.decimal
+
+-- | 单引号字符串字面量，遵循标准 SQL 转义规则：
+stringLit :: Parser String
+stringLit = lexeme $ do
+    _ <- char '\''
+    s <- many stringChar
+    _ <- char '\''
+    return s
+
+{- | 字符串内的一个字符：@''@ 折叠成一个单引号，其余字符（含反斜杠）原样保留。
+两个分支都不会在失败时消耗输入，因此可以安全地放进 'many'。
+-}
+stringChar :: Parser Char
+stringChar =
+    choice
+        [ '\'' <$ try (string "''")
+        , satisfy (/= '\'')
+        ]
+
+-- | 解析 ASC/DESC
+sortDir :: Parser SortDir
+sortDir = (Desc <$ keyword "desc") <|> (Asc <$ keyword "asc") <|> pure Asc
+
+-- | 解析 LIMIT
+limitClause :: Parser Int
+limitClause = do
+    keyword "limit"
+    integer
+
+-- * 表达式层
+
+-- | 表达式入口，最低优先级。
+expr :: Parser Expr
+expr = makeExprParser atom operatorTable
+
+{- | 运算符表。注意 'makeExprParser' 要求各层 **按优先级从高到低** 排列：
+比较运算符绑定最紧，'AND' 次之，'OR' 最松。
+-}
+operatorTable :: [[Operator Parser Expr]]
+operatorTable =
+    [
+        [ InfixN (Gt <$ symbol ">") -- 最高优先级
+        , InfixN (Lt <$ symbol "<")
+        , InfixN (Eq <$ symbol "=")
+        ]
+    , [InfixL (And <$ keyword "AND")]
+    , [InfixL (Or <$ keyword "OR")] -- 最低优先级
+    ]
+
+-- | 原子表达式：字面量、列引用或括号表达式。
+atom :: Parser Expr
+atom =
+    choice
+        [ LitInt <$> integer
+        , LitStr <$> stringLit
+        , Col <$> identifier
+        , between (symbol "(") (symbol ")") expr
+        ]
+
+-- * 语句层
+
+-- | 显式指定排序的语句
+orderItem :: Parser (String, SortDir)
+orderItem = do
+    col <- identifier
+    dir <- sortDir
+    return (col, dir)
+
+orderByClause :: Parser [(String, SortDir)]
+orderByClause = do
+    keyword "order"
+    keyword "by"
+    sepBy1 orderItem (symbol ",")
+
+assignment :: Parser (String, Expr)
+assignment = do
+    col <- identifier
+    _ <- symbol "="
+    e <- expr
+    return (col, e)
+
+-- | 选择列表：@*@ 或逗号分隔的列名。
+selectList :: Parser [String]
+selectList =
+    choice
+        [ ["*"] <$ symbol "*"
+        , (:) <$> identifier <*> many (symbol "," *> identifier)
+        ]
+
+-- | @SELECT ... FROM ... [WHERE ...]@。
+selectQuery :: Parser Query
+selectQuery = do
+    _ <- keyword "select"
+    cols <- selectList
+    _ <- keyword "from"
+    tableName <- identifier
+    mWhere <- optional (keyword "where" *> expr)
+    orderBy <- fromMaybe [] <$> optional orderByClause
+    mLimit <- optional limitClause
+    return
+        Select
+            { selectCols = cols
+            , selectTable = tableName
+            , selectWhere = mWhere
+            , selectOrderBy = orderBy
+            , selectLimit = mLimit
+            }
+
+-- | @INSERT ... INTO ... VALUES ...@。
+insertQuery :: Parser Query
+insertQuery = do
+    keyword "INSERT"
+    keyword "INTO"
+    tbl <- identifier
+    cols <-
+        between
+            (symbol "(")
+            (symbol ")")
+            (sepBy1 identifier (symbol ","))
+    keyword "VALUES"
+    vals <-
+        between
+            (symbol "(")
+            (symbol ")")
+            (sepBy1 atom (symbol ","))
+    return (Insert tbl cols vals)
+
+-- | @DELETE ... FROM ... [WHERE ...]@。
+deleteQuery :: Parser Query
+deleteQuery = do
+    keyword "DELETE"
+    keyword "FROM"
+    tbl <- identifier
+    mWhere <- optional (keyword "WHERE" *> expr)
+    return (Delete tbl mWhere)
+
+-- | UPDATE ... SET col = val, ... [WHERE ...]@
+updateQuery :: Parser Query
+updateQuery = do
+    keyword "update"
+    tbl <- identifier
+    keyword "set"
+    assigns <- sepBy1 assignment (symbol ",")
+    mWhere <- optional (keyword "where" *> expr)
+    return (Update tbl assigns mWhere)
+
+-- | 解析一条完整的语句；失败时返回可直接展示的错误信息。
+parseQuery :: String -> Either String Query
+parseQuery input =
+    case runParser (sc *> (selectQuery <|> insertQuery <|> deleteQuery <|> updateQuery) <* sc <* eof) "<query>" input of
+        Left err -> Left (errorBundlePretty err)
+        Right q -> Right q