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