diff --git a/Language/SQL/SimpleSQL/Lex.hs b/Language/SQL/SimpleSQL/Lex.hs index 395317f..e238f78 100644 --- a/Language/SQL/SimpleSQL/Lex.hs +++ b/Language/SQL/SimpleSQL/Lex.hs @@ -71,7 +71,6 @@ try again to add annotation to the ast -} -- | Lexer for SQL. -{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -150,6 +149,7 @@ import Data.Char import Control.Monad (void, guard) import Data.Text (Text) import qualified Data.Text as T +import Data.Maybe (fromMaybe) ------------------------------------------------------------------------------ @@ -223,13 +223,13 @@ lexSQL -- ^ the SQL source to lex -> Either ParseError [Token] 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 = - let sp = maybe (1,1) id sp' + let sp = fromMaybe (1,1) 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} is' = is {statePosState = sps} in snd $ runParser' p is' @@ -352,7 +352,7 @@ sqlString d = dollarString <|> csString <|> normalString <$> try cs <*> pure "'" <*> normalStringSuffix False "" - csPrefixes = (map (flip T.cons "'") "nNbBxX") ++ ["u&'", "U&'"] + csPrefixes = map (`T.cons` "'") "nNbBxX" ++ ["u&'", "U&'"] cs :: Parser Text cs = choice $ map string csPrefixes @@ -387,7 +387,7 @@ identifier d = -- try is used here to avoid a conflict with identifiers -- and quoted strings which also start with a 'u' unicodeQuotedIden = Identifier - <$> (f <$> try ((oneOf "uU") <* string "&")) + <$> (f <$> try (oneOf "uU" <* string "&")) <*> qidenPart where f x = Just (T.cons x "&\"", "\"") qidenPart = char '"' *> qidenSuffix "" @@ -404,7 +404,7 @@ identifierString :: Parser Text identifierString = (do c <- satisfy isFirstLetter choice - [T.cons c <$> (takeWhileP (Just "identifier char") isIdentifierChar) + [T.cons c <$> takeWhileP (Just "identifier char") isIdentifierChar ,pure $ T.singleton c]) "identifier" where isFirstLetter c = c == '_' || isAlpha c @@ -486,7 +486,7 @@ sqlNumber d = -- this is for definitely avoiding possibly ambiguous source <* choice [-- special case to allow e.g. 1..2 guard (diPostgresSymbols d) - *> (void $ lookAhead $ try $ (string ".." "")) + *> void (lookAhead $ try (string ".." "")) <|> void (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 , Symbol a' <- a , 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 diff --git a/Language/SQL/SimpleSQL/Parse.hs b/Language/SQL/SimpleSQL/Parse.hs index ed19dc6..b568e86 100644 --- a/Language/SQL/SimpleSQL/Parse.hs +++ b/Language/SQL/SimpleSQL/Parse.hs @@ -217,6 +217,7 @@ import Control.Monad.Reader (Reader ,runReader ,ask + ,asks ) import qualified Data.Set as Set @@ -227,7 +228,7 @@ import Control.Applicative ((<**>)) import Data.Char (isDigit) import Data.List (sort,groupBy) import Data.Function (on) -import Data.Maybe (catMaybes, isJust) +import Data.Maybe (catMaybes, isJust, mapMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -379,7 +380,7 @@ u&"example quoted" name :: Parser Name name = do - bl <- queryDialect diKeywords + bl <- askDialect diKeywords uncurry Name <$> identifierTok bl -- todo: replace (:[]) with a named function all over @@ -561,7 +562,7 @@ typeName = -- type names, plus all the type names which are -- reserved words reservedTypeNames = do - stn <- queryDialect diSpecialTypeNames + stn <- askDialect diSpecialTypeNames (:[]) . Name Nothing . T.unwords <$> makeKeywordTree stn @@ -771,7 +772,7 @@ idenExpr = -- special cases for keywords that can be parsed as an iden or app keywordFunctionOrIden = try $ do x <- unquotedIdentifierTok [] Nothing - d <- queryDialect id + d <- askDialect id let i = T.toLower x `elem` diIdentifierKeywords d a = T.toLower x `elem` diAppKeywords d case () of @@ -923,7 +924,7 @@ app = openParen *> choice [duplicates <**> (commaSep1 scalarExpr - <**> (((option [] orderBy) <* closeParen) + <**> ((option [] orderBy <* closeParen) <**> (optional afilter <$$$$$> AggregateApp))) -- separate cases with no all or distinct which must have at -- least one scalar expr @@ -967,17 +968,17 @@ window :: Parser ([ScalarExpr] -> [Name] -> ScalarExpr) window = keyword_ "over" *> openParen *> option [] partitionBy <**> (option [] orderBy - <**> (((optional frameClause) <* closeParen) <$$$$$> WindowApp)) + <**> ((optional frameClause <* closeParen) <$$$$$> WindowApp)) where partitionBy = keywords_ ["partition","by"] *> commaSep1 scalarExpr frameClause = frameRowsRange -- TODO: this 'and' could be an issue - <**> (choice [(keyword_ "between" *> frameLimit True) + <**> choice [(keyword_ "between" *> frameLimit True) <**> ((keyword_ "and" *> frameLimit True) <$$$> FrameBetween) -- maybe this should still use a b expression -- for consistency - ,frameLimit False <**> pure (flip FrameFrom)]) + ,frameLimit False <**> pure (flip FrameFrom)] frameRowsRange = FrameRows <$ keyword_ "rows" <|> FrameRange <$ keyword_ "range" frameLimit useB = @@ -1013,7 +1014,7 @@ inSuffix = where inty = choice [True <$ keyword_ "in" ,False <$ keywords_ ["not","in"]] - mkIn i v = \e -> In i e v + mkIn i v e = In i e v {- === between @@ -1034,14 +1035,15 @@ and operator. This is the call to scalarExprB. betweenSuffix :: Parser (ScalarExpr -> ScalarExpr) betweenSuffix = - makeOp <$> Name Nothing <$> opName + makeOp . Name Nothing + <$> opName <*> scalarExprB <*> (keyword_ "and" *> scalarExprB) where opName = choice ["between" <$ keyword_ "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 @@ -1224,7 +1226,7 @@ opTable bExpr = ,[prefixKeyword "not"] - ,if bExpr then [] else [binaryKeywordL "and"] + ,[binaryKeywordL "and" | not bExpr] ,[binaryKeywordL "or"] @@ -1368,7 +1370,7 @@ from = keyword_ "from" *> commaSep1 tref where -- TODO: use P (a->) for the join tref suffix -- chainl or buildexpressionparser - tref = (nonJoinTref "table ref") >>= optionSuffix (joinTrefSuffix) + tref = (nonJoinTref "table ref") >>= optionSuffix joinTrefSuffix nonJoinTref = choice [parens $ choice [TRQueryExpr <$> queryExpr @@ -1519,7 +1521,7 @@ queryExpr = E.makeExprParser qeterm qeOpTable mkSelect <$> option SQDefault duplicates <*> selectList - <*> (optional tableExpression) "table expression" + <*> optional tableExpression "table expression" mkSelect d sl Nothing = toQueryExpr $ makeSelect {msSetQuantifier = d, msSelectList = sl} mkSelect d sl (Just (TableExpression f w g h od ofs fe)) = @@ -1621,7 +1623,7 @@ statementWithoutSemicolon = choice ] statement :: Parser Statement -statement = statementWithoutSemicolon <* optional semi <|> semi *> pure EmptyStatement +statement = statementWithoutSemicolon <* optional semi <|> EmptyStatement <$ semi createSchema :: Parser Statement createSchema = keyword_ "schema" >> @@ -1629,7 +1631,7 @@ createSchema = keyword_ "schema" >> createTable :: Parser Statement createTable = do - d <- queryDialect id + d <- askDialect id let parseColumnDef = TableColumnDef <$> columnDef parseConstraintDef = uncurry TableConstraintDef <$> tableConstraintDef @@ -1675,7 +1677,7 @@ columnDef = ColumnDef <$> name <*> typeName tableConstraintDef :: Parser (Maybe [Name], TableConstraint) tableConstraintDef = (,) - <$> (optional (keyword_ "constraint" *> names)) + <$> optional (keyword_ "constraint" *> names) <*> (unique <|> primaryKey <|> check <|> references) where unique = keyword_ "unique" >> @@ -1725,7 +1727,7 @@ colConstraintDef = unique = ColUniqueConstraint <$ keyword_ "unique" primaryKey = do keywords_ ["primary", "key"] - d <- queryDialect id + d <- askDialect id autoincrement <- if diAutoincrement d then optional (keyword_ "autoincrement") else pure Nothing @@ -2099,9 +2101,9 @@ makeKeywordTree sets = parseGroup :: [[Text]] -> Parser [Text] parseGroup l@((k:_):_) = do keyword_ k - let tls = catMaybes $ map safeTail l + let tls = mapMaybe safeTail l pr = (k:) <$> parseTrees tls - if (or $ map null tls) + if any null tls then pr <|> pure [k] else pr parseGroup _ = guard False >> fail "impossible" @@ -2175,7 +2177,7 @@ unsignedInteger = read . T.unpack <$> sqlNumberTok True "natural number" -- todo: work out the symbol parsing better 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 c = c <$ symbol (T.singleton c) @@ -2205,12 +2207,12 @@ semi = singleCharSymbol ';' "" -- = helper functions 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 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 @@ -2270,7 +2272,7 @@ stringTokExtend = do guard (s == "'" && e == "'") (s',e',y) <- stringTokExtend guard (s' == "'" && e' == "'") - pure $ (s,e,x <> y) + pure (s,e,x <> y) ,pure (s,e,x) ] @@ -2361,12 +2363,8 @@ unquotedIdentifierTok blackList kw = token test Set.empty "" -- dialect guardDialect :: (Dialect -> Bool) -> Parser () -guardDialect p = do - d <- ask - guard (p d) +guardDialect p = guard . p =<< ask -queryDialect :: (Dialect -> a) -> Parser a -queryDialect f = do - d <- ask - pure $ f d +askDialect :: (Dialect -> a) -> Parser a +askDialect = asks diff --git a/Language/SQL/SimpleSQL/Pretty.hs b/Language/SQL/SimpleSQL/Pretty.hs index 63c3f34..556a078 100644 --- a/Language/SQL/SimpleSQL/Pretty.hs +++ b/Language/SQL/SimpleSQL/Pretty.hs @@ -3,6 +3,7 @@ -- source from ASTs. The code attempts to format the output in a -- readable way. {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module Language.SQL.SimpleSQL.Pretty (prettyQueryExpr ,prettyScalarExpr @@ -120,7 +121,7 @@ scalarExpr d (WindowApp f es pb od fr) = <+> pretty "over" <+> parens ((case pb of [] -> mempty - _ -> (pretty "partition by") <+> align + _ -> pretty "partition by" <+> align (commaSep $ map (scalarExpr d) pb)) <+> orderBy d od <+> me frd fr) @@ -142,7 +143,7 @@ scalarExpr dia (SpecialOp nm [a,b,c]) | nm `elem` [[Name Nothing "between"] ,[Name Nothing "not between"]] = 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 ,pretty "and" <+> scalarExpr dia c])] @@ -206,10 +207,10 @@ scalarExpr d (SubQueryExpr ty qe) = scalarExpr d (QuantifiedComparison v c cp sq) = scalarExpr d v <+> names c - <+> (pretty $ case cp of - CPAny -> "any" - CPSome -> "some" - CPAll -> "all") + <+> pretty (case cp of + CPAny -> "any" + CPSome -> "some" + CPAll -> "all") <+> parens (queryExpr d sq) scalarExpr d (Match v u sq) = @@ -306,13 +307,13 @@ typeName (PrecScaleTypeName t a b) = typeName (PrecLengthTypeName t i m u) = names t <> parens (pretty (show i) - <> me (\x -> case x of + <> me (\case PrecK -> pretty "K" PrecM -> pretty "M" PrecG -> pretty "G" PrecT -> pretty "T" PrecP -> pretty "P") m - <+> me (\x -> case x of + <+> me (\case PrecCharacters -> pretty "CHARACTERS" PrecOctets -> pretty "OCTETS") u) typeName (CharTypeName t i cs col) = @@ -350,7 +351,7 @@ intervalTypeField (Itf n p) = pretty n <+> me (\(x,x1) -> parens (pretty (show x) - <+> me (\y -> (sep [comma,pretty (show y)])) x1)) p + <+> me (\y -> sep [comma,pretty (show y)]) x1)) p -- = query expressions @@ -524,7 +525,7 @@ statement d (AlterDomain nm act) = <+> a act where a (ADSetDefault v) = texts ["set","default"] <+> scalarExpr d v - a (ADDropDefault) = texts ["drop","default"] + a ADDropDefault = texts ["drop","default"] a (ADAddConstraint cnm e) = pretty "add" <+> maybe mempty (\cnm' -> pretty "constraint" <+> names cnm') cnm @@ -603,7 +604,7 @@ statement _ (DropTable n b) = statement d (CreateView r nm al q co) = pretty "create" <+> (if r then pretty "recursive" else mempty) <+> pretty "view" <+> names nm - <+> (maybe mempty (\al' -> parens $ commaSep $ map name al')) al + <+> maybe mempty (parens . commaSep . map name) al <+> pretty "as" <+> queryExpr d q <+> case co of @@ -731,7 +732,7 @@ columnDef d (ColumnDef n t mdef cons) = pcon (ColReferencesConstraint tb c m u del) = pretty "references" <+> names tb - <+> maybe mempty (\c' -> parens (name c')) c + <+> maybe mempty (parens . name) c <+> refMatch m <+> refAct "update" u <+> refAct "delete" del