simple-sql-parser (empty) → 0.1.0.0
raw patch · 11 files changed
+2723/−0 lines, 11 filesdep +HUnitdep +basedep +haskell-src-extssetup-changed
Dependencies added: HUnit, base, haskell-src-exts, mtl, parsec, pretty, test-framework, test-framework-hunit
Files
- LICENSE +30/−0
- Language/SQL/SimpleSQL/Fixity.lhs +174/−0
- Language/SQL/SimpleSQL/Parser.lhs +793/−0
- Language/SQL/SimpleSQL/Pretty.lhs +233/−0
- Language/SQL/SimpleSQL/Syntax.lhs +210/−0
- README +5/−0
- Setup.hs +2/−0
- simple-sql-parser.cabal +59/−0
- tools/Language/SQL/SimpleSQL/Tests.lhs +534/−0
- tools/RunTests.lhs +8/−0
- tools/Tpch.lhs +675/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Jake Wheat++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jake Wheat nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Language/SQL/SimpleSQL/Fixity.lhs view
@@ -0,0 +1,174 @@++This is the module which deals with fixing up the scalar expression+trees for the operator precedence and associativity (aka 'fixity').++It currently uses haskell-src-exts as a hack, the algorithm from there+should be ported to work on these trees natively. Maybe it could be+made generic to use in places other than the scalar expr parser?++> {-# LANGUAGE TupleSections #-}+> module Language.SQL.SimpleSQL.Fixity+> (fixFixities+> ,Fixity(..)+> ,Assoc(..)+> ,infixl_+> ,infixr_+> ,infix_+> ) where++> import qualified Language.Haskell.Exts.Syntax as HSE+> import qualified Language.Haskell.Exts.Fixity as HSE+> import Control.Monad.Identity+> import Control.Applicative+> import Data.Maybe++> import Language.SQL.SimpleSQL.Syntax++> data Fixity = Fixity String --name of op+> Assoc+> deriving (Eq,Show)++> data Assoc = AssocLeft | AssocRight | AssocNone+> deriving (Eq,Show)++> infixl_ :: [String] -> [Fixity]+> infixl_ = map (`Fixity` AssocLeft)++> infixr_ :: [String] -> [Fixity]+> infixr_ = map (`Fixity` AssocRight)++> infix_ :: [String] -> [Fixity]+> infix_ = map (`Fixity` AssocNone)++> toHSEFixity :: [[Fixity]] -> [HSE.Fixity]+> toHSEFixity fs =+> let fs' = zip [0..] $ reverse fs+> in concatMap f fs'+> where+> f :: (Int, [Fixity]) -> [HSE.Fixity]+> f (n,fs') = flip concatMap fs' $ \(Fixity nm assoc) ->+> case assoc of+> AssocLeft -> HSE.infixl_ n [nm]+> AssocRight -> HSE.infixr_ n [nm]+> AssocNone -> HSE.infix_ n [nm]++fix the fixities in the given scalar expr. All the expressions to be+fixed should be left associative and equal precedence to be fixed+correctly. It doesn't descend into query expressions in subqueries and+the scalar expressions they contain.++TODO: get it to work on prefix and postfix unary operators also maybe+it should work on some of the other syntax (such as in).++> fixFixities :: [[Fixity]] -> ScalarExpr -> ScalarExpr+> fixFixities fs se =+> runIdentity $ toSql <$> HSE.applyFixities (toHSEFixity fs) (toHaskell se)++Now have to convert all our scalar exprs to haskell and back again.+Have to come up with a recipe for each ctor. Only continue if you have+a strong stomach. Probably would have been less effort to just write+the fixity code.++> toHaskell :: ScalarExpr -> HSE.Exp+> toHaskell e = case e of+> BinOp e0 op e1 -> HSE.InfixApp+> (toHaskell e0)+> (HSE.QVarOp $ sym op)+> (toHaskell e1)+> Iden {} -> str ('v':show e)+> StringLit {} -> str ('v':show e)+> NumLit {} -> str ('v':show e)+> App n es -> HSE.App (var ('f':n)) $ ltoh es+> Parens e0 -> HSE.Paren $ toHaskell e0+> IntervalLit {} -> str ('v':show e)+> Iden2 {} -> str ('v':show e)+> Star -> str ('v':show e)+> Star2 {} -> str ('v':show e)+> AggregateApp nm d es od ->+> HSE.App (var ('a':nm))+> $ HSE.List [str $ show (d,map snd od)+> ,HSE.List $ map toHaskell es+> ,HSE.List $ map (toHaskell . fst) od]+> WindowApp nm es pb od ->+> HSE.App (var ('w':nm))+> $ HSE.List [str $ show (map snd od)+> ,HSE.List $ map toHaskell es+> ,HSE.List $ map toHaskell pb+> ,HSE.List $ map (toHaskell . fst) od]+> PrefixOp nm e0 ->+> HSE.App (HSE.Var $ sym nm) (toHaskell e0)+> PostfixOp nm e0 ->+> HSE.App (HSE.Var $ sym ('p':nm)) (toHaskell e0)+> SpecialOp nm es ->+> HSE.App (var ('s':nm)) $ HSE.List $ map toHaskell es+> -- map the two maybes to lists with either 0 or 1 element+> Case v ts el -> HSE.App (var "$case")+> (HSE.List [ltoh $ maybeToList v+> ,HSE.List $ map (ltoh . (\(a,b) -> [a,b])) ts+> ,ltoh $ maybeToList el])+> Cast e0 tn -> HSE.App (str ('c':show tn)) $ toHaskell e0+> CastOp {} -> str ('v':show e)+> SubQueryExpr {} -> str ('v': show e)+> In b e0 (InList l) ->+> HSE.App (str ('i':show b))+> $ HSE.List [toHaskell e0, HSE.List $ map toHaskell l]+> In b e0 i -> HSE.App (str ('j':show (b,i))) $ toHaskell e0+> where+> ltoh = HSE.List . map toHaskell+> str = HSE.Lit . HSE.String+> var = HSE.Var . HSE.UnQual . HSE.Ident+> sym = HSE.UnQual . HSE.Symbol+++> toSql :: HSE.Exp -> ScalarExpr+> toSql e = case e of+++> HSE.InfixApp e0 (HSE.QVarOp (HSE.UnQual (HSE.Symbol n))) e1 ->+> BinOp (toSql e0) n (toSql e1)+> HSE.Lit (HSE.String ('v':l)) -> read l+> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('f':i))))+> (HSE.List es) -> App i $ map toSql es+> HSE.Paren e0 -> Parens $ toSql e0+> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('a':i))))+> (HSE.List [HSE.Lit (HSE.String vs)+> ,HSE.List es+> ,HSE.List od]) ->+> let (d,dir) = read vs+> in AggregateApp i d (map toSql es)+> $ zip (map toSql od) dir+> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('w':i))))+> (HSE.List [HSE.Lit (HSE.String vs)+> ,HSE.List es+> ,HSE.List pb+> ,HSE.List od]) ->+> let dir = read vs+> in WindowApp i (map toSql es)+> (map toSql pb)+> $ zip (map toSql od) dir+> HSE.App (HSE.Var (HSE.UnQual (HSE.Symbol ('p':nm)))) e0 ->+> PostfixOp nm $ toSql e0+> HSE.App (HSE.Var (HSE.UnQual (HSE.Symbol nm))) e0 ->+> PrefixOp nm $ toSql e0+> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('s':nm)))) (HSE.List es) ->+> SpecialOp nm $ map toSql es+> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident "$case")))+> (HSE.List [v,ts,el]) ->+> Case (ltom v) (pairs ts) (ltom el)+> HSE.App (HSE.Lit (HSE.String ('c':nm))) e0 ->+> Cast (toSql e0) (read nm)+> HSE.App (HSE.Lit (HSE.String ('i':nm)))+> (HSE.List [e0, HSE.List es]) ->+> In (read nm) (toSql e0) (InList $ map toSql es)+> HSE.App (HSE.Lit (HSE.String ('j':nm))) e0 ->+> let (b,sq) = read nm+> in In b (toSql e0) sq+> _ -> err e+> where+> ltom (HSE.List []) = Nothing+> ltom (HSE.List [ex]) = Just $ toSql ex+> ltom ex = err ex+> pairs (HSE.List l) = map (\(HSE.List [a,b]) -> (toSql a, toSql b)) l+> pairs ex = err ex+> err :: Show a => a -> e+> err a = error $ "simple-sql-parser: internal fixity error " ++ show a
+ Language/SQL/SimpleSQL/Parser.lhs view
@@ -0,0 +1,793 @@++> -- | This is the module with the parser functions.+> module Language.SQL.SimpleSQL.Parser+> (parseQueryExpr+> ,parseScalarExpr+> ,parseQueryExprs+> ,ParseError(..)) where++> import Control.Monad.Identity+> import Control.Applicative hiding (many, (<|>), optional)+> import Data.Maybe+> import Data.Char+> import Text.Parsec hiding (ParseError)+> import qualified Text.Parsec as P++> import Language.SQL.SimpleSQL.Syntax+> import Language.SQL.SimpleSQL.Fixity++The public API functions.++> -- | Parses a query expr, trailing semicolon optional.+> parseQueryExpr :: FilePath -- ^ filename to use in errors+> -> Maybe (Int,Int) -- ^ line number and column number to use in errors+> -> String -- ^ the SQL source to parse+> -> Either ParseError QueryExpr+> parseQueryExpr = wrapParse topLevelQueryExpr++> -- | Parses a list of query exprs, with semi colons between them. The final semicolon is optional.+> parseQueryExprs :: FilePath -- ^ filename to use in errors+> -> Maybe (Int,Int) -- ^ line number and column number to use in errors+> -> String -- ^ the SQL source to parse+> -> Either ParseError [QueryExpr]+> parseQueryExprs = wrapParse queryExprs++> -- | Parses a scalar expression.+> parseScalarExpr :: FilePath -- ^ filename to use in errors+> -> Maybe (Int,Int) -- ^ line number and column number to use in errors+> -> String -- ^ the SQL source to parse+> -> Either ParseError ScalarExpr+> parseScalarExpr = wrapParse scalarExpr++This helper function takes the parser given and:++sets the position when parsing+automatically skips leading whitespace+checks the parser parses all the input using eof+converts the error return to the nice wrapper++> wrapParse :: P a+> -> FilePath+> -> Maybe (Int,Int)+> -> String+> -> Either ParseError a+> wrapParse parser f p src =+> either (Left . convParseError src) Right+> $ parse (setPos p *> whiteSpace *> parser <* eof) f src++> -- | Type to represent parse errors.+> data ParseError = ParseError+> {peErrorString :: String -- ^ contains the error message+> ,peFilename :: FilePath -- ^ filename location for the error+> ,pePosition :: (Int,Int) -- ^ line number and column number location for the error+> ,peFormattedError :: String -- ^ formatted error with the position, error message and source context+> } deriving (Eq,Show)++------------------------------------------------++> type P a = ParsecT String () Identity a++= scalar expressions++== literals++See the stringLiteral lexer below for notes on string literal syntax.++> estring :: P ScalarExpr+> estring = StringLit <$> stringLiteral++> number :: P ScalarExpr+> number = NumLit <$> numberLiteral++parse SQL interval literals, something like+interval '5' day (3)+or+interval '5' month++> interval :: P ScalarExpr+> interval = try (keyword_ "interval") >>+> IntervalLit+> <$> stringLiteral+> <*> identifierString+> <*> optionMaybe (try $ parens integerLiteral)++> literal :: P ScalarExpr+> literal = number <|> estring <|> interval++== identifiers++Uses the identifierString 'lexer'. See this function for notes on identifiers.++> identifier :: P ScalarExpr+> identifier = Iden <$> identifierString++Identifier with one dot in it. This should be extended to any amount+of dots.++> dottedIden :: P ScalarExpr+> dottedIden = Iden2 <$> identifierString+> <*> (symbol "." *> identifierString)++== star++used in select *, select x.*, and agg(*) variations.++> star :: P ScalarExpr+> star = choice [Star <$ symbol "*"+> ,Star2 <$> (identifierString <* symbol "." <* symbol "*")]++== function application, aggregates and windows++this represents anything which syntactically looks like regular C+function application: an identifier, parens with comma sep scalar+expression arguments.++The parsing for the aggregate extensions is here as well:++aggregate([all|distinct] args [order by orderitems])++> aggOrApp :: P ScalarExpr+> aggOrApp =+> makeApp+> <$> identifierString+> <*> parens ((,,) <$> try duplicates+> <*> choice [(:[]) <$> try star+> ,commaSep scalarExpr']+> <*> try (optionMaybe orderBy))+> where+> makeApp i (Nothing,es,Nothing) = App i es+> makeApp i (d,es,od) = AggregateApp i d es (fromMaybe [] od)++> duplicates :: P (Maybe Duplicates)+> duplicates = optionMaybe $ try $+> choice [All <$ keyword_ "all"+> ,Distinct <$ keyword "distinct"]++parse a window call as a suffix of a regular function call+this looks like this:+functionname(args) over ([partition by ids] [order by orderitems])++No support for explicit frames yet.++The convention in this file is that the 'Suffix', erm, suffix on+parser names means that they have been left factored. These are almost+always used with the optionSuffix combinator.++> windowSuffix :: ScalarExpr -> P ScalarExpr+> windowSuffix (App f es) =+> try (keyword_ "over")+> *> parens (WindowApp f es+> <$> option [] partitionBy+> <*> option [] orderBy)+> where+> partitionBy = try (keyword_ "partition") >>+> keyword_ "by" >> commaSep1 scalarExpr'+> windowSuffix _ = fail ""++> app :: P ScalarExpr+> app = aggOrApp >>= optionSuffix windowSuffix++== case expression++> scase :: P ScalarExpr+> scase =+> Case <$> (try (keyword_ "case") *> optionMaybe (try scalarExpr'))+> <*> many1 swhen+> <*> optionMaybe (try (keyword_ "else") *> scalarExpr')+> <* keyword_ "end"+> where+> swhen = keyword_ "when" *>+> ((,) <$> scalarExpr' <*> (keyword_ "then" *> scalarExpr'))++== miscellaneous keyword operators++These are keyword operators which don't look like normal prefix,+postfix or infix binary operators. They mostly look like function+application but with keywords in the argument list instead of commas+to separate the arguments.++cast: cast(expr as type)++> cast :: P ScalarExpr+> cast = parensCast <|> prefixCast+> where+> parensCast = try (keyword_ "cast") >>+> parens (Cast <$> scalarExpr'+> <*> (keyword_ "as" *> typeName))+> prefixCast = try (CastOp <$> typeName+> <*> stringLiteral)++extract(id from expr)++> extract :: P ScalarExpr+> extract = try (keyword_ "extract") >>+> parens (makeOp <$> identifierString+> <*> (keyword_ "from" *> scalarExpr'))+> where makeOp n e = SpecialOp "extract" [Iden n, e]++substring(x from expr to expr)++todo: also support substring(x from expr)++> substring :: P ScalarExpr+> substring = try (keyword_ "substring") >>+> parens (makeOp <$> scalarExpr'+> <*> (keyword_ "from" *> scalarExpr')+> <*> (keyword_ "for" *> scalarExpr')+> )+> where makeOp a b c = SpecialOp "substring" [a,b,c]++in: two variations:+a in (expr0, expr1, ...)+a in (queryexpr)++> inSuffix :: ScalarExpr -> P ScalarExpr+> inSuffix e =+> In <$> inty+> <*> return e+> <*> parens (choice+> [InQueryExpr <$> queryExpr+> ,InList <$> commaSep1 scalarExpr'])+> where+> inty = try $ choice [True <$ keyword_ "in"+> ,False <$ keyword_ "not" <* keyword_ "in"]++between:+expr between expr and expr++There is a complication when parsing between - when parsing the second+expression it is ambiguous when you hit an 'and' whether it is a+binary operator or part of the between. This code follows what+postgres does, which might be standard across SQL implementations,+which is that you can't have a binary and operator in the middle+expression in a between unless it is wrapped in parens. The 'bExpr+parsing' is used to create alternative scalar expression parser which+is identical to the normal one expect it doesn't recognise the binary+and operator. This is the call to scalarExpr'' True.++> betweenSuffix :: ScalarExpr -> P ScalarExpr+> betweenSuffix e =+> makeOp <$> opName+> <*> return e+> <*> scalarExpr'' True+> <*> (keyword_ "and" *> scalarExpr'' True)+> where+> opName = try $ choice+> ["between" <$ keyword_ "between"+> ,"not between" <$ keyword_ "not" <* keyword_ "between"]+> makeOp n a b c = SpecialOp n [a,b,c]++subquery expression:+[exists|all|any|some] (queryexpr)++> subquery :: P ScalarExpr+> subquery =+> choice+> [try $ SubQueryExpr SqSq <$> parens queryExpr+> ,SubQueryExpr <$> try sqkw <*> parens queryExpr]+> where+> sqkw = try $ choice+> [SqExists <$ keyword_ "exists"+> ,SqAll <$ try (keyword_ "all")+> ,SqAny <$ keyword_ "any"+> ,SqSome <$ keyword_ "some"]++typename: used in casts. Special cases for the multi keyword typenames+that SQL supports.++> typeName :: P TypeName+> typeName = choice+> [TypeName "double precision"+> <$ try (keyword_ "double" <* keyword_ "precision")+> ,TypeName "character varying"+> <$ try (keyword_ "character" <* keyword_ "varying")+> ,TypeName <$> identifierString]++== scalar parens++> sparens :: P ScalarExpr+> sparens = Parens <$> parens scalarExpr'+++== operator parsing++The 'regular' operators in this parsing and in the abstract syntax are+unary prefix, unary postfix and binary infix operators. The operators+can be symbols (a + b), single keywords (a and b) or multiple keywords+(a is similar to b).++First, the list of the regulars operators split by operator type+(prefix, postfix, binary) and by symbol/single keyword/ multiple+keyword.++> binOpSymbolNames :: [String]+> binOpSymbolNames =+> ["=", "<=", ">=", "!=", "<>", "<", ">"+> ,"*", "/", "+", "-"+> ,"||"]++> binOpKeywordNames :: [String]+> binOpKeywordNames = ["and", "or", "like", "overlaps"]++> binOpMultiKeywordNames :: [[String]]+> binOpMultiKeywordNames = map words+> ["not like"+> ,"is similar to"+> ,"is not similar to"+> ,"is distinct from"+> ,"is not distinct from"]++used for between parsing++> binOpKeywordNamesNoAnd :: [String]+> binOpKeywordNamesNoAnd = filter (/="and") binOpKeywordNames++There aren't any multi keyword prefix operators currently supported.++> prefixUnOpKeywordNames :: [String]+> prefixUnOpKeywordNames = ["not"]++> prefixUnOpSymbolNames :: [String]+> prefixUnOpSymbolNames = ["+", "-"]++There aren't any single keyword postfix operators currently+supported. Maybe all these 'is's can be left factored?++> postfixOpKeywords :: [String]+> postfixOpKeywords = ["is null"+> ,"is not null"+> ,"is true"+> ,"is not true"+> ,"is false"+> ,"is not false"+> ,"is unknown"+> ,"is not unknown"]++The parsers:++> prefixUnaryOp :: P ScalarExpr+> prefixUnaryOp =+> PrefixOp <$> opSymbol <*> scalarExpr'+> where+> opSymbol = choice (map (try . symbol) prefixUnOpSymbolNames+> ++ map (try . keyword) prefixUnOpKeywordNames)++TODO: the handling of multikeyword args is different in+postfixopsuffix and binaryoperatorsuffix. It should be the same in+both cases++> postfixOpSuffix :: ScalarExpr -> P ScalarExpr+> postfixOpSuffix e =+> try $ choice $ map makeOp opPairs+> where+> opPairs = flip map postfixOpKeywords $ \o -> (o, words o)+> makeOp (o,ws) = try $ PostfixOp o e <$ keywords_ ws+> keywords_ = try . mapM_ keyword_++All the binary operators are parsed as same precedence and left+associativity. This is fixed with a separate pass over the AST.++> binaryOperatorSuffix :: Bool -> ScalarExpr -> P ScalarExpr+> binaryOperatorSuffix bExpr e0 =+> BinOp e0 <$> opSymbol <*> factor+> where+> opSymbol = choice+> (map (try . symbol) binOpSymbolNames+> ++ map (try . keywords) binOpMultiKeywordNames+> ++ map (try . keyword)+> (if bExpr+> then binOpKeywordNamesNoAnd+> else binOpKeywordNames))+> keywords ks = unwords <$> mapM keyword ks++> sqlFixities :: [[Fixity]]+> sqlFixities = highPrec ++ defaultPrec ++ lowPrec+> where+> allOps = binOpSymbolNames ++ binOpKeywordNames+> ++ map unwords binOpMultiKeywordNames+> ++ prefixUnOpKeywordNames ++ prefixUnOpSymbolNames+> ++ postfixOpKeywords+> -- these are the ops with the highest precedence in order+> highPrec = [infixl_ ["*","/"]+> ,infixl_ ["+", "-"]+> ,infixl_ ["<=",">=","!=","<>","||","like"]+> ]+> -- these are the ops with the lowest precedence in order+> lowPrec = [infix_ ["<",">"]+> ,infixr_ ["="]+> ,infixr_ ["not"]+> ,infixl_ ["and"]+> ,infixl_ ["or"]]+> already = concatMap (map fName) highPrec+> ++ concatMap (map fName) lowPrec+> -- all the other ops have equal precedence and go between the+> -- high and low precedence ops+> defaultPrecOps = filter (`notElem` already) allOps+> -- almost correct, have to do some more work to+> -- get the associativity correct for these operators+> defaultPrec = [infixl_ defaultPrecOps]+> fName (Fixity n _) = n+++== scalar expressions++TODO:+left factor stuff which starts with identifier++This parses most of the scalar exprs. I'm not sure if factor is the+correct terminology here. The order of the parsers and use of try is+carefully done to make everything work. It is a little fragile and+could at least do with some heavy explanation.++> factor :: P ScalarExpr+> factor = choice [literal+> ,scase+> ,cast+> ,extract+> ,substring+> ,subquery+> ,prefixUnaryOp+> ,try app+> ,try dottedIden+> ,identifier+> ,sparens]++putting the factor together with the extra bits++> scalarExpr'' :: Bool -> P ScalarExpr+> scalarExpr'' bExpr = factor >>= trysuffix+> where+> trysuffix e = try (suffix e) <|> return e+> suffix e0 = choice+> [binaryOperatorSuffix bExpr e0+> ,inSuffix e0+> ,betweenSuffix e0+> ,postfixOpSuffix e0+> ] >>= trysuffix++Wrapper for non 'bExpr' parsing. See the between parser for+explanation.++> scalarExpr' :: P ScalarExpr+> scalarExpr' = scalarExpr'' False++The scalarExpr wrapper. The idea is that directly nested scalar+expressions use the scalarExpr' parser, then other code uses the+scalarExpr parser and then everyone gets the fixity fixes and it's+easy to ensure that this fix is only applied once to each scalar+expression tree (for efficiency and code clarity).++> scalarExpr :: P ScalarExpr+> scalarExpr =+> choice [try star+> ,fixFixities sqlFixities <$> scalarExpr']++-------------------------------------------------++= query expressions++== select lists++> selectItem :: P (Maybe String, ScalarExpr)+> selectItem = flip (,) <$> scalarExpr <*> optionMaybe (try alias)+> where alias = optional (try (keyword_ "as")) *> identifierString++> selectList :: P [(Maybe String,ScalarExpr)]+> selectList = commaSep1 selectItem++== from++Here is the rough grammar for joins++tref+(cross | [natural] ([inner] | (left | right | full) [outer])) join+tref+[on expr | using (...)]++> from :: P [TableRef]+> from = try (keyword_ "from") *> commaSep1 tref+> where+> tref = nonJoinTref >>= optionSuffix joinTrefSuffix+> nonJoinTref = choice [try (TRQueryExpr <$> parens queryExpr)+> ,TRParens <$> parens tref+> ,TRSimple <$> identifierString]+> >>= optionSuffix aliasSuffix+> aliasSuffix j =+> let tableAlias = optional (try $ keyword_ "as") *> identifierString+> columnAliases = optionMaybe $ try $ parens+> $ commaSep1 identifierString+> in option j (TRAlias j <$> try tableAlias <*> try columnAliases)+> joinTrefSuffix t = (do+> nat <- option False $ try (True <$ try (keyword_ "natural"))+> TRJoin t <$> joinType+> <*> nonJoinTref+> <*> optionMaybe (joinCondition nat))+> >>= optionSuffix joinTrefSuffix+> joinType = choice+> [JCross <$ try (keyword_ "cross")+> ,JInner <$ try (keyword_ "inner")+> ,choice [JLeft <$ try (keyword_ "left")+> ,JRight <$ try (keyword_ "right")+> ,JFull <$ try (keyword_ "full")]+> <* optional (try $ keyword_ "outer")]+> <* keyword "join"+> joinCondition nat =+> choice [guard nat >> return JoinNatural+> ,try (keyword_ "on") >>+> JoinOn <$> scalarExpr+> ,try (keyword_ "using") >>+> JoinUsing <$> parens (commaSep1 identifierString)+> ]++== simple other parts++Parsers for where, group by, having, order by and limit, which are+pretty trivial.++Here is a helper for parsing a few parts of the query expr (currently+where, having, limit, offset).++> keywordScalarExpr :: String -> P ScalarExpr+> keywordScalarExpr k = try (keyword_ k) *> scalarExpr++> swhere :: P ScalarExpr+> swhere = keywordScalarExpr "where"++> sgroupBy :: P [ScalarExpr]+> sgroupBy = try (keyword_ "group")+> *> keyword_ "by"+> *> commaSep1 scalarExpr++> having :: P ScalarExpr+> having = keywordScalarExpr "having"++> orderBy :: P [(ScalarExpr,Direction)]+> orderBy = try (keyword_ "order") *> keyword_ "by" *> commaSep1 ob+> where+> ob = (,) <$> scalarExpr+> <*> option Asc (choice [Asc <$ keyword_ "asc"+> ,Desc <$ keyword_ "desc"])++> limit :: P ScalarExpr+> limit = keywordScalarExpr "limit"++> offset :: P ScalarExpr+> offset = keywordScalarExpr "offset"++== common table expressions++> with :: P QueryExpr+> with = try (keyword_ "with") >>+> With <$> commaSep1 withQuery <*> queryExpr+> where+> withQuery =+> (,) <$> (identifierString <* optional (try $ keyword_ "as"))+> <*> parens queryExpr++== query expression++This parser parses any query expression variant: normal select, cte,+and union, etc..++> queryExpr :: P QueryExpr+> queryExpr =+> choice [with+> ,select >>= optionSuffix queryExprSuffix]+> where+> select = try (keyword_ "select") >>+> Select+> <$> (fromMaybe All <$> duplicates)+> <*> selectList+> <*> option [] from+> <*> optionMaybe swhere+> <*> option [] sgroupBy+> <*> optionMaybe having+> <*> option [] orderBy+> <*> optionMaybe limit+> <*> optionMaybe offset++> queryExprSuffix :: QueryExpr -> P QueryExpr+> queryExprSuffix qe =+> (CombineQueryExpr qe+> <$> try (choice+> [Union <$ keyword_ "union"+> ,Intersect <$ keyword_ "intersect"+> ,Except <$ keyword_ "except"])+> <*> (fromMaybe All <$> duplicates)+> <*> option Respectively+> (try (Corresponding <$ keyword_ "corresponding"))+> <*> queryExpr)+> >>= optionSuffix queryExprSuffix++wrapper for query expr which ignores optional trailing semicolon.++> topLevelQueryExpr :: P QueryExpr+> topLevelQueryExpr =+> queryExpr >>= optionSuffix ((symbol ";" *>) . return)++wrapper to parse a series of query exprs from a single source. They+must be separated by semicolon, but for the last expression, the+trailing semicolon is optional.++> queryExprs :: P [QueryExpr]+> queryExprs =+> (:[]) <$> queryExpr+> >>= optionSuffix ((symbol ";" *>) . return)+> >>= optionSuffix (\p -> (p++) <$> queryExprs)++------------------------------------------------++= lexing parsers++The lexing is a bit 'virtual', in the usual parsec style. The+convention in this file is to put all the parsers which access+characters directly or indirectly here (i.e. ones which use char,+string, digit, etc.), except for the parsers which only indirectly+access them via these functions, if you follow?++> symbol :: String -> P String+> symbol s = string s+> -- <* notFollowedBy (oneOf "+-/*<>=!|")+> <* whiteSpace++> symbol_ :: String -> P ()+> symbol_ s = symbol s *> return ()++> keyword :: String -> P String+> keyword s = (map toLower <$> string s)+> <* notFollowedBy (char '_' <|> alphaNum)+> <* whiteSpace++> keyword_ :: String -> P ()+> keyword_ s = keyword s *> return ()++Identifiers are very simple at the moment: start with a letter or+underscore, and continue with letter, underscore or digit. It doesn't+support quoting other other sorts of identifiers yet. There is a+blacklist of keywords which aren't supported as identifiers.++> identifierString :: P String+> identifierString = do+> s <- (:) <$> letterOrUnderscore+> <*> many letterDigitOrUnderscore <* whiteSpace+> guard (s `notElem` blacklist)+> return s+> where+> letterOrUnderscore = char '_' <|> letter+> letterDigitOrUnderscore = char '_' <|> alphaNum++> blacklist :: [String]+> blacklist =+> ["select", "as", "from", "where", "having", "group", "order"+> ,"limit", "offset"+> ,"inner", "left", "right", "full", "natural", "join"+> ,"cross", "on", "using"+> ,"when", "then", "case", "end", "in"+> ,"except", "intersect", "union"]++These blacklisted names are mostly needed when we parse something with+an optional alias, e.g. select a a from t. If we write select a from+t, we have to make sure the from isn't parsed as an alias. I'm not+sure what other places strictly need the blacklist, and in theory it+could be tuned differently for each place the identifierString/+identifier parsers are used to only blacklist the bare minimum.++String literals: limited at the moment, no escaping \' or other+variations.++> stringLiteral :: P String+> stringLiteral = char '\'' *> manyTill anyChar (symbol_ "'")++number literals++here is the rough grammar target:++digits+digits.[digits][e[+-]digits]+[digits].digits[e[+-]digits]+digitse[+-]digits++numbers are parsed to strings, not to a numeric type. This is to avoid+making a decision on how to represent numbers, the client code can+make this choice.++> numberLiteral :: P String+> numberLiteral =+> choice [int+> >>= optionSuffix dot+> >>= optionSuffix fracts+> >>= optionSuffix expon+> ,fract "" >>= optionSuffix expon]+> <* whiteSpace+> where+> int = many1 digit+> fract p = dot p >>= fracts+> dot p = (p++) <$> string "."+> fracts p = (p++) <$> int+> expon p = concat <$> sequence+> [return p+> ,string "e"+> ,option "" (string "+" <|> string "-")+> ,int]++lexer for integer literals which appear in some places in SQL++> integerLiteral :: P Int+> integerLiteral = read <$> many1 digit <* whiteSpace++whitespace parser which skips comments also++> whiteSpace :: P ()+> whiteSpace =+> choice [simpleWhiteSpace *> whiteSpace+> ,lineComment *> whiteSpace+> ,blockComment *> whiteSpace+> ,return ()]+> where+> lineComment = try (string "--")+> *> manyTill anyChar (void (char '\n') <|> eof)+> blockComment = -- no nesting of block comments in SQL+> try (string "/*")+> -- TODO: why is try used herex+> *> manyTill anyChar (try $ string "*/")+> -- use many1 so we can more easily avoid non terminating loops+> simpleWhiteSpace = void $ many1 (oneOf " \t\n")++= generic parser helpers++a possible issue with the option suffix is that it enforces left+associativity when chaining it recursively. Have to review+all these uses and figure out if any should be right associative+instead, and create an alternative suffix parser++> optionSuffix :: (a -> P a) -> a -> P a+> optionSuffix p a = option a (p a)++> parens :: P a -> P a+> parens = between (symbol_ "(") (symbol_ ")")++> commaSep :: P a -> P [a]+> commaSep = (`sepBy` symbol_ ",")+++> commaSep1 :: P a -> P [a]+> commaSep1 = (`sepBy1` symbol_ ",")++--------------------------------------------++= helper functions++> setPos :: Maybe (Int,Int) -> P ()+> setPos Nothing = return ()+> setPos (Just (l,c)) = fmap f getPosition >>= setPosition+> where f = flip setSourceColumn c+> . flip setSourceLine l++> convParseError :: String -> P.ParseError -> ParseError+> convParseError src e =+> ParseError+> {peErrorString = show e+> ,peFilename = sourceName p+> ,pePosition = (sourceLine p, sourceColumn p)+> ,peFormattedError = formatError src e+> }+> where+> p = errorPos e++format the error more nicely: emacs format for positioning, plus+context++> formatError :: String -> P.ParseError -> String+> formatError src e =+> sourceName p ++ ":" ++ show (sourceLine p)+> ++ ":" ++ show (sourceColumn p) ++ ":"+> ++ context+> ++ show e+> where+> context =+> let lns = take 1 $ drop (sourceLine p - 1) $ lines src+> in case lns of+> [x] -> "\n" ++ x ++ "\n"+> ++ replicate (sourceColumn p - 1) ' ' ++ "^\n"+> _ -> ""+> p = errorPos e
+ Language/SQL/SimpleSQL/Pretty.lhs view
@@ -0,0 +1,233 @@++> -- | These is the pretty printing functions, which produce SQL+> -- source from ASTs. The code attempts to format the output in a+> -- readable way.+> module Language.SQL.SimpleSQL.Pretty+> (prettyQueryExpr+> ,prettyScalarExpr+> ,prettyQueryExprs+> ) where++> import Language.SQL.SimpleSQL.Syntax+> import Text.PrettyPrint+> import Data.Maybe++> -- | Convert a query expr ast to concrete syntax.+> prettyQueryExpr :: QueryExpr -> String+> prettyQueryExpr = render . queryExpr++> -- | Convert a scalar expr ast to concrete syntax.+> prettyScalarExpr :: ScalarExpr -> String+> prettyScalarExpr = render . scalarExpr++> -- | Convert a list of query exprs to concrete syntax. A semi colon+> -- is inserted after each query expr.+> prettyQueryExprs :: [QueryExpr] -> String+> prettyQueryExprs = render . vcat . map ((<> text ";\n") . queryExpr)++= scalar expressions++> scalarExpr :: ScalarExpr -> Doc+> scalarExpr (StringLit s) = quotes $ text s+> scalarExpr (NumLit s) = text s+> scalarExpr (IntervalLit v u p) =+> text "interval" <+> quotes (text v)+> <+> text u+> <+> maybe empty (parens . text . show ) p+> scalarExpr (Iden i) = text i+> scalarExpr (Iden2 q i) = text q <> text "." <> text i+> scalarExpr Star = text "*"+> scalarExpr (Star2 q) = text q <> text "." <> text "*"++> scalarExpr (App f es) = text f <> parens (commaSep (map scalarExpr es))++> scalarExpr (AggregateApp f d es od) =+> text f+> <> parens ((case d of+> Just Distinct -> text "distinct"+> Just All -> text "all"+> Nothing -> empty)+> <+> commaSep (map scalarExpr es)+> <+> orderBy od)++> scalarExpr (WindowApp f es pb od) =+> text f <> parens (commaSep $ map scalarExpr es)+> <+> text "over"+> <+> parens ((case pb of+> [] -> empty+> _ -> text "partition by"+> <+> nest 13 (commaSep $ map scalarExpr pb))+> <+> orderBy od)++> scalarExpr (SpecialOp nm [a,b,c]) | nm `elem` ["between", "not between"] =+> sep [scalarExpr a+> ,text nm <+> scalarExpr b+> ,nest (length nm + 1)+> $ text "and" <+> scalarExpr c]++> scalarExpr (SpecialOp "extract" [a,n]) =+> text "extract" <> parens (scalarExpr a+> <+> text "from"+> <+> scalarExpr n)++> scalarExpr (SpecialOp "substring" [a,s,e]) =+> text "substring" <> parens (scalarExpr a+> <+> text "from"+> <+> scalarExpr s+> <+> text "for"+> <+> scalarExpr e)++> scalarExpr (SpecialOp nm es) =+> text nm <+> parens (commaSep $ map scalarExpr es)++> scalarExpr (PrefixOp f e) = text f <+> scalarExpr e+> scalarExpr (PostfixOp f e) = scalarExpr e <+> text f+> scalarExpr e@(BinOp _ op _) | op `elem` ["and", "or"] =+> -- special case for and, or, get all the ands so we can vcat them+> -- nicely+> case ands e of+> (e':es) -> vcat (scalarExpr e'+> : map ((text op <+>) . scalarExpr) es)+> [] -> empty -- shouldn't be possible+> where+> ands (BinOp a op' b) | op == op' = ands a ++ ands b+> ands x = [x]+> scalarExpr (BinOp e0 f e1) =+> scalarExpr e0 <+> text f <+> scalarExpr e1++> scalarExpr (Case t ws els) =+> sep $ [text "case" <+> maybe empty scalarExpr t]+> ++ map w ws+> ++ maybeToList (fmap e els)+> ++ [text "end"]+> where+> w (t0,t1) =+> text "when" <+> nest 5 (scalarExpr t0)+> <+> text "then" <+> nest 5 (scalarExpr t1)+> e el = text "else" <+> nest 5 (scalarExpr el)+> scalarExpr (Parens e) = parens $ scalarExpr e+> scalarExpr (Cast e (TypeName tn)) =+> text "cast" <> parens (sep [scalarExpr e+> ,text "as"+> ,text tn])++> scalarExpr (CastOp (TypeName tn) s) =+> text tn <+> quotes (text s)++> scalarExpr (SubQueryExpr ty qe) =+> (case ty of+> SqSq -> empty+> SqExists -> text "exists"+> SqAll -> text "all"+> SqSome -> text "some"+> SqAny -> text "any"+> ) <+> parens (queryExpr qe)++> scalarExpr (In b se x) =+> scalarExpr se <+>+> (if b then empty else text "not")+> <+> text "in"+> <+> parens (nest (if b then 3 else 7) $+> case x of+> InList es -> commaSep $ map scalarExpr es+> InQueryExpr qe -> queryExpr qe)++= query expressions++> queryExpr :: QueryExpr -> Doc+> queryExpr (Select d sl fr wh gb hv od lm off) =+> sep [text "select"+> ,case d of+> All -> empty+> Distinct -> text "distinct"+> ,nest 7 $ sep [selectList sl]+> ,from fr+> ,maybeScalarExpr "where" wh+> ,grpBy gb+> ,maybeScalarExpr "having" hv+> ,orderBy od+> ,maybeScalarExpr "limit" lm+> ,maybeScalarExpr "offset" off+> ]+> queryExpr (CombineQueryExpr q1 ct d c q2) =+> sep [queryExpr q1+> ,text (case ct of+> Union -> "union"+> Intersect -> "intersect"+> Except -> "except")+> <+> case d of+> All -> empty+> Distinct -> text "distinct"+> <+> case c of+> Corresponding -> text "corresponding"+> Respectively -> empty+> ,queryExpr q2]+> queryExpr (With withs qe) =+> text "with"+> <+> vcat [nest 5+> (vcat $ punctuate comma $ flip map withs $ \(n,q) ->+> text n <+> text "as" <+> parens (queryExpr q))+> ,queryExpr qe]++> selectList :: [(Maybe String, ScalarExpr)] -> Doc+> selectList is = commaSep $ map si is+> where+> si (al,e) = scalarExpr e <+> maybe empty alias al+> alias al = text "as" <+> text al++> from :: [TableRef] -> Doc+> from [] = empty+> from ts =+> sep [text "from"+> ,nest 5 $ vcat $ punctuate comma $ map tr ts]+> where+> tr (TRSimple t) = text t+> tr (TRAlias t a cs) =+> sep [tr t+> ,text "as" <+> text a+> <+> maybe empty (parens . commaSep . map text) cs]+> tr (TRParens t) = parens $ tr t+> tr (TRQueryExpr q) = parens $ queryExpr q+> tr (TRJoin t0 jt t1 jc) =+> sep [tr t0+> ,joinText jt jc <+> tr t1+> ,joinCond jc]+> joinText jt jc =+> sep [case jc of+> Just JoinNatural -> text "natural"+> _ -> empty+> ,case jt of+> JInner -> text "inner"+> JLeft -> text "left"+> JRight -> text "right"+> JFull -> text "full"+> JCross -> text "cross"+> ,text "join"]+> joinCond (Just (JoinOn e)) = text "on" <+> scalarExpr e+> joinCond (Just (JoinUsing es)) =+> text "using" <+> parens (commaSep $ map text es)+> joinCond Nothing = empty+> joinCond (Just JoinNatural) = empty++> maybeScalarExpr :: String -> Maybe ScalarExpr -> Doc+> maybeScalarExpr k = maybe empty+> (\e -> sep [text k+> ,nest (length k + 1) $ scalarExpr e])++> grpBy :: [ScalarExpr] -> Doc+> grpBy [] = empty+> grpBy gs = sep [text "group by"+> ,nest 9 $ commaSep $ map scalarExpr gs]++> orderBy :: [(ScalarExpr,Direction)] -> Doc+> orderBy [] = empty+> orderBy os = sep [text "order by"+> ,nest 9 $ commaSep $ map f os]+> where+> f (e,Asc) = scalarExpr e+> f (e,Desc) = scalarExpr e <+> text "desc"++= utils++> commaSep :: [Doc] -> Doc+> commaSep ds = sep $ punctuate comma ds
+ Language/SQL/SimpleSQL/Syntax.lhs view
@@ -0,0 +1,210 @@++> -- | The AST for SQL queries+> module Language.SQL.SimpleSQL.Syntax+> (-- * Scalar expressions+> ScalarExpr(..)+> ,TypeName(..)+> ,Duplicates(..)+> ,Direction(..)+> ,InThing(..)+> ,SubQueryExprType(..)+> -- * Query expressions+> ,QueryExpr(..)+> ,makeSelect+> ,CombineOp(..)+> ,Corresponding(..)+> -- ** From+> ,TableRef(..)+> ,JoinType(..)+> ,JoinCondition(..)+> ) where++> -- | Represents a scalar expression+> data ScalarExpr+> = -- | a numeric literal optional decimal point, e+-+> -- integral exponent, e.g+> --+> -- * 10+> --+> -- * 10.+> --+> -- * .1+> --+> -- * 10.1+> --+> -- * 1e5+> --+> -- * 12.34e-6+> NumLit String+> -- | string literal, currently only basic strings between+> -- single quotes without escapes (no single quotes in strings+> -- then)+> | StringLit String+> -- | text of interval literal, units of interval precision,+> -- e.g. interval 3 days (3)+> | IntervalLit String String (Maybe Int)+> -- | identifier without dots+> | Iden String+> -- | identifier with one dot+> | Iden2 String String+> -- | star+> | Star+> -- | star with qualifier, e.g t.*+> | Star2 String+> -- | function application (anything that looks like c style+> -- function application syntactically)+> | App String [ScalarExpr]+> -- | aggregate application, which adds distinct or all, and+> -- order by, to regular function application+> | AggregateApp String (Maybe Duplicates)+> [ScalarExpr]+> [(ScalarExpr,Direction)]+> -- | window application, which adds over (partition by a order+> -- by b) to regular function application. Explicit frames are+> -- not currently supported+> | WindowApp String [ScalarExpr] [ScalarExpr] [(ScalarExpr,Direction)]+> -- | Infix binary operators. This is used for symbol operators+> -- (a + b), keyword operators (a and b) and multiple keyword+> -- operators (a is similar to b)+> | BinOp ScalarExpr String ScalarExpr+> -- | Prefix unary operators. This is used for symbol+> -- operators, keyword operators and multiple keyword operators+> | PrefixOp String ScalarExpr+> -- | Postfix unary operators. This is used for symbol+> -- operators, keyword operators and multiple keyword operators+> | PostfixOp String ScalarExpr+> -- | Used for ternary, mixfix and other non orthodox+> -- operators, including the function looking calls which use+> -- keywords instead of commas to separate the arguments,+> -- e.g. substring(t from 1 to 5)+> | SpecialOp String [ScalarExpr]+> -- | case expression. both flavours supported. Multiple+> -- condition when branches not currently supported (case when+> -- a=4,b=5 then x end)+> | Case (Maybe ScalarExpr) -- test value+> [(ScalarExpr,ScalarExpr)] -- when branches+> (Maybe ScalarExpr) -- else value+> | Parens ScalarExpr+> -- | cast(a as typename)+> | Cast ScalarExpr TypeName+> -- | prefix 'typed literal', e.g. int '42'+> | CastOp TypeName String+> -- | exists, all, any, some subqueries+> | SubQueryExpr SubQueryExprType QueryExpr+> -- | in list literal and in subquery, if the bool is false it+> -- means not in was used ('a not in (1,2)')+> | In Bool ScalarExpr InThing+> deriving (Eq,Show,Read)++> -- | Represents a type name, used in casts.+> data TypeName = TypeName String deriving (Eq,Show,Read)+++> -- | Used for 'expr in (scalar expression list)', and 'expr in+> -- (subquery)' syntax+> data InThing = InList [ScalarExpr]+> | InQueryExpr QueryExpr+> deriving (Eq,Show,Read)++> -- | A subquery in a scalar expression+> data SubQueryExprType+> = -- | exists (query expr)+> SqExists+> -- | a scalar subquery+> | SqSq+> -- | all (query expr)+> | SqAll+> -- | some (query expr)+> | SqSome+> -- | any (query expr)+> | SqAny+> deriving (Eq,Show,Read)++> -- | Represents a query expression, which can be:+> --+> -- * a regular select;+> --+> -- * a set operator (union, except, intersect);+> --+> -- * a common table expression (with);+> --+> -- * a values expression (not yet supported);+> --+> -- * or the table syntax - 'table t', shorthand for 'select * from+> -- t' (not yet supported).+> data QueryExpr+> = Select+> {qeDuplicates :: Duplicates+> ,qeSelectList :: [(Maybe String,ScalarExpr)]+> -- ^ the column aliases and the expressions+> ,qeFrom :: [TableRef]+> ,qeWhere :: Maybe ScalarExpr+> ,qeGroupBy :: [ScalarExpr]+> ,qeHaving :: Maybe ScalarExpr+> ,qeOrderBy :: [(ScalarExpr,Direction)]+> ,qeLimit :: Maybe ScalarExpr+> ,qeOffset :: Maybe ScalarExpr+> }+> | CombineQueryExpr+> {qe1 :: QueryExpr+> ,qeCombOp :: CombineOp+> ,qeDuplicates :: Duplicates+> ,qeCorresponding :: Corresponding+> ,qe2 :: QueryExpr+> }+> | With [(String,QueryExpr)] QueryExpr+> deriving (Eq,Show,Read)++TODO: add queryexpr parens to deal with e.g.+(select 1 union select 2) union select 3+I'm not sure if this is valid syntax or not.++> -- | represents the Distinct or All keywords, which can be used+> -- before a select list, in an aggregate/window function+> -- application, or in a query expression set operator+> data Duplicates = Distinct | All deriving (Eq,Show,Read)++> -- | The direction for a column in order by.+> data Direction = Asc | Desc deriving (Eq,Show,Read)+> -- | Query expression set operators+> data CombineOp = Union | Except | Intersect deriving (Eq,Show,Read)+> -- | Corresponding, an option for the set operators+> data Corresponding = Corresponding | Respectively deriving (Eq,Show,Read)++> -- | helper/'default' value for query exprs to make creating query+> -- expr values a little easier+> makeSelect :: QueryExpr+> makeSelect = Select {qeDuplicates = All+> ,qeSelectList = []+> ,qeFrom = []+> ,qeWhere = Nothing+> ,qeGroupBy = []+> ,qeHaving = Nothing+> ,qeOrderBy = []+> ,qeLimit = Nothing+> ,qeOffset = Nothing}++> -- | Represents a entry in the csv of tables in the from clause.+> data TableRef = -- | from t+> TRSimple String+> -- | from a join b+> | TRJoin TableRef JoinType TableRef (Maybe JoinCondition)+> -- | from (a)+> | TRParens TableRef+> -- | from a as b(c,d)+> | TRAlias TableRef String (Maybe [String])+> -- | from (query expr)+> | TRQueryExpr QueryExpr+> deriving (Eq,Show,Read)++TODO: add function table ref++> -- | The type of a join+> data JoinType = JInner | JLeft | JRight | JFull | JCross+> deriving (Eq,Show,Read)++> -- | The join condition.+> data JoinCondition = JoinOn ScalarExpr -- ^ on expr+> | JoinUsing [String] -- ^ using (column list)+> | JoinNatural -- ^ natural join was used+> deriving (Eq,Show,Read)
+ README view
@@ -0,0 +1,5 @@+A parser for SQL queries in Haskell.++Homepage: http://jakewheat.github.io/simple_sql_parser/++Contact: jakewheatmail@gmail.com
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ simple-sql-parser.cabal view
@@ -0,0 +1,59 @@+name: simple-sql-parser+version: 0.1.0.0+synopsis: A parser for SQL queries+description: A parser for SQL queries++homepage: http://jakewheat.github.io/simple_sql_parser/+license: BSD3+license-file: LICENSE+author: Jake Wheat+maintainer: jakewheatmail@gmail.com+copyright: Copyright Jake Wheat 2013+category: Database,Language+build-type: Simple+extra-source-files: README,LICENSE+cabal-version: >=1.10+bug-reports: https://github.com/JakeWheat/simple_sql_parser/issues++source-repository head+ type: git+ location: https://github.com/JakeWheat/simple_sql_parser.git++library+ exposed-modules: Language.SQL.SimpleSQL.Pretty,+ Language.SQL.SimpleSQL.Parser,+ Language.SQL.SimpleSQL.Syntax+ other-modules: Language.SQL.SimpleSQL.Fixity+ other-extensions: TupleSections+ build-depends: base >=4.6 && <4.7,+ parsec >=3.1 && <3.2,+ mtl >=2.1 && <2.2,+ pretty >= 1.1 && < 1.2,+ haskell-src-exts >= 1.14 && < 1.15+ -- hs-source-dirs:+ default-language: Haskell2010+ ghc-options: -Wall++Test-Suite Tests+ type: exitcode-stdio-1.0+ main-is: RunTests.lhs+ hs-source-dirs: .,tools+ Build-Depends: base >=4.6 && <4.7,+ parsec >=3.1 && <3.2,+ mtl >=2.1 && <2.2,+ pretty >= 1.1 && < 1.2,+ haskell-src-exts >= 1.14 && < 1.15,++ HUnit >= 1.2 && < 1.3,+ test-framework >= 0.8 && < 0.9,+ test-framework-hunit >= 0.3 && < 0.4++ Other-Modules: Language.SQL.SimpleSQL.Pretty,+ Language.SQL.SimpleSQL.Parser,+ Language.SQL.SimpleSQL.Syntax,+ Language.SQL.SimpleSQL.Fixity,+ Language.SQL.SimpleSQL.Tests,+ Tpch+ other-extensions: TupleSections+ default-language: Haskell2010+ ghc-options: -Wall
+ tools/Language/SQL/SimpleSQL/Tests.lhs view
@@ -0,0 +1,534 @@++> module Language.SQL.SimpleSQL.Tests+> (testData+> ,tests+> ,TestItem(..)+> ) where++> import Language.SQL.SimpleSQL.Syntax+> import Language.SQL.SimpleSQL.Pretty+> import Language.SQL.SimpleSQL.Parser+> import qualified Test.HUnit as H+> import Tpch+> import Test.Framework+> import Test.Framework.Providers.HUnit++> data TestItem = Group String [TestItem]+> | TestScalarExpr String ScalarExpr+> | TestQueryExpr String QueryExpr+> | TestQueryExprs String [QueryExpr]+> | ParseQueryExpr String+> deriving (Eq,Show)++> scalarExprParserTests :: TestItem+> scalarExprParserTests = Group "scalarExprParserTests"+> [literals+> ,identifiers+> ,star+> ,app+> ,caseexp+> ,operators+> ,parens+> ,subqueries+> ,aggregates+> ,windowFunctions+> ]++> literals :: TestItem+> literals = Group "literals" $ map (uncurry TestScalarExpr)+> [("3", NumLit "3")+> ,("3.", NumLit "3.")+> ,("3.3", NumLit "3.3")+> ,(".3", NumLit ".3")+> ,("3.e3", NumLit "3.e3")+> ,("3.3e3", NumLit "3.3e3")+> ,(".3e3", NumLit ".3e3")+> ,("3e3", NumLit "3e3")+> ,("3e+3", NumLit "3e+3")+> ,("3e-3", NumLit "3e-3")+> ,("'string'", StringLit "string")+> ,("'1'", StringLit "1")+> ,("interval '3' day", IntervalLit "3" "day" Nothing)+> ,("interval '3' day (3)", IntervalLit "3" "day" $ Just 3)+> ]++> identifiers :: TestItem+> identifiers = Group "identifiers" $ map (uncurry TestScalarExpr)+> [("iden1", Iden "iden1")+> ,("t.a", Iden2 "t" "a")+> ]++> star :: TestItem+> star = Group "star" $ map (uncurry TestScalarExpr)+> [("*", Star)+> ,("t.*", Star2 "t")+> ]++> app :: TestItem+> app = Group "app" $ map (uncurry TestScalarExpr)+> [("f()", App "f" [])+> ,("f(a)", App "f" [Iden "a"])+> ,("f(a,b)", App "f" [Iden "a", Iden "b"])+> ]++> caseexp :: TestItem+> caseexp = Group "caseexp" $ map (uncurry TestScalarExpr)+> [("case a when 1 then 2 end"+> ,Case (Just $ Iden "a") [(NumLit "1"+> ,NumLit "2")] Nothing)+> ,("case a when 1 then 2 when 3 then 4 end"+> ,Case (Just $ Iden "a") [(NumLit "1", NumLit "2")+> ,(NumLit "3", NumLit "4")] Nothing)+> ,("case a when 1 then 2 when 3 then 4 else 5 end"+> ,Case (Just $ Iden "a") [(NumLit "1", NumLit "2")+> ,(NumLit "3", NumLit "4")] (Just $ NumLit "5"))+> ,("case when a=1 then 2 when a=3 then 4 else 5 end"+> ,Case Nothing [(BinOp (Iden "a") "=" (NumLit "1"), NumLit "2")+> ,(BinOp (Iden "a") "=" (NumLit "3"), NumLit "4")]+> (Just $ NumLit "5"))+> ]++> operators :: TestItem+> operators = Group "operators"+> [binaryOperators+> ,unaryOperators+> ,casts+> ,miscOps]++> binaryOperators :: TestItem+> binaryOperators = Group "binaryOperators" $ map (uncurry TestScalarExpr)+> [("a + b", BinOp (Iden "a") "+" (Iden "b"))+> -- sanity check fixities+> -- todo: add more fixity checking+> ,("a + b * c"+> ,BinOp (Iden "a") "+"+> (BinOp (Iden "b") "*" (Iden "c")))+> ,("a * b + c"+> ,BinOp (BinOp (Iden "a") "*" (Iden "b"))+> "+" (Iden "c"))+> ]++> unaryOperators :: TestItem+> unaryOperators = Group "unaryOperators" $ map (uncurry TestScalarExpr)+> [("not a", PrefixOp "not" $ Iden "a")+> ,("not not a", PrefixOp "not" $ PrefixOp "not" $ Iden "a")+> ,("+a", PrefixOp "+" $ Iden "a")+> ,("-a", PrefixOp "-" $ Iden "a")+> ]+++> casts :: TestItem+> casts = Group "operators" $ map (uncurry TestScalarExpr)+> [("cast('1' as int)"+> ,Cast (StringLit "1") $ TypeName "int")+> ,("int '3'"+> ,CastOp (TypeName "int") "3")+> ,("cast('1' as double precision)"+> ,Cast (StringLit "1") $ TypeName "double precision")+> ,("double precision '3'"+> ,CastOp (TypeName "double precision") "3")+> ]++> subqueries :: TestItem+> subqueries = Group "unaryOperators" $ map (uncurry TestScalarExpr)+> [("exists (select a from t)", SubQueryExpr SqExists ms)+> ,("(select a from t)", SubQueryExpr SqSq ms)+> ,("a in (select a from t)"+> ,In True (Iden "a") (InQueryExpr ms))+> ,("a not in (select a from t)"+> ,In False (Iden "a") (InQueryExpr ms))+> ,("a > all (select a from t)"+> ,BinOp (Iden "a") ">" (SubQueryExpr SqAll ms))+> ,("a = some (select a from t)"+> ,BinOp (Iden "a") "=" (SubQueryExpr SqSome ms))+> ,("a <= any (select a from t)"+> ,BinOp (Iden "a") "<=" (SubQueryExpr SqAny ms))+> ]+> where+> ms = makeSelect+> {qeSelectList = [(Nothing,Iden "a")]+> ,qeFrom = [TRSimple "t"]+> }++> miscOps :: TestItem+> miscOps = Group "unaryOperators" $ map (uncurry TestScalarExpr)+> [("a in (1,2,3)"+> ,In True (Iden "a") $ InList $ map NumLit ["1","2","3"])+> ,("a between b and c", SpecialOp "between" [Iden "a"+> ,Iden "b"+> ,Iden "c"])+> ,("a not between b and c", SpecialOp "not between" [Iden "a"+> ,Iden "b"+> ,Iden "c"])+> ,("a is null", PostfixOp "is null" (Iden "a"))+> ,("a is not null", PostfixOp "is not null" (Iden "a"))+> ,("a is true", PostfixOp "is true" (Iden "a"))+> ,("a is not true", PostfixOp "is not true" (Iden "a"))+> ,("a is false", PostfixOp "is false" (Iden "a"))+> ,("a is not false", PostfixOp "is not false" (Iden "a"))+> ,("a is unknown", PostfixOp "is unknown" (Iden "a"))+> ,("a is not unknown", PostfixOp "is not unknown" (Iden "a"))+> ,("a is distinct from b", BinOp (Iden "a") "is distinct from"(Iden "b"))+> ,("a is not distinct from b"+> ,BinOp (Iden "a") "is not distinct from" (Iden "b"))+> ,("a like b", BinOp (Iden "a") "like" (Iden "b"))+> ,("a not like b", BinOp (Iden "a") "not like" (Iden "b"))+> ,("a is similar to b", BinOp (Iden "a") "is similar to" (Iden "b"))+> ,("a is not similar to b"+> ,BinOp (Iden "a") "is not similar to" (Iden "b"))+> ,("a overlaps b", BinOp (Iden "a") "overlaps" (Iden "b"))+> ,("extract(day from t)", SpecialOp "extract" [Iden "day", Iden "t"])+> ,("substring(x from 1 for 2)"+> ,SpecialOp "substring" [Iden "x", NumLit "1", NumLit "2"])+> ]++> aggregates :: TestItem+> aggregates = Group "aggregates" $ map (uncurry TestScalarExpr)+> [("count(*)",App "count" [Star])+> ,("sum(a order by a)"+> ,AggregateApp "sum" Nothing [Iden "a"] [(Iden "a", Asc)])+> ,("sum(all a)"+> ,AggregateApp "sum" (Just All) [Iden "a"] [])+> ,("count(distinct a)"+> ,AggregateApp "count" (Just Distinct) [Iden "a"] [])+> ]++> windowFunctions :: TestItem+> windowFunctions = Group "windowFunctions" $ map (uncurry TestScalarExpr)+> [("max(a) over ()", WindowApp "max" [Iden "a"] [] [])+> ,("count(*) over ()", WindowApp "count" [Star] [] [])+> ,("max(a) over (partition by b)"+> ,WindowApp "max" [Iden "a"] [Iden "b"] [])+> ,("max(a) over (partition by b,c)"+> ,WindowApp "max" [Iden "a"] [Iden "b",Iden "c"] [])+> ,("sum(a) over (order by b)"+> ,WindowApp "sum" [Iden "a"] [] [(Iden "b", Asc)])+> ,("sum(a) over (order by b desc,c)"+> ,WindowApp "sum" [Iden "a"] [] [(Iden "b", Desc)+> ,(Iden "c", Asc)])+> ,("sum(a) over (partition by b order by c)"+> ,WindowApp "sum" [Iden "a"] [Iden "b"] [(Iden "c", Asc)])+> -- todo: check order by options, add frames+> ]++> parens :: TestItem+> parens = Group "parens" $ map (uncurry TestScalarExpr)+> [("(a)", Parens (Iden "a"))+> ,("(a + b)", Parens (BinOp (Iden "a") "+" (Iden "b")))+> ]++> queryExprParserTests :: TestItem+> queryExprParserTests = Group "queryExprParserTests"+> [duplicates+> ,selectLists+> ,from+> ,whereClause+> ,groupByClause+> ,having+> ,orderBy+> ,limit+> ,combos+> ,withQueries+> ,fullQueries+> ]++++> duplicates :: TestItem+> duplicates = Group "duplicates" $ map (uncurry TestQueryExpr)+> [("select a from t" ,ms All)+> ,("select all a from t" ,ms All)+> ,("select distinct a from t", ms Distinct)+> ]+> where+> ms d = makeSelect+> {qeDuplicates = d+> ,qeSelectList = [(Nothing,Iden "a")]+> ,qeFrom = [TRSimple "t"]}++> selectLists :: TestItem+> selectLists = Group "selectLists" $ map (uncurry TestQueryExpr)+> [("select 1",+> makeSelect {qeSelectList = [(Nothing,NumLit "1")]})+> ,("select a"+> ,makeSelect {qeSelectList = [(Nothing,Iden "a")]})+> ,("select a,b"+> ,makeSelect {qeSelectList = [(Nothing,Iden "a")+> ,(Nothing,Iden "b")]})+> ,("select 1+2,3+4"+> ,makeSelect {qeSelectList =+> [(Nothing,BinOp (NumLit "1") "+" (NumLit "2"))+> ,(Nothing,BinOp (NumLit "3") "+" (NumLit "4"))]})+> ,("select a as a, /*comment*/ b as b"+> ,makeSelect {qeSelectList = [(Just "a", Iden "a")+> ,(Just "b", Iden "b")]})+> ,("select a a, b b"+> ,makeSelect {qeSelectList = [(Just "a", Iden "a")+> ,(Just "b", Iden "b")]})+> ]++> from :: TestItem+> from = Group "from" $ map (uncurry TestQueryExpr)+> [("select a from t"+> ,ms [TRSimple "t"])+> ,("select a from t,u"+> ,ms [TRSimple "t", TRSimple "u"])+> ,("select a from t inner join u on expr"+> ,ms [TRJoin (TRSimple "t") JInner (TRSimple "u")+> (Just $ JoinOn $ Iden "expr")])+> ,("select a from t left join u on expr"+> ,ms [TRJoin (TRSimple "t") JLeft (TRSimple "u")+> (Just $ JoinOn $ Iden "expr")])+> ,("select a from t right join u on expr"+> ,ms [TRJoin (TRSimple "t") JRight (TRSimple "u")+> (Just $ JoinOn $ Iden "expr")])+> ,("select a from t full join u on expr"+> ,ms [TRJoin (TRSimple "t") JFull (TRSimple "u")+> (Just $ JoinOn $ Iden "expr")])+> ,("select a from t cross join u"+> ,ms [TRJoin (TRSimple "t")+> JCross (TRSimple "u") Nothing])+> ,("select a from t natural inner join u"+> ,ms [TRJoin (TRSimple "t") JInner (TRSimple "u")+> (Just JoinNatural)])+> ,("select a from t inner join u using(a,b)"+> ,ms [TRJoin (TRSimple "t") JInner (TRSimple "u")+> (Just $ JoinUsing ["a", "b"])])+> ,("select a from (select a from t)"+> ,ms [TRQueryExpr $ ms [TRSimple "t"]])+> ,("select a from t as u"+> ,ms [TRAlias (TRSimple "t") "u" Nothing])+> ,("select a from t u"+> ,ms [TRAlias (TRSimple "t") "u" Nothing])+> ,("select a from t u(b)"+> ,ms [TRAlias (TRSimple "t") "u" $ Just ["b"]])+> ,("select a from (t cross join u) as u"+> ,ms [TRAlias (TRParens $+> TRJoin (TRSimple "t") JCross (TRSimple "u") Nothing)+> "u" Nothing])+> -- todo: not sure if the associativity is correct+> ,("select a from t cross join u cross join v",+> ms [TRJoin+> (TRJoin (TRSimple "t")+> JCross (TRSimple "u") Nothing)+> JCross (TRSimple "v") Nothing])+> ]+> where+> ms f = makeSelect {qeSelectList = [(Nothing,Iden "a")]+> ,qeFrom = f}++> whereClause :: TestItem+> whereClause = Group "whereClause" $ map (uncurry TestQueryExpr)+> [("select a from t where a = 5"+> ,makeSelect {qeSelectList = [(Nothing,Iden "a")]+> ,qeFrom = [TRSimple "t"]+> ,qeWhere = Just $ BinOp (Iden "a") "=" (NumLit "5")})+> ]++> groupByClause :: TestItem+> groupByClause = Group "groupByClause" $ map (uncurry TestQueryExpr)+> [("select a,sum(b) from t group by a"+> ,makeSelect {qeSelectList = [(Nothing, Iden "a")+> ,(Nothing, App "sum" [Iden "b"])]+> ,qeFrom = [TRSimple "t"]+> ,qeGroupBy = [Iden "a"]+> })+> ,("select a,b,sum(c) from t group by a,b"+> ,makeSelect {qeSelectList = [(Nothing, Iden "a")+> ,(Nothing, Iden "b")+> ,(Nothing, App "sum" [Iden "c"])]+> ,qeFrom = [TRSimple "t"]+> ,qeGroupBy = [Iden "a",Iden "b"]+> })+> ]++> having :: TestItem+> having = Group "having" $ map (uncurry TestQueryExpr)+> [("select a,sum(b) from t group by a having sum(b) > 5"+> ,makeSelect {qeSelectList = [(Nothing, Iden "a")+> ,(Nothing, App "sum" [Iden "b"])]+> ,qeFrom = [TRSimple "t"]+> ,qeGroupBy = [Iden "a"]+> ,qeHaving = Just $ BinOp (App "sum" [Iden "b"])+> ">" (NumLit "5")+> })+> ]++> orderBy :: TestItem+> orderBy = Group "orderBy" $ map (uncurry TestQueryExpr)+> [("select a from t order by a"+> ,ms [(Iden "a", Asc)])+> ,("select a from t order by a, b"+> ,ms [(Iden "a", Asc), (Iden "b", Asc)])+> ,("select a from t order by a asc"+> ,ms [(Iden "a", Asc)])+> ,("select a from t order by a desc, b desc"+> ,ms [(Iden "a", Desc), (Iden "b", Desc)])+> ]+> where+> ms o = makeSelect {qeSelectList = [(Nothing,Iden "a")]+> ,qeFrom = [TRSimple "t"]+> ,qeOrderBy = o}++> limit :: TestItem+> limit = Group "limit" $ map (uncurry TestQueryExpr)+> [("select a from t limit 10"+> ,ms (Just $ NumLit "10") Nothing)+> ,("select a from t limit 10 offset 10"+> ,ms (Just $ NumLit "10") (Just $ NumLit "10"))+> ]+> where+> ms l o = makeSelect+> {qeSelectList = [(Nothing,Iden "a")]+> ,qeFrom = [TRSimple "t"]+> ,qeLimit = l+> ,qeOffset = o}++> combos :: TestItem+> combos = Group "combos" $ map (uncurry TestQueryExpr)+> [("select a from t union select b from u"+> ,CombineQueryExpr ms1 Union All Respectively ms2)+> ,("select a from t intersect select b from u"+> ,CombineQueryExpr ms1 Intersect All Respectively ms2)+> ,("select a from t except all select b from u"+> ,CombineQueryExpr ms1 Except All Respectively ms2)+> ,("select a from t union distinct corresponding \+> \select b from u"+> ,CombineQueryExpr ms1 Union Distinct Corresponding ms2)+> ,("select a from t union select a from t union select a from t"+> -- is this the correct associativity? +> ,CombineQueryExpr ms1 Union All Respectively+> (CombineQueryExpr ms1 Union All Respectively ms1))+> ]+> where+> ms1 = makeSelect+> {qeSelectList = [(Nothing,Iden "a")]+> ,qeFrom = [TRSimple "t"]}+> ms2 = makeSelect+> {qeSelectList = [(Nothing,Iden "b")]+> ,qeFrom = [TRSimple "u"]}+++> withQueries :: TestItem+> withQueries = Group "with queries" $ map (uncurry TestQueryExpr)+> [("with u as (select a from t) select a from u"+> ,With [("u", ms1)] ms2)+> ,("with x as (select a from t),\n\+> \ u as (select a from x)\n\+> \select a from u"+> ,With [("x", ms1), ("u",ms3)] ms2)+> ]+> where+> ms c t = makeSelect+> {qeSelectList = [(Nothing,Iden c)]+> ,qeFrom = [TRSimple t]}+> ms1 = ms "a" "t"+> ms2 = ms "a" "u"+> ms3 = ms "a" "x"+++> fullQueries :: TestItem+> fullQueries = Group "queries" $ map (uncurry TestQueryExpr)+> [("select count(*) from t"+> ,makeSelect+> {qeSelectList = [(Nothing, App "count" [Star])]+> ,qeFrom = [TRSimple "t"]+> }+> )+> ,("select a, sum(c+d) as s\n\+> \ from t,u\n\+> \ where a > 5\n\+> \ group by a\n\+> \ having count(1) > 5\n\+> \ order by s"+> ,makeSelect+> {qeSelectList = [(Nothing, Iden "a")+> ,(Just "s"+> ,App "sum" [BinOp (Iden "c")+> "+" (Iden "d")])]+> ,qeFrom = [TRSimple "t", TRSimple "u"]+> ,qeWhere = Just $ BinOp (Iden "a") ">" (NumLit "5")+> ,qeGroupBy = [Iden "a"]+> ,qeHaving = Just $ BinOp (App "count" [NumLit "1"])+> ">" (NumLit "5")+> ,qeOrderBy = [(Iden "s", Asc)]+> }+> )+> ]++> queryExprsParserTests :: TestItem+> queryExprsParserTests = Group "query exprs" $ map (uncurry TestQueryExprs)+> [("select 1",[ms])+> ,("select 1;",[ms])+> ,("select 1;select 1",[ms,ms])+> ,("select 1;select 1;",[ms,ms])+> ,(" select 1;select 1; ",[ms,ms])+> ]+> where+> ms = makeSelect {qeSelectList = [(Nothing,NumLit "1")]}++> tpchTests :: TestItem+> tpchTests =+> Group "parse tpch"+> $ map (ParseQueryExpr . snd) tpchQueries++> testData :: TestItem+> testData =+> Group "parserTest"+> [scalarExprParserTests+> ,queryExprParserTests+> ,queryExprsParserTests+> ,tpchTests+> ]++> tests :: Test.Framework.Test+> tests = itemToTest testData++> --runTests :: IO ()+> --runTests = void $ H.runTestTT $ itemToTest testData++> itemToTest :: TestItem -> Test.Framework.Test+> itemToTest (Group nm ts) =+> testGroup nm $ map itemToTest ts+> itemToTest (TestScalarExpr str expected) =+> toTest parseScalarExpr prettyScalarExpr str expected+> itemToTest (TestQueryExpr str expected) =+> toTest parseQueryExpr prettyQueryExpr str expected+> itemToTest (TestQueryExprs str expected) =+> toTest parseQueryExprs prettyQueryExprs str expected+> itemToTest (ParseQueryExpr str) =+> toPTest parseQueryExpr prettyQueryExpr str++> toTest :: (Eq a, Show a) =>+> (String -> Maybe (Int,Int) -> String -> Either ParseError a)+> -> (a -> String)+> -> String+> -> a+> -> Test.Framework.Test+> toTest parser pp str expected = testCase str $ do+> let egot = parser "" Nothing str+> case egot of+> Left e -> H.assertFailure $ peFormattedError e+> Right got -> do+> H.assertEqual "" expected got+> let str' = pp got+> let egot' = parser "" Nothing str'+> case egot' of+> Left e' -> H.assertFailure $ "pp roundtrip " ++ peFormattedError e'+> Right got' -> H.assertEqual "pp roundtrip" expected got'++> toPTest :: (Eq a, Show a) =>+> (String -> Maybe (Int,Int) -> String -> Either ParseError a)+> -> (a -> String)+> -> String+> -> Test.Framework.Test+> toPTest parser pp str = testCase str $ do+> let egot = parser "" Nothing str+> case egot of+> Left e -> H.assertFailure $ peFormattedError e+> Right got -> do+> let str' = pp got+> let egot' = parser "" Nothing str'+> case egot' of+> Left e' -> H.assertFailure $ "pp roundtrip " ++ peFormattedError e'+> Right _got' -> return ()
+ tools/RunTests.lhs view
@@ -0,0 +1,8 @@+++> import Test.Framework++> import Language.SQL.SimpleSQL.Tests++> main :: IO ()+> main = defaultMain [tests]
+ tools/Tpch.lhs view
@@ -0,0 +1,675 @@++test data for tpch queries+++> {-# LANGUAGE OverloadedStrings #-}++> module Tpch (tpchQueries) where+>++> tpchQueries :: [(String,String)]+> tpchQueries =+> [("Q1","\n\+> \select\n\+> \ l_returnflag,\n\+> \ l_linestatus,\n\+> \ sum(l_quantity) as sum_qty,\n\+> \ sum(l_extendedprice) as sum_base_price,\n\+> \ sum(l_extendedprice * (1 - l_discount)) as sum_disc_price,\n\+> \ sum(l_extendedprice * (1 - l_discount) * (1 + l_tax)) as sum_charge,\n\+> \ avg(l_quantity) as avg_qty,\n\+> \ avg(l_extendedprice) as avg_price,\n\+> \ avg(l_discount) as avg_disc,\n\+> \ count(*) as count_order\n\+> \from\n\+> \ lineitem\n\+> \where\n\+> \ l_shipdate <= date '1998-12-01' - interval '63' day (3)\n\+> \group by\n\+> \ l_returnflag,\n\+> \ l_linestatus\n\+> \order by\n\+> \ l_returnflag,\n\+> \ l_linestatus")+> ,("Q2","\n\+> \select\n\+> \ s_acctbal,\n\+> \ s_name,\n\+> \ n_name,\n\+> \ p_partkey,\n\+> \ p_mfgr,\n\+> \ s_address,\n\+> \ s_phone,\n\+> \ s_comment\n\+> \from\n\+> \ part,\n\+> \ supplier,\n\+> \ partsupp,\n\+> \ nation,\n\+> \ region\n\+> \where\n\+> \ p_partkey = ps_partkey\n\+> \ and s_suppkey = ps_suppkey\n\+> \ and p_size = 15\n\+> \ and p_type like '%BRASS'\n\+> \ and s_nationkey = n_nationkey\n\+> \ and n_regionkey = r_regionkey\n\+> \ and r_name = 'EUROPE'\n\+> \ and ps_supplycost = (\n\+> \ select\n\+> \ min(ps_supplycost)\n\+> \ from\n\+> \ partsupp,\n\+> \ supplier,\n\+> \ nation,\n\+> \ region\n\+> \ where\n\+> \ p_partkey = ps_partkey\n\+> \ and s_suppkey = ps_suppkey\n\+> \ and s_nationkey = n_nationkey\n\+> \ and n_regionkey = r_regionkey\n\+> \ and r_name = 'EUROPE'\n\+> \ )\n\+> \order by\n\+> \ s_acctbal desc,\n\+> \ n_name,\n\+> \ s_name,\n\+> \ p_partkey\n\+> \limit 100")+> ,("Q3","\n\+> \ select\n\+> \ l_orderkey,\n\+> \ sum(l_extendedprice * (1 - l_discount)) as revenue,\n\+> \ o_orderdate,\n\+> \ o_shippriority\n\+> \ from\n\+> \ customer,\n\+> \ orders,\n\+> \ lineitem\n\+> \ where\n\+> \ c_mktsegment = 'MACHINERY'\n\+> \ and c_custkey = o_custkey\n\+> \ and l_orderkey = o_orderkey\n\+> \ and o_orderdate < date '1995-03-21'\n\+> \ and l_shipdate > date '1995-03-21'\n\+> \ group by\n\+> \ l_orderkey,\n\+> \ o_orderdate,\n\+> \ o_shippriority\n\+> \ order by\n\+> \ revenue desc,\n\+> \ o_orderdate\n\+> \ limit 10")+> ,("Q4","\n\+> \ select\n\+> \ o_orderpriority,\n\+> \ count(*) as order_count\n\+> \ from\n\+> \ orders\n\+> \ where\n\+> \ o_orderdate >= date '1996-03-01'\n\+> \ and o_orderdate < date '1996-03-01' + interval '3' month\n\+> \ and exists (\n\+> \ select\n\+> \ *\n\+> \ from\n\+> \ lineitem\n\+> \ where\n\+> \ l_orderkey = o_orderkey\n\+> \ and l_commitdate < l_receiptdate\n\+> \ )\n\+> \ group by\n\+> \ o_orderpriority\n\+> \ order by\n\+> \ o_orderpriority")+> ,("Q5","\n\+> \ select\n\+> \ n_name,\n\+> \ sum(l_extendedprice * (1 - l_discount)) as revenue\n\+> \ from\n\+> \ customer,\n\+> \ orders,\n\+> \ lineitem,\n\+> \ supplier,\n\+> \ nation,\n\+> \ region\n\+> \ where\n\+> \ c_custkey = o_custkey\n\+> \ and l_orderkey = o_orderkey\n\+> \ and l_suppkey = s_suppkey\n\+> \ and c_nationkey = s_nationkey\n\+> \ and s_nationkey = n_nationkey\n\+> \ and n_regionkey = r_regionkey\n\+> \ and r_name = 'EUROPE'\n\+> \ and o_orderdate >= date '1997-01-01'\n\+> \ and o_orderdate < date '1997-01-01' + interval '1' year\n\+> \ group by\n\+> \ n_name\n\+> \ order by\n\+> \ revenue desc")+> ,("Q6","\n\+> \ select\n\+> \ sum(l_extendedprice * l_discount) as revenue\n\+> \ from\n\+> \ lineitem\n\+> \ where\n\+> \ l_shipdate >= date '1997-01-01'\n\+> \ and l_shipdate < date '1997-01-01' + interval '1' year\n\+> \ and l_discount between 0.07 - 0.01 and 0.07 + 0.01\n\+> \ and l_quantity < 24")+> ,("Q7","\n\+> \ select\n\+> \ supp_nation,\n\+> \ cust_nation,\n\+> \ l_year,\n\+> \ sum(volume) as revenue\n\+> \ from\n\+> \ (\n\+> \ select\n\+> \ n1.n_name as supp_nation,\n\+> \ n2.n_name as cust_nation,\n\+> \ extract(year from l_shipdate) as l_year,\n\+> \ l_extendedprice * (1 - l_discount) as volume\n\+> \ from\n\+> \ supplier,\n\+> \ lineitem,\n\+> \ orders,\n\+> \ customer,\n\+> \ nation n1,\n\+> \ nation n2\n\+> \ where\n\+> \ s_suppkey = l_suppkey\n\+> \ and o_orderkey = l_orderkey\n\+> \ and c_custkey = o_custkey\n\+> \ and s_nationkey = n1.n_nationkey\n\+> \ and c_nationkey = n2.n_nationkey\n\+> \ and (\n\+> \ (n1.n_name = 'PERU' and n2.n_name = 'IRAQ')\n\+> \ or (n1.n_name = 'IRAQ' and n2.n_name = 'PERU')\n\+> \ )\n\+> \ and l_shipdate between date '1995-01-01' and date '1996-12-31'\n\+> \ ) as shipping\n\+> \ group by\n\+> \ supp_nation,\n\+> \ cust_nation,\n\+> \ l_year\n\+> \ order by\n\+> \ supp_nation,\n\+> \ cust_nation,\n\+> \ l_year")+> ,("Q8","\n\+> \ select\n\+> \ o_year,\n\+> \ sum(case\n\+> \ when nation = 'IRAQ' then volume\n\+> \ else 0\n\+> \ end) / sum(volume) as mkt_share\n\+> \ from\n\+> \ (\n\+> \ select\n\+> \ extract(year from o_orderdate) as o_year,\n\+> \ l_extendedprice * (1 - l_discount) as volume,\n\+> \ n2.n_name as nation\n\+> \ from\n\+> \ part,\n\+> \ supplier,\n\+> \ lineitem,\n\+> \ orders,\n\+> \ customer,\n\+> \ nation n1,\n\+> \ nation n2,\n\+> \ region\n\+> \ where\n\+> \ p_partkey = l_partkey\n\+> \ and s_suppkey = l_suppkey\n\+> \ and l_orderkey = o_orderkey\n\+> \ and o_custkey = c_custkey\n\+> \ and c_nationkey = n1.n_nationkey\n\+> \ and n1.n_regionkey = r_regionkey\n\+> \ and r_name = 'MIDDLE EAST'\n\+> \ and s_nationkey = n2.n_nationkey\n\+> \ and o_orderdate between date '1995-01-01' and date '1996-12-31'\n\+> \ and p_type = 'STANDARD ANODIZED BRASS'\n\+> \ ) as all_nations\n\+> \ group by\n\+> \ o_year\n\+> \ order by\n\+> \ o_year")+> ,("Q9","\n\+> \ select\n\+> \ nation,\n\+> \ o_year,\n\+> \ sum(amount) as sum_profit\n\+> \ from\n\+> \ (\n\+> \ select\n\+> \ n_name as nation,\n\+> \ extract(year from o_orderdate) as o_year,\n\+> \ l_extendedprice * (1 - l_discount) - ps_supplycost * l_quantity as amount\n\+> \ from\n\+> \ part,\n\+> \ supplier,\n\+> \ lineitem,\n\+> \ partsupp,\n\+> \ orders,\n\+> \ nation\n\+> \ where\n\+> \ s_suppkey = l_suppkey\n\+> \ and ps_suppkey = l_suppkey\n\+> \ and ps_partkey = l_partkey\n\+> \ and p_partkey = l_partkey\n\+> \ and o_orderkey = l_orderkey\n\+> \ and s_nationkey = n_nationkey\n\+> \ and p_name like '%antique%'\n\+> \ ) as profit\n\+> \ group by\n\+> \ nation,\n\+> \ o_year\n\+> \ order by\n\+> \ nation,\n\+> \ o_year desc")+> ,("Q10","\n\+> \ select\n\+> \ c_custkey,\n\+> \ c_name,\n\+> \ sum(l_extendedprice * (1 - l_discount)) as revenue,\n\+> \ c_acctbal,\n\+> \ n_name,\n\+> \ c_address,\n\+> \ c_phone,\n\+> \ c_comment\n\+> \ from\n\+> \ customer,\n\+> \ orders,\n\+> \ lineitem,\n\+> \ nation\n\+> \ where\n\+> \ c_custkey = o_custkey\n\+> \ and l_orderkey = o_orderkey\n\+> \ and o_orderdate >= date '1993-12-01'\n\+> \ and o_orderdate < date '1993-12-01' + interval '3' month\n\+> \ and l_returnflag = 'R'\n\+> \ and c_nationkey = n_nationkey\n\+> \ group by\n\+> \ c_custkey,\n\+> \ c_name,\n\+> \ c_acctbal,\n\+> \ c_phone,\n\+> \ n_name,\n\+> \ c_address,\n\+> \ c_comment\n\+> \ order by\n\+> \ revenue desc\n\+> \ limit 20")+> ,("Q11","\n\+> \ select\n\+> \ ps_partkey,\n\+> \ sum(ps_supplycost * ps_availqty) as value\n\+> \ from\n\+> \ partsupp,\n\+> \ supplier,\n\+> \ nation\n\+> \ where\n\+> \ ps_suppkey = s_suppkey\n\+> \ and s_nationkey = n_nationkey\n\+> \ and n_name = 'CHINA'\n\+> \ group by\n\+> \ ps_partkey having\n\+> \ sum(ps_supplycost * ps_availqty) > (\n\+> \ select\n\+> \ sum(ps_supplycost * ps_availqty) * 0.0001000000\n\+> \ from\n\+> \ partsupp,\n\+> \ supplier,\n\+> \ nation\n\+> \ where\n\+> \ ps_suppkey = s_suppkey\n\+> \ and s_nationkey = n_nationkey\n\+> \ and n_name = 'CHINA'\n\+> \ )\n\+> \ order by\n\+> \ value desc")+> ,("Q12","\n\+> \ select\n\+> \ l_shipmode,\n\+> \ sum(case\n\+> \ when o_orderpriority = '1-URGENT'\n\+> \ or o_orderpriority = '2-HIGH'\n\+> \ then 1\n\+> \ else 0\n\+> \ end) as high_line_count,\n\+> \ sum(case\n\+> \ when o_orderpriority <> '1-URGENT'\n\+> \ and o_orderpriority <> '2-HIGH'\n\+> \ then 1\n\+> \ else 0\n\+> \ end) as low_line_count\n\+> \ from\n\+> \ orders,\n\+> \ lineitem\n\+> \ where\n\+> \ o_orderkey = l_orderkey\n\+> \ and l_shipmode in ('AIR', 'RAIL')\n\+> \ and l_commitdate < l_receiptdate\n\+> \ and l_shipdate < l_commitdate\n\+> \ and l_receiptdate >= date '1994-01-01'\n\+> \ and l_receiptdate < date '1994-01-01' + interval '1' year\n\+> \ group by\n\+> \ l_shipmode\n\+> \ order by\n\+> \ l_shipmode")+> ,("Q13","\n\+> \ select\n\+> \ c_count,\n\+> \ count(*) as custdist\n\+> \ from\n\+> \ (\n\+> \ select\n\+> \ c_custkey,\n\+> \ count(o_orderkey)\n\+> \ from\n\+> \ customer left outer join orders on\n\+> \ c_custkey = o_custkey\n\+> \ and o_comment not like '%pending%requests%'\n\+> \ group by\n\+> \ c_custkey\n\+> \ ) as c_orders (c_custkey, c_count)\n\+> \ group by\n\+> \ c_count\n\+> \ order by\n\+> \ custdist desc,\n\+> \ c_count desc")+> ,("Q14","\n\+> \ select\n\+> \ 100.00 * sum(case\n\+> \ when p_type like 'PROMO%'\n\+> \ then l_extendedprice * (1 - l_discount)\n\+> \ else 0\n\+> \ end) / sum(l_extendedprice * (1 - l_discount)) as promo_revenue\n\+> \ from\n\+> \ lineitem,\n\+> \ part\n\+> \ where\n\+> \ l_partkey = p_partkey\n\+> \ and l_shipdate >= date '1994-12-01'\n\+> \ and l_shipdate < date '1994-12-01' + interval '1' month")+> ,("Q15","\n\+> \ /*create view revenue0 (supplier_no, total_revenue) as\n\+> \ select\n\+> \ l_suppkey,\n\+> \ sum(l_extendedprice * (1 - l_discount))\n\+> \ from\n\+> \ lineitem\n\+> \ where\n\+> \ l_shipdate >= date '1995-06-01'\n\+> \ and l_shipdate < date '1995-06-01' + interval '3' month\n\+> \ group by\n\+> \ l_suppkey;*/\n\+> \ with\n\+> \ revenue0 as\n\+> \ (select\n\+> \ l_suppkey as supplier_no,\n\+> \ sum(l_extendedprice * (1 - l_discount)) as total_revenue\n\+> \ from\n\+> \ lineitem\n\+> \ where\n\+> \ l_shipdate >= date '1995-06-01'\n\+> \ and l_shipdate < date '1995-06-01' + interval '3' month\n\+> \ group by\n\+> \ l_suppkey)\n\+> \ select\n\+> \ s_suppkey,\n\+> \ s_name,\n\+> \ s_address,\n\+> \ s_phone,\n\+> \ total_revenue\n\+> \ from\n\+> \ supplier,\n\+> \ revenue0\n\+> \ where\n\+> \ s_suppkey = supplier_no\n\+> \ and total_revenue = (\n\+> \ select\n\+> \ max(total_revenue)\n\+> \ from\n\+> \ revenue0\n\+> \ )\n\+> \ order by\n\+> \ s_suppkey")+> ,("Q16","\n\+> \ select\n\+> \ p_brand,\n\+> \ p_type,\n\+> \ p_size,\n\+> \ count(distinct ps_suppkey) as supplier_cnt\n\+> \ from\n\+> \ partsupp,\n\+> \ part\n\+> \ where\n\+> \ p_partkey = ps_partkey\n\+> \ and p_brand <> 'Brand#15'\n\+> \ and p_type not like 'MEDIUM BURNISHED%'\n\+> \ and p_size in (39, 26, 18, 45, 19, 1, 3, 9)\n\+> \ and ps_suppkey not in (\n\+> \ select\n\+> \ s_suppkey\n\+> \ from\n\+> \ supplier\n\+> \ where\n\+> \ s_comment like '%Customer%Complaints%'\n\+> \ )\n\+> \ group by\n\+> \ p_brand,\n\+> \ p_type,\n\+> \ p_size\n\+> \ order by\n\+> \ supplier_cnt desc,\n\+> \ p_brand,\n\+> \ p_type,\n\+> \ p_size")+> ,("Q17","\n\+> \ select\n\+> \ sum(l_extendedprice) / 7.0 as avg_yearly\n\+> \ from\n\+> \ lineitem,\n\+> \ part\n\+> \ where\n\+> \ p_partkey = l_partkey\n\+> \ and p_brand = 'Brand#52'\n\+> \ and p_container = 'JUMBO CAN'\n\+> \ and l_quantity < (\n\+> \ select\n\+> \ 0.2 * avg(l_quantity)\n\+> \ from\n\+> \ lineitem\n\+> \ where\n\+> \ l_partkey = p_partkey\n\+> \ )")+> ,("Q18","\n\+> \ select\n\+> \ c_name,\n\+> \ c_custkey,\n\+> \ o_orderkey,\n\+> \ o_orderdate,\n\+> \ o_totalprice,\n\+> \ sum(l_quantity)\n\+> \ from\n\+> \ customer,\n\+> \ orders,\n\+> \ lineitem\n\+> \ where\n\+> \ o_orderkey in (\n\+> \ select\n\+> \ l_orderkey\n\+> \ from\n\+> \ lineitem\n\+> \ group by\n\+> \ l_orderkey having\n\+> \ sum(l_quantity) > 313\n\+> \ )\n\+> \ and c_custkey = o_custkey\n\+> \ and o_orderkey = l_orderkey\n\+> \ group by\n\+> \ c_name,\n\+> \ c_custkey,\n\+> \ o_orderkey,\n\+> \ o_orderdate,\n\+> \ o_totalprice\n\+> \ order by\n\+> \ o_totalprice desc,\n\+> \ o_orderdate\n\+> \ limit 100")+> ,("Q19","\n\+> \ select\n\+> \ sum(l_extendedprice* (1 - l_discount)) as revenue\n\+> \ from\n\+> \ lineitem,\n\+> \ part\n\+> \ where\n\+> \ (\n\+> \ p_partkey = l_partkey\n\+> \ and p_brand = 'Brand#43'\n\+> \ and p_container in ('SM CASE', 'SM BOX', 'SM PACK', 'SM PKG')\n\+> \ and l_quantity >= 3 and l_quantity <= 3 + 10\n\+> \ and p_size between 1 and 5\n\+> \ and l_shipmode in ('AIR', 'AIR REG')\n\+> \ and l_shipinstruct = 'DELIVER IN PERSON'\n\+> \ )\n\+> \ or\n\+> \ (\n\+> \ p_partkey = l_partkey\n\+> \ and p_brand = 'Brand#25'\n\+> \ and p_container in ('MED BAG', 'MED BOX', 'MED PKG', 'MED PACK')\n\+> \ and l_quantity >= 10 and l_quantity <= 10 + 10\n\+> \ and p_size between 1 and 10\n\+> \ and l_shipmode in ('AIR', 'AIR REG')\n\+> \ and l_shipinstruct = 'DELIVER IN PERSON'\n\+> \ )\n\+> \ or\n\+> \ (\n\+> \ p_partkey = l_partkey\n\+> \ and p_brand = 'Brand#24'\n\+> \ and p_container in ('LG CASE', 'LG BOX', 'LG PACK', 'LG PKG')\n\+> \ and l_quantity >= 22 and l_quantity <= 22 + 10\n\+> \ and p_size between 1 and 15\n\+> \ and l_shipmode in ('AIR', 'AIR REG')\n\+> \ and l_shipinstruct = 'DELIVER IN PERSON'\n\+> \ )")+> ,("Q20","\n\+> \ select\n\+> \ s_name,\n\+> \ s_address\n\+> \ from\n\+> \ supplier,\n\+> \ nation\n\+> \ where\n\+> \ s_suppkey in (\n\+> \ select\n\+> \ ps_suppkey\n\+> \ from\n\+> \ partsupp\n\+> \ where\n\+> \ ps_partkey in (\n\+> \ select\n\+> \ p_partkey\n\+> \ from\n\+> \ part\n\+> \ where\n\+> \ p_name like 'lime%'\n\+> \ )\n\+> \ and ps_availqty > (\n\+> \ select\n\+> \ 0.5 * sum(l_quantity)\n\+> \ from\n\+> \ lineitem\n\+> \ where\n\+> \ l_partkey = ps_partkey\n\+> \ and l_suppkey = ps_suppkey\n\+> \ and l_shipdate >= date '1994-01-01'\n\+> \ and l_shipdate < date '1994-01-01' + interval '1' year\n\+> \ )\n\+> \ )\n\+> \ and s_nationkey = n_nationkey\n\+> \ and n_name = 'VIETNAM'\n\+> \ order by\n\+> \ s_name")+> ,("Q21","\n\+> \ select\n\+> \ s_name,\n\+> \ count(*) as numwait\n\+> \ from\n\+> \ supplier,\n\+> \ lineitem l1,\n\+> \ orders,\n\+> \ nation\n\+> \ where\n\+> \ s_suppkey = l1.l_suppkey\n\+> \ and o_orderkey = l1.l_orderkey\n\+> \ and o_orderstatus = 'F'\n\+> \ and l1.l_receiptdate > l1.l_commitdate\n\+> \ and exists (\n\+> \ select\n\+> \ *\n\+> \ from\n\+> \ lineitem l2\n\+> \ where\n\+> \ l2.l_orderkey = l1.l_orderkey\n\+> \ and l2.l_suppkey <> l1.l_suppkey\n\+> \ )\n\+> \ and not exists (\n\+> \ select\n\+> \ *\n\+> \ from\n\+> \ lineitem l3\n\+> \ where\n\+> \ l3.l_orderkey = l1.l_orderkey\n\+> \ and l3.l_suppkey <> l1.l_suppkey\n\+> \ and l3.l_receiptdate > l3.l_commitdate\n\+> \ )\n\+> \ and s_nationkey = n_nationkey\n\+> \ and n_name = 'INDIA'\n\+> \ group by\n\+> \ s_name\n\+> \ order by\n\+> \ numwait desc,\n\+> \ s_name\n\+> \ limit 100")+> ,("Q22","\n\+> \ select\n\+> \ cntrycode,\n\+> \ count(*) as numcust,\n\+> \ sum(c_acctbal) as totacctbal\n\+> \ from\n\+> \ (\n\+> \ select\n\+> \ substring(c_phone from 1 for 2) as cntrycode,\n\+> \ c_acctbal\n\+> \ from\n\+> \ customer\n\+> \ where\n\+> \ substring(c_phone from 1 for 2) in\n\+> \ ('41', '28', '39', '21', '24', '29', '44')\n\+> \ and c_acctbal > (\n\+> \ select\n\+> \ avg(c_acctbal)\n\+> \ from\n\+> \ customer\n\+> \ where\n\+> \ c_acctbal > 0.00\n\+> \ and substring(c_phone from 1 for 2) in\n\+> \ ('41', '28', '39', '21', '24', '29', '44')\n\+> \ )\n\+> \ and not exists (\n\+> \ select\n\+> \ *\n\+> \ from\n\+> \ orders\n\+> \ where\n\+> \ o_custkey = c_custkey\n\+> \ )\n\+> \ ) as custsale\n\+> \ group by\n\+> \ cntrycode\n\+> \ order by\n\+> \ cntrycode")+> ]