starlitcanopy/simple-sql-parser
1
Fork 0
Code Activity

hlint pass

Browse source
This commit is contained in:
Jake Wheat 2024-01-11 15:34:07 +00:00
parent 858c7723b0
commit fe6b71fa2a
3 changed files with 52 additions and 53 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
Language/SQL/SimpleSQL/Lex.hs
View file

@ -71,7 +71,6 @@ try again to add annotation to the ast
-} -}
-- | Lexer for SQL. -- | Lexer for SQL.
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
@ -150,6 +149,7 @@ import Data.Char
import Control.Monad (void, guard) import Control.Monad (void, guard)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe (fromMaybe)
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
@ -223,13 +223,13 @@ lexSQL
-- ^ the SQL source to lex -- ^ the SQL source to lex
-> Either ParseError [Token] -> Either ParseError [Token]
lexSQL dialect fn p src = lexSQL dialect fn p src =
fmap (map tokenVal) $ lexSQLWithPositions dialect fn p src map tokenVal <$> lexSQLWithPositions dialect fn p src
myParse :: Text -> (Maybe (Int,Int)) -> Parser a -> Text -> Either ParseError a myParse :: Text -> Maybe (Int,Int) -> Parser a -> Text -> Either ParseError a
myParse name sp' p s = myParse name sp' p s =
let sp = maybe (1,1) id sp' let sp = fromMaybe (1,1) sp'
ps = SourcePos (T.unpack name) (mkPos $ fst sp) (mkPos $ snd sp) ps = SourcePos (T.unpack name) (mkPos $ fst sp) (mkPos $ snd sp)
is = (initialState (T.unpack name) s) is = initialState (T.unpack name) s
sps = (statePosState is) {pstateSourcePos = ps} sps = (statePosState is) {pstateSourcePos = ps}
is' = is {statePosState = sps} is' = is {statePosState = sps}
in snd $ runParser' p is' in snd $ runParser' p is'
@ -352,7 +352,7 @@ sqlString d = dollarString <|> csString <|> normalString
<$> try cs <$> try cs
<*> pure "'" <*> pure "'"
<*> normalStringSuffix False "" <*> normalStringSuffix False ""
csPrefixes = (map (flip T.cons "'") "nNbBxX") ++ ["u&'", "U&'"] csPrefixes = map (`T.cons` "'") "nNbBxX" ++ ["u&'", "U&'"]
cs :: Parser Text cs :: Parser Text
cs = choice $ map string csPrefixes cs = choice $ map string csPrefixes
@ -387,7 +387,7 @@ identifier d =
-- try is used here to avoid a conflict with identifiers -- try is used here to avoid a conflict with identifiers
-- and quoted strings which also start with a 'u' -- and quoted strings which also start with a 'u'
unicodeQuotedIden = Identifier unicodeQuotedIden = Identifier
<$> (f <$> try ((oneOf "uU") <* string "&")) <$> (f <$> try (oneOf "uU" <* string "&"))
<*> qidenPart <*> qidenPart
where f x = Just (T.cons x "&\"", "\"") where f x = Just (T.cons x "&\"", "\"")
qidenPart = char '"' *> qidenSuffix "" qidenPart = char '"' *> qidenSuffix ""
@ -404,7 +404,7 @@ identifierString :: Parser Text
identifierString = (do identifierString = (do
c <- satisfy isFirstLetter c <- satisfy isFirstLetter
choice choice
[T.cons c <$> (takeWhileP (Just "identifier char") isIdentifierChar) [T.cons c <$> takeWhileP (Just "identifier char") isIdentifierChar
,pure $ T.singleton c]) <?> "identifier" ,pure $ T.singleton c]) <?> "identifier"
where where
isFirstLetter c = c == '_' || isAlpha c isFirstLetter c = c == '_' || isAlpha c
@ -486,7 +486,7 @@ sqlNumber d =
-- this is for definitely avoiding possibly ambiguous source -- this is for definitely avoiding possibly ambiguous source
<* choice [-- special case to allow e.g. 1..2 <* choice [-- special case to allow e.g. 1..2
guard (diPostgresSymbols d) guard (diPostgresSymbols d)
*> (void $ lookAhead $ try $ (string ".." <?> "")) *> void (lookAhead $ try (string ".." <?> ""))
<|> void (notFollowedBy (oneOf "eE.")) <|> void (notFollowedBy (oneOf "eE."))
,notFollowedBy (oneOf "eE.") ,notFollowedBy (oneOf "eE.")
] ]
@ -737,7 +737,7 @@ two symbols next to eachother will fail if the symbols can combine and
| diPostgresSymbols d | diPostgresSymbols d
, Symbol a' <- a , Symbol a' <- a
, Symbol b' <- b , Symbol b' <- b
, b' `notElem` ["+", "-"] || or (map (`T.elem` a') "~!@#%^&|`?") = False , b' `notElem` ["+", "-"] || any (`T.elem` a') ("~!@#%^&|`?" :: [Char]) = False
{- {-
check two adjacent symbols in non postgres where the combination check two adjacent symbols in non postgres where the combination

60
Language/SQL/SimpleSQL/Parse.hs
View file

@ -217,6 +217,7 @@ import Control.Monad.Reader
(Reader (Reader
,runReader ,runReader
,ask ,ask
,asks
) )
import qualified Data.Set as Set import qualified Data.Set as Set
@ -227,7 +228,7 @@ import Control.Applicative ((<**>))
import Data.Char (isDigit) import Data.Char (isDigit)
import Data.List (sort,groupBy) import Data.List (sort,groupBy)
import Data.Function (on) import Data.Function (on)
import Data.Maybe (catMaybes, isJust) import Data.Maybe (catMaybes, isJust, mapMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@ -379,7 +380,7 @@ u&"example quoted"
name :: Parser Name name :: Parser Name
name = do name = do
bl <- queryDialect diKeywords bl <- askDialect diKeywords
uncurry Name <$> identifierTok bl uncurry Name <$> identifierTok bl
-- todo: replace (:[]) with a named function all over -- todo: replace (:[]) with a named function all over
@ -561,7 +562,7 @@ typeName =
-- type names, plus all the type names which are -- type names, plus all the type names which are
-- reserved words -- reserved words
reservedTypeNames = do reservedTypeNames = do
stn <- queryDialect diSpecialTypeNames stn <- askDialect diSpecialTypeNames
(:[]) . Name Nothing . T.unwords <$> makeKeywordTree stn (:[]) . Name Nothing . T.unwords <$> makeKeywordTree stn
@ -771,7 +772,7 @@ idenExpr =
-- special cases for keywords that can be parsed as an iden or app -- special cases for keywords that can be parsed as an iden or app
keywordFunctionOrIden = try $ do keywordFunctionOrIden = try $ do
x <- unquotedIdentifierTok [] Nothing x <- unquotedIdentifierTok [] Nothing
d <- queryDialect id d <- askDialect id
let i = T.toLower x `elem` diIdentifierKeywords d let i = T.toLower x `elem` diIdentifierKeywords d
a = T.toLower x `elem` diAppKeywords d a = T.toLower x `elem` diAppKeywords d
case () of case () of
@ -923,7 +924,7 @@ app =
openParen *> choice openParen *> choice
[duplicates [duplicates
<**> (commaSep1 scalarExpr <**> (commaSep1 scalarExpr
<**> (((option [] orderBy) <* closeParen) <**> ((option [] orderBy <* closeParen)
<**> (optional afilter <$$$$$> AggregateApp))) <**> (optional afilter <$$$$$> AggregateApp)))
-- separate cases with no all or distinct which must have at -- separate cases with no all or distinct which must have at
-- least one scalar expr -- least one scalar expr
@ -967,17 +968,17 @@ window :: Parser ([ScalarExpr] -> [Name] -> ScalarExpr)
window = window =
keyword_ "over" *> openParen *> option [] partitionBy keyword_ "over" *> openParen *> option [] partitionBy
<**> (option [] orderBy <**> (option [] orderBy
<**> (((optional frameClause) <* closeParen) <$$$$$> WindowApp)) <**> ((optional frameClause <* closeParen) <$$$$$> WindowApp))
where where
partitionBy = keywords_ ["partition","by"] *> commaSep1 scalarExpr partitionBy = keywords_ ["partition","by"] *> commaSep1 scalarExpr
frameClause = frameClause =
frameRowsRange -- TODO: this 'and' could be an issue frameRowsRange -- TODO: this 'and' could be an issue
<**> (choice [(keyword_ "between" *> frameLimit True) <**> choice [(keyword_ "between" *> frameLimit True)
<**> ((keyword_ "and" *> frameLimit True) <**> ((keyword_ "and" *> frameLimit True)
<$$$> FrameBetween) <$$$> FrameBetween)
-- maybe this should still use a b expression -- maybe this should still use a b expression
-- for consistency -- for consistency
,frameLimit False <**> pure (flip FrameFrom)]) ,frameLimit False <**> pure (flip FrameFrom)]
frameRowsRange = FrameRows <$ keyword_ "rows" frameRowsRange = FrameRows <$ keyword_ "rows"
<|> FrameRange <$ keyword_ "range" <|> FrameRange <$ keyword_ "range"
frameLimit useB = frameLimit useB =
@ -1013,7 +1014,7 @@ inSuffix =
where where
inty = choice [True <$ keyword_ "in" inty = choice [True <$ keyword_ "in"
,False <$ keywords_ ["not","in"]] ,False <$ keywords_ ["not","in"]]
mkIn i v = \e -> In i e v mkIn i v e = In i e v
{- {-
=== between === between
@ -1034,14 +1035,15 @@ and operator. This is the call to scalarExprB.
betweenSuffix :: Parser (ScalarExpr -> ScalarExpr) betweenSuffix :: Parser (ScalarExpr -> ScalarExpr)
betweenSuffix = betweenSuffix =
makeOp <$> Name Nothing <$> opName makeOp . Name Nothing
<$> opName
<*> scalarExprB <*> scalarExprB
<*> (keyword_ "and" *> scalarExprB) <*> (keyword_ "and" *> scalarExprB)
where where
opName = choice opName = choice
["between" <$ keyword_ "between" ["between" <$ keyword_ "between"
,"not between" <$ try (keywords_ ["not","between"])] ,"not between" <$ try (keywords_ ["not","between"])]
makeOp n b c = \a -> SpecialOp [n] [a,b,c] makeOp n b c a = SpecialOp [n] [a,b,c]
{- {-
=== quantified comparison === quantified comparison
@ -1224,7 +1226,7 @@ opTable bExpr =
,[prefixKeyword "not"] ,[prefixKeyword "not"]
,if bExpr then [] else [binaryKeywordL "and"] ,[binaryKeywordL "and" | not bExpr]
,[binaryKeywordL "or"] ,[binaryKeywordL "or"]
@ -1368,7 +1370,7 @@ from = keyword_ "from" *> commaSep1 tref
where where
-- TODO: use P (a->) for the join tref suffix -- TODO: use P (a->) for the join tref suffix
-- chainl or buildexpressionparser -- chainl or buildexpressionparser
tref = (nonJoinTref <?> "table ref") >>= optionSuffix (joinTrefSuffix) tref = (nonJoinTref <?> "table ref") >>= optionSuffix joinTrefSuffix
nonJoinTref = choice nonJoinTref = choice
[parens $ choice [parens $ choice
[TRQueryExpr <$> queryExpr [TRQueryExpr <$> queryExpr
@ -1519,7 +1521,7 @@ queryExpr = E.makeExprParser qeterm qeOpTable
mkSelect mkSelect
<$> option SQDefault duplicates <$> option SQDefault duplicates
<*> selectList <*> selectList
<*> (optional tableExpression) <?> "table expression" <*> optional tableExpression <?> "table expression"
mkSelect d sl Nothing = mkSelect d sl Nothing =
toQueryExpr $ makeSelect {msSetQuantifier = d, msSelectList = sl} toQueryExpr $ makeSelect {msSetQuantifier = d, msSelectList = sl}
mkSelect d sl (Just (TableExpression f w g h od ofs fe)) = mkSelect d sl (Just (TableExpression f w g h od ofs fe)) =
@ -1621,7 +1623,7 @@ statementWithoutSemicolon = choice
] ]
statement :: Parser Statement statement :: Parser Statement
statement = statementWithoutSemicolon <* optional semi <|> semi *> pure EmptyStatement statement = statementWithoutSemicolon <* optional semi <|> EmptyStatement <$ semi
createSchema :: Parser Statement createSchema :: Parser Statement
createSchema = keyword_ "schema" >> createSchema = keyword_ "schema" >>
@ -1629,7 +1631,7 @@ createSchema = keyword_ "schema" >>
createTable :: Parser Statement createTable :: Parser Statement
createTable = do createTable = do
d <- queryDialect id d <- askDialect id
let let
parseColumnDef = TableColumnDef <$> columnDef parseColumnDef = TableColumnDef <$> columnDef
parseConstraintDef = uncurry TableConstraintDef <$> tableConstraintDef parseConstraintDef = uncurry TableConstraintDef <$> tableConstraintDef
@ -1675,7 +1677,7 @@ columnDef = ColumnDef <$> name <*> typeName
tableConstraintDef :: Parser (Maybe [Name], TableConstraint) tableConstraintDef :: Parser (Maybe [Name], TableConstraint)
tableConstraintDef = tableConstraintDef =
(,) (,)
<$> (optional (keyword_ "constraint" *> names)) <$> optional (keyword_ "constraint" *> names)
<*> (unique <|> primaryKey <|> check <|> references) <*> (unique <|> primaryKey <|> check <|> references)
where where
unique = keyword_ "unique" >> unique = keyword_ "unique" >>
@ -1725,7 +1727,7 @@ colConstraintDef =
unique = ColUniqueConstraint <$ keyword_ "unique" unique = ColUniqueConstraint <$ keyword_ "unique"
primaryKey = do primaryKey = do
keywords_ ["primary", "key"] keywords_ ["primary", "key"]
d <- queryDialect id d <- askDialect id
autoincrement <- if diAutoincrement d autoincrement <- if diAutoincrement d
then optional (keyword_ "autoincrement") then optional (keyword_ "autoincrement")
else pure Nothing else pure Nothing
@ -2099,9 +2101,9 @@ makeKeywordTree sets =
parseGroup :: [[Text]] -> Parser [Text] parseGroup :: [[Text]] -> Parser [Text]
parseGroup l@((k:_):_) = do parseGroup l@((k:_):_) = do
keyword_ k keyword_ k
let tls = catMaybes $ map safeTail l let tls = mapMaybe safeTail l
pr = (k:) <$> parseTrees tls pr = (k:) <$> parseTrees tls
if (or $ map null tls) if any null tls
then pr <|> pure [k] then pr <|> pure [k]
else pr else pr
parseGroup _ = guard False >> fail "impossible" parseGroup _ = guard False >> fail "impossible"
@ -2175,7 +2177,7 @@ unsignedInteger = read . T.unpack <$> sqlNumberTok True <?> "natural number"
-- todo: work out the symbol parsing better -- todo: work out the symbol parsing better
symbol :: Text -> Parser Text symbol :: Text -> Parser Text
symbol s = symbolTok (Just s) <?> (T.unpack s) symbol s = symbolTok (Just s) <?> T.unpack s
singleCharSymbol :: Char -> Parser Char singleCharSymbol :: Char -> Parser Char
singleCharSymbol c = c <$ symbol (T.singleton c) singleCharSymbol c = c <$ symbol (T.singleton c)
@ -2205,12 +2207,12 @@ semi = singleCharSymbol ';' <?> ""
-- = helper functions -- = helper functions
keyword :: Text -> Parser Text keyword :: Text -> Parser Text
keyword k = unquotedIdentifierTok [] (Just k) <?> (T.unpack k) keyword k = unquotedIdentifierTok [] (Just k) <?> T.unpack k
-- helper function to improve error messages -- helper function to improve error messages
keywords_ :: [Text] -> Parser () keywords_ :: [Text] -> Parser ()
keywords_ ks = mapM_ keyword_ ks <?> (T.unpack (T.unwords ks)) keywords_ ks = mapM_ keyword_ ks <?> T.unpack (T.unwords ks)
parens :: Parser a -> Parser a parens :: Parser a -> Parser a
@ -2270,7 +2272,7 @@ stringTokExtend = do
guard (s == "'" && e == "'") guard (s == "'" && e == "'")
(s',e',y) <- stringTokExtend (s',e',y) <- stringTokExtend
guard (s' == "'" && e' == "'") guard (s' == "'" && e' == "'")
pure $ (s,e,x <> y) pure (s,e,x <> y)
,pure (s,e,x) ,pure (s,e,x)
] ]
@ -2361,12 +2363,8 @@ unquotedIdentifierTok blackList kw = token test Set.empty <?> ""
-- dialect -- dialect
guardDialect :: (Dialect -> Bool) -> Parser () guardDialect :: (Dialect -> Bool) -> Parser ()
guardDialect p = do guardDialect p = guard . p =<< ask
d <- ask
guard (p d)
queryDialect :: (Dialect -> a) -> Parser a askDialect :: (Dialect -> a) -> Parser a
queryDialect f = do askDialect = asks
d <- ask
pure $ f d

19
Language/SQL/SimpleSQL/Pretty.hs
View file

@ -3,6 +3,7 @@
-- source from ASTs. The code attempts to format the output in a -- source from ASTs. The code attempts to format the output in a
-- readable way. -- readable way.
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Language.SQL.SimpleSQL.Pretty module Language.SQL.SimpleSQL.Pretty
(prettyQueryExpr (prettyQueryExpr
,prettyScalarExpr ,prettyScalarExpr
@ -120,7 +121,7 @@ scalarExpr d (WindowApp f es pb od fr) =
<+> pretty "over" <+> pretty "over"
<+> parens ((case pb of <+> parens ((case pb of
[] -> mempty [] -> mempty
_ -> (pretty "partition by") <+> align _ -> pretty "partition by" <+> align
(commaSep $ map (scalarExpr d) pb)) (commaSep $ map (scalarExpr d) pb))
<+> orderBy d od <+> orderBy d od
<+> me frd fr) <+> me frd fr)
@ -142,7 +143,7 @@ scalarExpr dia (SpecialOp nm [a,b,c])
| nm `elem` [[Name Nothing "between"] | nm `elem` [[Name Nothing "between"]
,[Name Nothing "not between"]] = ,[Name Nothing "not between"]] =
sep [scalarExpr dia a sep [scalarExpr dia a
,names nm <+> nest ((T.length (unnames nm) - 3)) (sep ,names nm <+> nest (T.length (unnames nm) - 3) (sep
[scalarExpr dia b [scalarExpr dia b
,pretty "and" <+> scalarExpr dia c])] ,pretty "and" <+> scalarExpr dia c])]
@ -206,7 +207,7 @@ scalarExpr d (SubQueryExpr ty qe) =
scalarExpr d (QuantifiedComparison v c cp sq) = scalarExpr d (QuantifiedComparison v c cp sq) =
scalarExpr d v scalarExpr d v
<+> names c <+> names c
<+> (pretty $ case cp of <+> pretty (case cp of
CPAny -> "any" CPAny -> "any"
CPSome -> "some" CPSome -> "some"
CPAll -> "all") CPAll -> "all")
@ -306,13 +307,13 @@ typeName (PrecScaleTypeName t a b) =
typeName (PrecLengthTypeName t i m u) = typeName (PrecLengthTypeName t i m u) =
names t names t
<> parens (pretty (show i) <> parens (pretty (show i)
<> me (\x -> case x of <> me (\case
PrecK -> pretty "K" PrecK -> pretty "K"
PrecM -> pretty "M" PrecM -> pretty "M"
PrecG -> pretty "G" PrecG -> pretty "G"
PrecT -> pretty "T" PrecT -> pretty "T"
PrecP -> pretty "P") m PrecP -> pretty "P") m
<+> me (\x -> case x of <+> me (\case
PrecCharacters -> pretty "CHARACTERS" PrecCharacters -> pretty "CHARACTERS"
PrecOctets -> pretty "OCTETS") u) PrecOctets -> pretty "OCTETS") u)
typeName (CharTypeName t i cs col) = typeName (CharTypeName t i cs col) =
@ -350,7 +351,7 @@ intervalTypeField (Itf n p) =
pretty n pretty n
<+> me (\(x,x1) -> <+> me (\(x,x1) ->
parens (pretty (show x) parens (pretty (show x)
<+> me (\y -> (sep [comma,pretty (show y)])) x1)) p <+> me (\y -> sep [comma,pretty (show y)]) x1)) p
-- = query expressions -- = query expressions
@ -524,7 +525,7 @@ statement d (AlterDomain nm act) =
<+> a act <+> a act
where where
a (ADSetDefault v) = texts ["set","default"] <+> scalarExpr d v a (ADSetDefault v) = texts ["set","default"] <+> scalarExpr d v
a (ADDropDefault) = texts ["drop","default"] a ADDropDefault = texts ["drop","default"]
a (ADAddConstraint cnm e) = a (ADAddConstraint cnm e) =
pretty "add" pretty "add"
<+> maybe mempty (\cnm' -> pretty "constraint" <+> names cnm') cnm <+> maybe mempty (\cnm' -> pretty "constraint" <+> names cnm') cnm
@ -603,7 +604,7 @@ statement _ (DropTable n b) =
statement d (CreateView r nm al q co) = statement d (CreateView r nm al q co) =
pretty "create" <+> (if r then pretty "recursive" else mempty) pretty "create" <+> (if r then pretty "recursive" else mempty)
<+> pretty "view" <+> names nm <+> pretty "view" <+> names nm
<+> (maybe mempty (\al' -> parens $ commaSep $ map name al')) al <+> maybe mempty (parens . commaSep . map name) al
<+> pretty "as" <+> pretty "as"
<+> queryExpr d q <+> queryExpr d q
<+> case co of <+> case co of
@ -731,7 +732,7 @@ columnDef d (ColumnDef n t mdef cons) =
pcon (ColReferencesConstraint tb c m u del) = pcon (ColReferencesConstraint tb c m u del) =
pretty "references" pretty "references"
<+> names tb <+> names tb
<+> maybe mempty (\c' -> parens (name c')) c <+> maybe mempty (parens . name) c
<+> refMatch m <+> refMatch m
<+> refAct "update" u <+> refAct "update" u
<+> refAct "delete" del <+> refAct "delete" del