simple-sql-parser 0.4.0 → 0.4.1
raw patch · 18 files changed
+443/−279 lines, 18 filesdep ~base
Dependency ranges changed: base
Files
- Language/SQL/SimpleSQL/Combinators.lhs +7/−5
- Language/SQL/SimpleSQL/Parser.lhs +76/−32
- Language/SQL/SimpleSQL/Pretty.lhs +144/−129
- Language/SQL/SimpleSQL/Syntax.lhs +21/−1
- changelog +6/−1
- simple-sql-parser.cabal +5/−4
- tools/Language/SQL/SimpleSQL/FullQueries.lhs +1/−1
- tools/Language/SQL/SimpleSQL/GroupBy.lhs +3/−3
- tools/Language/SQL/SimpleSQL/MySQL.lhs +40/−0
- tools/Language/SQL/SimpleSQL/Postgres.lhs +1/−2
- tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs +10/−10
- tools/Language/SQL/SimpleSQL/QueryExprs.lhs +1/−1
- tools/Language/SQL/SimpleSQL/SQL2011.lhs +48/−48
- tools/Language/SQL/SimpleSQL/TableRefs.lhs +1/−1
- tools/Language/SQL/SimpleSQL/TestTypes.lhs +17/−5
- tools/Language/SQL/SimpleSQL/Tests.lhs +46/−20
- tools/Language/SQL/SimpleSQL/Tpch.lhs +1/−1
- tools/Language/SQL/SimpleSQL/ValueExprs.lhs +15/−15
Language/SQL/SimpleSQL/Combinators.lhs view
@@ -17,8 +17,10 @@ > import Control.Applicative ((<$>), (<*>), (<**>), pure, Applicative) > import Text.Parsec (option,many)-> import Text.Parsec.String (Parser)+> import Text.Parsec.Prim (Parsec) +> type Parser s = Parsec String s+ 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@@ -27,7 +29,7 @@ This function style is not good, and should be replaced with chain and <??> which has a different type -> optionSuffix :: (a -> Parser a) -> a -> Parser a+> optionSuffix :: (a -> Parser s a) -> a -> Parser s a > optionSuffix p a = option a (p a) @@ -37,7 +39,7 @@ TODO: make sure the precedence higher than <|> and lower than the other operators so it can be used nicely -> (<??>) :: Parser a -> Parser (a -> a) -> Parser a+> (<??>) :: Parser s a -> Parser s (a -> a) -> Parser s a > p <??> q = p <**> option id q @@ -78,7 +80,7 @@ a second or more suffix parser contingent on the first suffix parser succeeding. -> (<??.>) :: Parser (a -> a) -> Parser (a -> a) -> Parser (a -> a)+> (<??.>) :: Parser s (a -> a) -> Parser s (a -> a) -> Parser s (a -> a) > (<??.>) pa pb = (.) `c` pa <*> option id pb > -- todo: fix this mess > where c = (<$>) . flip@@ -86,7 +88,7 @@ 0 to many repeated applications of suffix parser -> (<??*>) :: Parser a -> Parser (a -> a) -> Parser a+> (<??*>) :: Parser s a -> Parser s (a -> a) -> Parser s a > p <??*> q = foldr ($) <$> p <*> (reverse <$> many q)
Language/SQL/SimpleSQL/Parser.lhs view
@@ -190,10 +190,11 @@ > import Text.Parsec (setPosition,setSourceColumn,setSourceLine,getPosition > ,option,between,sepBy,sepBy1,string,manyTill,anyChar > ,try,string,many1,oneOf,digit,(<|>),choice,char,eof-> ,optionMaybe,optional,many,letter,parse+> ,optionMaybe,optional,many,letter,runParser > ,chainl1, chainr1,(<?>) {-,notFollowedBy,alphaNum-}, lookAhead)-> import Text.Parsec.String (Parser)+> -- import Text.Parsec.String (Parser) > import Text.Parsec.Perm (permute,(<$?>), (<|?>))+> import Text.Parsec.Prim (Parsec, getState) > import qualified Text.Parsec.Expr as E > import Data.List (intercalate,sort,groupBy) > import Data.Function (on)@@ -204,11 +205,13 @@ = Public API > -- | Parses a query expr, trailing semicolon optional.-> parseQueryExpr :: FilePath-> -- ^ filename to use in errors+> parseQueryExpr :: Dialect+> -- ^ dialect of SQL to use+> -> FilePath+> -- ^ filename to use in error messages > -> Maybe (Int,Int) > -- ^ line number and column number of the first character-> -- in the source (to use in errors)+> -- in the source to use in error messages > -> String > -- ^ the SQL source to parse > -> Either ParseError QueryExpr@@ -216,22 +219,26 @@ > -- | Parses a list of query expressions, with semi colons between > -- them. The final semicolon is optional.-> parseQueryExprs :: FilePath-> -- ^ filename to use in errors+> parseQueryExprs :: Dialect+> -- ^ dialect of SQL to use+> -> FilePath+> -- ^ filename to use in error messages > -> Maybe (Int,Int) > -- ^ line number and column number of the first character-> -- in the source (to use in errors)+> -- in the source to use in error messages > -> String > -- ^ the SQL source to parse > -> Either ParseError [QueryExpr] > parseQueryExprs = wrapParse queryExprs > -- | Parses a value expression.-> parseValueExpr :: FilePath-> -- ^ filename to use in errors+> parseValueExpr :: Dialect+> -- ^ dialect of SQL to use+> -> FilePath+> -- ^ filename to use in error messages > -> Maybe (Int,Int) > -- ^ line number and column number of the first character-> -- in the source (to use in errors)+> -- in the source to use in error messages > -> String > -- ^ the SQL source to parse > -> Either ParseError ValueExpr@@ -245,19 +252,20 @@ converts the error return to the nice wrapper > wrapParse :: Parser a+> -> Dialect > -> FilePath > -> Maybe (Int,Int) > -> String > -> Either ParseError a-> wrapParse parser f p src =+> wrapParse parser d f p src = > either (Left . convParseError src) Right-> $ parse (setPos p *> whitespace *> parser <* eof) f src+> $ runParser (setPos p *> whitespace *> parser <* eof)+> d f src > where > setPos Nothing = pure () > setPos (Just (l,c)) = fmap up getPosition >>= setPosition > where up = flip setSourceColumn c . flip setSourceLine l - ------------------------------------------------ = Names@@ -294,9 +302,17 @@ u&"example quoted" > name :: Parser Name-> name = choice [QName <$> quotedIdentifier-> ,UQName <$> uquotedIdentifier-> ,Name <$> identifierBlacklist blacklist]+> name = do+> d <- getState+> choice [QName <$> quotedIdentifier+> ,UQName <$> uquotedIdentifier+> ,Name <$> identifierBlacklist (blacklist d)+> ,dqName]+> where+> dqName = guardDialect [MySQL] *>+> lexeme (DQName "`" "`"+> <$> (char '`'+> *> manyTill anyChar (char '`'))) todo: replace (:[]) with a named function all over @@ -1002,7 +1018,7 @@ wanted to avoid extensibility and to not be concerned with parse error messages, but both of these are too important. -> opTable :: Bool -> [[E.Operator String () Identity ValueExpr]]+> opTable :: Bool -> [[E.Operator String ParseState Identity ValueExpr]] > opTable bExpr = > [-- parse match and quantified comparisons as postfix ops > -- todo: left factor the quantified comparison with regular@@ -1184,6 +1200,10 @@ tref [on expr | using (...)] +TODO: either use explicit 'operator precedence' parsers or build+expression parser for the 'tref operators' such as joins, lateral,+aliases.+ > from :: Parser [TableRef] > from = keyword_ "from" *> commaSep1 tref > where@@ -1289,10 +1309,15 @@ > ,keyword_ "row"]) > fetch :: Parser ValueExpr-> fetch = fs *> valueExpr <* ro+> fetch = fetchFirst <|> limit > where+> fetchFirst = guardDialect [SQL2011]+> *> fs *> valueExpr <* ro > fs = makeKeywordTree ["fetch first", "fetch next"] > ro = makeKeywordTree ["rows only", "row only"]+> -- todo: not in ansi sql dialect+> limit = guardDialect [MySQL] *>+> keyword_ "limit" *> valueExpr == common table expressions @@ -1619,17 +1644,8 @@ > pure i) > <?> "identifier" -> blacklist :: [String]-> blacklist = reservedWord {--> [-- case-> "case", "when", "then", "else", "end"-> ,--join-> "natural","inner","outer","cross","left","right","full","join"-> ,"on","using","lateral"-> ,"from","where","group","having","order","limit", "offset", "fetch"-> ,"as","in"-> ,"except", "intersect", "union"-> ] -}+> blacklist :: Dialect -> [String]+> blacklist = reservedWord 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@@ -1645,8 +1661,8 @@ keywords (I'm not sure what exactly being an unreserved keyword means). -> reservedWord :: [String]-> reservedWord =+> reservedWord :: Dialect -> [String]+> reservedWord SQL2011 = > ["abs" > --,"all" > ,"allocate"@@ -1972,3 +1988,31 @@ > ,"without" > --,"year" > ]++TODO: create this list properly++> reservedWord MySQL = reservedWord SQL2011 ++ ["limit"]+++-----------++bit hacky, used to make the dialect available during parsing so+different parsers can be used for different dialects++> type ParseState = Dialect++> type Parser = Parsec String ParseState++> guardDialect :: [Dialect] -> Parser ()+> guardDialect ds = do+> d <- getState+> guard (d `elem` ds)++TODO: the ParseState and the Dialect argument should be turned into a+flags struct. Part (or all?) of this struct is the dialect+information, but each dialect has different versions + a big set of+flags to control syntax variations within a version of a product+dialect (for instance, string and identifier parsing rules vary from+dialect to dialect and version to version, and most or all SQL DBMSs+appear to have a set of flags to further enable or disable variations+for quoting and escaping strings and identifiers).
Language/SQL/SimpleSQL/Pretty.lhs view
@@ -19,65 +19,65 @@ > import Data.List (intercalate) > -- | Convert a query expr ast to concrete syntax.-> prettyQueryExpr :: QueryExpr -> String-> prettyQueryExpr = render . queryExpr+> prettyQueryExpr :: Dialect -> QueryExpr -> String+> prettyQueryExpr d = render . queryExpr d > -- | Convert a value expr ast to concrete syntax.-> prettyValueExpr :: ValueExpr -> String-> prettyValueExpr = render . valueExpr+> prettyValueExpr :: Dialect -> ValueExpr -> String+> prettyValueExpr d = render . valueExpr d > -- | 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)+> prettyQueryExprs :: Dialect -> [QueryExpr] -> String+> prettyQueryExprs d = render . vcat . map ((<> text ";\n") . queryExpr d) = value expressions -> valueExpr :: ValueExpr -> Doc-> valueExpr (StringLit s) = quotes $ text $ doubleUpQuotes s+> valueExpr :: Dialect -> ValueExpr -> Doc+> valueExpr _ (StringLit s) = quotes $ text $ doubleUpQuotes s -> valueExpr (NumLit s) = text s-> valueExpr (IntervalLit s v f t) =+> valueExpr _ (NumLit s) = text s+> valueExpr _ (IntervalLit s v f t) = > text "interval" > <+> me (\x -> if x then text "+" else text "-") s > <+> quotes (text v) > <+> intervalTypeField f > <+> me (\x -> text "to" <+> intervalTypeField x) t-> valueExpr (Iden i) = names i-> valueExpr Star = text "*"-> valueExpr Parameter = text "?"-> valueExpr (HostParameter p i) =+> valueExpr _ (Iden i) = names i+> valueExpr _ Star = text "*"+> valueExpr _ Parameter = text "?"+> valueExpr _ (HostParameter p i) = > text (':':p) > <+> me (\i' -> text "indicator" <+> text (':':i')) i -> valueExpr (App f es) = names f <> parens (commaSep (map valueExpr es))+> valueExpr d (App f es) = names f <> parens (commaSep (map (valueExpr d) es)) -> valueExpr (AggregateApp f d es od fil) =+> valueExpr dia (AggregateApp f d es od fil) = > names f > <> parens ((case d of > Distinct -> text "distinct" > All -> text "all" > SQDefault -> empty)-> <+> commaSep (map valueExpr es)-> <+> orderBy od)+> <+> commaSep (map (valueExpr dia) es)+> <+> orderBy dia od) > <+> me (\x -> text "filter"-> <+> parens (text "where" <+> valueExpr x)) fil+> <+> parens (text "where" <+> valueExpr dia x)) fil -> valueExpr (AggregateAppGroup f es od) =+> valueExpr d (AggregateAppGroup f es od) = > names f-> <> parens (commaSep (map valueExpr es))+> <> parens (commaSep (map (valueExpr d) es)) > <+> if null od > then empty-> else text "within group" <+> parens(orderBy od)+> else text "within group" <+> parens (orderBy d od) -> valueExpr (WindowApp f es pb od fr) =-> names f <> parens (commaSep $ map valueExpr es)+> valueExpr d (WindowApp f es pb od fr) =+> names f <> parens (commaSep $ map (valueExpr d) es) > <+> text "over" > <+> parens ((case pb of > [] -> empty > _ -> text "partition by"-> <+> nest 13 (commaSep $ map valueExpr pb))-> <+> orderBy od+> <+> nest 13 (commaSep $ map (valueExpr d) pb))+> <+> orderBy d od > <+> me frd fr) > where > frd (FrameFrom rs fp) = rsd rs <+> fpd fp@@ -90,109 +90,109 @@ > fpd UnboundedPreceding = text "unbounded preceding" > fpd UnboundedFollowing = text "unbounded following" > fpd Current = text "current row"-> fpd (Preceding e) = valueExpr e <+> text "preceding"-> fpd (Following e) = valueExpr e <+> text "following"+> fpd (Preceding e) = valueExpr d e <+> text "preceding"+> fpd (Following e) = valueExpr d e <+> text "following" -> valueExpr (SpecialOp nm [a,b,c]) | nm `elem` [[Name "between"]-> ,[Name "not between"]] =-> sep [valueExpr a-> ,names nm <+> valueExpr b-> ,nest (length (unnames nm) + 1) $ text "and" <+> valueExpr c]+> valueExpr dia (SpecialOp nm [a,b,c]) | nm `elem` [[Name "between"]+> ,[Name "not between"]] =+> sep [valueExpr dia a+> ,names nm <+> valueExpr dia b+> ,nest (length (unnames nm) + 1) $ text "and" <+> valueExpr dia c] -> valueExpr (SpecialOp [Name "rowctor"] as) =-> parens $ commaSep $ map valueExpr as+> valueExpr d (SpecialOp [Name "rowctor"] as) =+> parens $ commaSep $ map (valueExpr d) as -> valueExpr (SpecialOp nm es) =-> names nm <+> parens (commaSep $ map valueExpr es)+> valueExpr d (SpecialOp nm es) =+> names nm <+> parens (commaSep $ map (valueExpr d) es) -> valueExpr (SpecialOpK nm fs as) =+> valueExpr d (SpecialOpK nm fs as) = > names nm <> parens (sep $ catMaybes-> (fmap valueExpr fs-> : map (\(n,e) -> Just (text n <+> valueExpr e)) as))+> (fmap (valueExpr d) fs+> : map (\(n,e) -> Just (text n <+> valueExpr d e)) as)) -> valueExpr (PrefixOp f e) = names f <+> valueExpr e-> valueExpr (PostfixOp f e) = valueExpr e <+> names f-> valueExpr e@(BinOp _ op _) | op `elem` [[Name "and"], [Name "or"]] =+> valueExpr d (PrefixOp f e) = names f <+> valueExpr d e+> valueExpr d (PostfixOp f e) = valueExpr d e <+> names f+> valueExpr d e@(BinOp _ op _) | op `elem` [[Name "and"], [Name "or"]] = > -- special case for and, or, get all the ands so we can vcat them > -- nicely > case ands e of-> (e':es) -> vcat (valueExpr e'-> : map ((names op <+>) . valueExpr) es)+> (e':es) -> vcat (valueExpr d e'+> : map ((names op <+>) . valueExpr d) es) > [] -> empty -- shouldn't be possible > where > ands (BinOp a op' b) | op == op' = ands a ++ ands b > ands x = [x] > -- special case for . we don't use whitespace-> valueExpr (BinOp e0 [Name "."] e1) =-> valueExpr e0 <> text "." <> valueExpr e1-> valueExpr (BinOp e0 f e1) =-> valueExpr e0 <+> names f <+> valueExpr e1+> valueExpr d (BinOp e0 [Name "."] e1) =+> valueExpr d e0 <> text "." <> valueExpr d e1+> valueExpr d (BinOp e0 f e1) =+> valueExpr d e0 <+> names f <+> valueExpr d e1 -> valueExpr (Case t ws els) =-> sep $ [text "case" <+> me valueExpr t]+> valueExpr dia (Case t ws els) =+> sep $ [text "case" <+> me (valueExpr dia) t] > ++ map w ws > ++ maybeToList (fmap e els) > ++ [text "end"] > where > w (t0,t1) =-> text "when" <+> nest 5 (commaSep $ map valueExpr t0)-> <+> text "then" <+> nest 5 (valueExpr t1)-> e el = text "else" <+> nest 5 (valueExpr el)-> valueExpr (Parens e) = parens $ valueExpr e-> valueExpr (Cast e tn) =-> text "cast" <> parens (sep [valueExpr e+> text "when" <+> nest 5 (commaSep $ map (valueExpr dia) t0)+> <+> text "then" <+> nest 5 (valueExpr dia t1)+> e el = text "else" <+> nest 5 (valueExpr dia el)+> valueExpr d (Parens e) = parens $ valueExpr d e+> valueExpr d (Cast e tn) =+> text "cast" <> parens (sep [valueExpr d e > ,text "as" > ,typeName tn]) -> valueExpr (TypedLit tn s) =+> valueExpr _ (TypedLit tn s) = > typeName tn <+> quotes (text s) -> valueExpr (SubQueryExpr ty qe) =+> valueExpr d (SubQueryExpr ty qe) = > (case ty of > SqSq -> empty > SqExists -> text "exists" > SqUnique -> text "unique"-> ) <+> parens (queryExpr qe)+> ) <+> parens (queryExpr d qe) -> valueExpr (QuantifiedComparison v c cp sq) =-> valueExpr v+> valueExpr d (QuantifiedComparison v c cp sq) =+> valueExpr d v > <+> names c > <+> (text $ case cp of > CPAny -> "any" > CPSome -> "some" > CPAll -> "all")-> <+> parens (queryExpr sq)+> <+> parens (queryExpr d sq) -> valueExpr (Match v u sq) =-> valueExpr v+> valueExpr d (Match v u sq) =+> valueExpr d v > <+> text "match" > <+> (if u then text "unique" else empty)-> <+> parens (queryExpr sq)+> <+> parens (queryExpr d sq) -> valueExpr (In b se x) =-> valueExpr se <+>+> valueExpr d (In b se x) =+> valueExpr d 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 valueExpr es-> InQueryExpr qe -> queryExpr qe)+> InList es -> commaSep $ map (valueExpr d) es+> InQueryExpr qe -> queryExpr d qe) -> valueExpr (Array v es) =-> valueExpr v <> brackets (commaSep $ map valueExpr es)+> valueExpr d (Array v es) =+> valueExpr d v <> brackets (commaSep $ map (valueExpr d) es) -> valueExpr (ArrayCtor q) =-> text "array" <> parens (queryExpr q)+> valueExpr d (ArrayCtor q) =+> text "array" <> parens (queryExpr d q) -> valueExpr (MultisetCtor es) =-> text "multiset" <> brackets (commaSep $ map valueExpr es)+> valueExpr d (MultisetCtor es) =+> text "multiset" <> brackets (commaSep $ map (valueExpr d) es) -> valueExpr (MultisetQueryCtor q) =-> text "multiset" <> parens (queryExpr q)+> valueExpr d (MultisetQueryCtor q) =+> text "multiset" <> parens (queryExpr d q) -> valueExpr (MultisetBinOp a c q b) =+> valueExpr d (MultisetBinOp a c q b) = > sep-> [valueExpr a+> [valueExpr d a > ,text "multiset" > ,text $ case c of > Union -> "union"@@ -202,25 +202,27 @@ > SQDefault -> empty > All -> text "all" > Distinct -> text "distinct"-> ,valueExpr b]+> ,valueExpr d b] -> valueExpr (CSStringLit cs st) =+> valueExpr _ (CSStringLit cs st) = > text cs <> quotes (text $ doubleUpQuotes st) -> valueExpr (Escape v e) =-> valueExpr v <+> text "escape" <+> text [e]+> valueExpr d (Escape v e) =+> valueExpr d v <+> text "escape" <+> text [e] -> valueExpr (UEscape v e) =-> valueExpr v <+> text "uescape" <+> text [e]+> valueExpr d (UEscape v e) =+> valueExpr d v <+> text "uescape" <+> text [e] -> valueExpr (Collate v c) =-> valueExpr v <+> text "collate" <+> names c+> valueExpr d (Collate v c) =+> valueExpr d v <+> text "collate" <+> names c -> valueExpr (NextValueFor ns) =+> valueExpr _ (NextValueFor ns) = > text "next value for" <+> names ns +> valueExpr d (VEComment cmt v) =+> vcat $ map comment cmt ++ [valueExpr d v] > doubleUpQuotes :: String -> String > doubleUpQuotes [] = []@@ -238,6 +240,7 @@ > unname (QName n) = "\"" ++ doubleUpDoubleQuotes n ++ "\"" > unname (UQName n) = "U&\"" ++ doubleUpDoubleQuotes n ++ "\"" > unname (Name n) = n+> unname (DQName s e n) = s ++ n ++ e > unnames :: [Name] -> String > unnames ns = intercalate "." $ map unname ns@@ -248,6 +251,7 @@ > name (UQName n) = > text "U&" <> doubleQuotes (text $ doubleUpDoubleQuotes n) > name (Name n) = text n+> name (DQName s e n) = text s <> text n <> text e > names :: [Name] -> Doc > names ns = hcat $ punctuate (text ".") $ map name ns@@ -309,25 +313,31 @@ = query expressions -> queryExpr :: QueryExpr -> Doc-> queryExpr (Select d sl fr wh gb hv od off fe) =+> queryExpr :: Dialect -> QueryExpr -> Doc+> queryExpr dia (Select d sl fr wh gb hv od off fe) = > sep [text "select" > ,case d of > SQDefault -> empty > All -> text "all" > Distinct -> text "distinct"-> ,nest 7 $ sep [selectList sl]-> ,from fr-> ,maybeValueExpr "where" wh-> ,grpBy gb-> ,maybeValueExpr "having" hv-> ,orderBy od-> ,me (\e -> text "offset" <+> valueExpr e <+> text "rows") off-> ,me (\e -> text "fetch first" <+> valueExpr e-> <+> text "rows only") fe+> ,nest 7 $ sep [selectList dia sl]+> ,from dia fr+> ,maybeValueExpr dia "where" wh+> ,grpBy dia gb+> ,maybeValueExpr dia "having" hv+> ,orderBy dia od+> ,me (\e -> text "offset" <+> valueExpr dia e <+> text "rows") off+> ,fetchFirst > ]-> queryExpr (CombineQueryExpr q1 ct d c q2) =-> sep [queryExpr q1+> where+> fetchFirst =+> me (\e -> if dia == MySQL+> then text "limit" <+> valueExpr dia e+> else text "fetch first" <+> valueExpr dia e+> <+> text "rows only") fe++> queryExpr dia (CombineQueryExpr q1 ct d c q2) =+> sep [queryExpr dia q1 > ,text (case ct of > Union -> "union" > Intersect -> "intersect"@@ -339,17 +349,19 @@ > <+> case c of > Corresponding -> text "corresponding" > Respectively -> empty-> ,queryExpr q2]-> queryExpr (With rc withs qe) =+> ,queryExpr dia q2]+> queryExpr d (With rc withs qe) = > text "with" <+> (if rc then text "recursive" else empty) > <+> vcat [nest 5 > (vcat $ punctuate comma $ flip map withs $ \(n,q) ->-> alias n <+> text "as" <+> parens (queryExpr q))-> ,queryExpr qe]-> queryExpr (Values vs) =+> alias n <+> text "as" <+> parens (queryExpr d q))+> ,queryExpr d qe]+> queryExpr d (Values vs) = > text "values"-> <+> nest 7 (commaSep (map (parens . commaSep . map valueExpr) vs))-> queryExpr (Table t) = text "table" <+> names t+> <+> nest 7 (commaSep (map (parens . commaSep . map (valueExpr d)) vs))+> queryExpr _ (Table t) = text "table" <+> names t+> queryExpr d (QEComment cmt v) =+> vcat $ map comment cmt ++ [queryExpr d v] > alias :: Alias -> Doc@@ -357,25 +369,25 @@ > text "as" <+> name nm > <+> me (parens . commaSep . map name) cols -> selectList :: [(ValueExpr,Maybe Name)] -> Doc-> selectList is = commaSep $ map si is+> selectList :: Dialect -> [(ValueExpr,Maybe Name)] -> Doc+> selectList d is = commaSep $ map si is > where-> si (e,al) = valueExpr e <+> me als al+> si (e,al) = valueExpr d e <+> me als al > als al = text "as" <+> name al -> from :: [TableRef] -> Doc-> from [] = empty-> from ts =+> from :: Dialect -> [TableRef] -> Doc+> from _ [] = empty+> from d ts = > sep [text "from" > ,nest 5 $ vcat $ punctuate comma $ map tr ts] > where > tr (TRSimple t) = names t > tr (TRLateral t) = text "lateral" <+> tr t > tr (TRFunction f as) =-> names f <> parens (commaSep $ map valueExpr as)+> names f <> parens (commaSep $ map (valueExpr d) as) > tr (TRAlias t a) = sep [tr t, alias a] > tr (TRParens t) = parens $ tr t-> tr (TRQueryExpr q) = parens $ queryExpr q+> tr (TRQueryExpr q) = parens $ queryExpr d q > tr (TRJoin t0 b jt t1 jc) = > sep [tr t0 > ,if b then text "natural" else empty@@ -389,34 +401,34 @@ > JFull -> text "full" > JCross -> text "cross" > ,text "join"]-> joinCond (Just (JoinOn e)) = text "on" <+> valueExpr e+> joinCond (Just (JoinOn e)) = text "on" <+> valueExpr d e > joinCond (Just (JoinUsing es)) = > text "using" <+> parens (commaSep $ map name es) > joinCond Nothing = empty -> maybeValueExpr :: String -> Maybe ValueExpr -> Doc-> maybeValueExpr k = me+> maybeValueExpr :: Dialect -> String -> Maybe ValueExpr -> Doc+> maybeValueExpr d k = me > (\e -> sep [text k-> ,nest (length k + 1) $ valueExpr e])+> ,nest (length k + 1) $ valueExpr d e]) -> grpBy :: [GroupingExpr] -> Doc-> grpBy [] = empty-> grpBy gs = sep [text "group by"+> grpBy :: Dialect -> [GroupingExpr] -> Doc+> grpBy _ [] = empty+> grpBy d gs = sep [text "group by" > ,nest 9 $ commaSep $ map ge gs] > where-> ge (SimpleGroup e) = valueExpr e+> ge (SimpleGroup e) = valueExpr d e > ge (GroupingParens g) = parens (commaSep $ map ge g) > ge (Cube es) = text "cube" <> parens (commaSep $ map ge es) > ge (Rollup es) = text "rollup" <> parens (commaSep $ map ge es) > ge (GroupingSets es) = text "grouping sets" <> parens (commaSep $ map ge es) -> orderBy :: [SortSpec] -> Doc-> orderBy [] = empty-> orderBy os = sep [text "order by"+> orderBy :: Dialect -> [SortSpec] -> Doc+> orderBy _ [] = empty+> orderBy dia os = sep [text "order by" > ,nest 9 $ commaSep $ map f os] > where > f (SortSpec e d n) =-> valueExpr e+> valueExpr dia e > <+> (case d of > Asc -> text "asc" > Desc -> text "desc"@@ -433,3 +445,6 @@ > me :: (a -> Doc) -> Maybe a -> Doc > me = maybe empty++> comment :: Comment -> Doc+> comment (BlockComment str) = text "/*" <+> text str <+> text "*/"
Language/SQL/SimpleSQL/Syntax.lhs view
@@ -30,6 +30,10 @@ > ,TableRef(..) > ,JoinType(..) > ,JoinCondition(..)+> -- * dialect+> ,Dialect(..)+> -- * comment+> ,Comment(..) > ) where > import Data.Data@@ -159,12 +163,15 @@ > | MultisetCtor [ValueExpr] > | MultisetQueryCtor QueryExpr > | NextValueFor [Name]+> | VEComment [Comment] ValueExpr > deriving (Eq,Show,Read,Data,Typeable) > -- | Represents an identifier name, which can be quoted or unquoted. > data Name = Name String > | QName String > | UQName String+> | DQName String String String+> -- ^ dialect quoted name, the fields are start quote, end quote and the string itself, e.g. `something` is parsed to DQName "`" "`" "something, and $a$ test $a$ is parsed to DQName "$a$" "$a" " test " > deriving (Eq,Show,Read,Data,Typeable) > -- | Represents a type name, used in casts.@@ -288,6 +295,7 @@ > ,qeQueryExpression :: QueryExpr} > | Values [[ValueExpr]] > | Table [Name]+> | QEComment [Comment] QueryExpr > deriving (Eq,Show,Read,Data,Typeable) TODO: add queryexpr parens to deal with e.g.@@ -319,7 +327,6 @@ > ,qeOffset = Nothing > ,qeFetchFirst = Nothing} - > -- | 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.@@ -372,3 +379,16 @@ > data JoinCondition = JoinOn ValueExpr -- ^ on expr > | JoinUsing [Name] -- ^ using (column list) > deriving (Eq,Show,Read,Data,Typeable)+++> -- | Used to set the dialect used for parsing and pretty printing,+> -- very unfinished at the moment.+> data Dialect = SQL2011+> | MySQL+> deriving (Eq,Show,Read,Data,Typeable)+++> -- | Comment. Useful when generating SQL code programmatically.+> data Comment = BlockComment String+> deriving (Eq,Show,Read,Data,Typeable)+
changelog view
@@ -2,7 +2,12 @@ please email jakewheatmail@gmail.com or use the github bug tracker, https://github.com/JakeWheat/simple-sql-parser/issues. -0.4.0 (updated to dbd48baaa1d1bce3d0d0139b8ffe55370fabe672)+0.4.1 (commit c156c5c34e91e1f7ef449d2c1ea14e282104fd90)+ tested with ghc 7.4.2, 7.6.3, 7.8.4,7.10.0.20150123+ simple demonstration of how dialects could be handled internally+ add ability to add comments to syntax tree to help with generating+ SQL code+0.4.0 (commit 7914898cc8f07bbaf8358d208469392346341964) now targets SQL:2011 update to ghc 7.8.2 remove dependency on haskell-src-exts
simple-sql-parser.cabal view
@@ -1,5 +1,5 @@ name: simple-sql-parser-version: 0.4.0+version: 0.4.1 synopsis: A parser for SQL queries description: A parser for SQL queries. Parses most SQL:2011@@ -33,7 +33,7 @@ Other-Modules: Language.SQL.SimpleSQL.Errors, Language.SQL.SimpleSQL.Combinators other-extensions: TupleSections- build-depends: base >=4.6 && <4.8,+ build-depends: base >=4.5 && <4.9, parsec >=3.1 && <3.2, mtl >=2.1 && <2.3, pretty >= 1.1 && < 1.2@@ -46,7 +46,7 @@ type: exitcode-stdio-1.0 main-is: RunTests.lhs hs-source-dirs: .,tools- Build-Depends: base >=4.6 && <4.8,+ Build-Depends: base >=4.5 && <4.9, parsec >=3.1 && <3.2, mtl >=2.1 && <2.3, pretty >= 1.1 && < 1.2,@@ -64,6 +64,7 @@ Language.SQL.SimpleSQL.ErrorMessages, Language.SQL.SimpleSQL.FullQueries, Language.SQL.SimpleSQL.GroupBy,+ Language.SQL.SimpleSQL.MySQL, Language.SQL.SimpleSQL.Postgres, Language.SQL.SimpleSQL.QueryExprComponents, Language.SQL.SimpleSQL.QueryExprs,@@ -81,7 +82,7 @@ executable SQLIndent main-is: SQLIndent.lhs hs-source-dirs: .,tools- Build-Depends: base >=4.6 && <4.8,+ Build-Depends: base >=4.5 && <4.9, parsec >=3.1 && <3.2, mtl >=2.1 && <2.3, pretty >= 1.1 && < 1.2
tools/Language/SQL/SimpleSQL/FullQueries.lhs view
@@ -8,7 +8,7 @@ > fullQueriesTests :: TestItem-> fullQueriesTests = Group "queries" $ map (uncurry TestQueryExpr)+> fullQueriesTests = Group "queries" $ map (uncurry (TestQueryExpr SQL2011)) > [("select count(*) from t" > ,makeSelect > {qeSelectList = [(App [Name "count"] [Star], Nothing)]
tools/Language/SQL/SimpleSQL/GroupBy.lhs view
@@ -15,7 +15,7 @@ > ] > simpleGroupBy :: TestItem-> simpleGroupBy = Group "simpleGroupBy" $ map (uncurry TestQueryExpr)+> simpleGroupBy = Group "simpleGroupBy" $ map (uncurry (TestQueryExpr SQL2011)) > [("select a,sum(b) from t group by a" > ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing) > ,(App [Name "sum"] [Iden [Name "b"]],Nothing)]@@ -37,7 +37,7 @@ sure which sql version they were introduced, 1999 or 2003 I think). > newGroupBy :: TestItem-> newGroupBy = Group "newGroupBy" $ map (uncurry TestQueryExpr)+> newGroupBy = Group "newGroupBy" $ map (uncurry (TestQueryExpr SQL2011)) > [("select * from t group by ()", ms [GroupingParens []]) > ,("select * from t group by grouping sets ((), (a))" > ,ms [GroupingSets [GroupingParens []@@ -53,7 +53,7 @@ > ,qeGroupBy = g} > randomGroupBy :: TestItem-> randomGroupBy = Group "randomGroupBy" $ map ParseQueryExpr+> randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr SQL2011) > ["select * from t GROUP BY a" > ,"select * from t GROUP BY GROUPING SETS((a))" > ,"select * from t GROUP BY a,b,c"
+ tools/Language/SQL/SimpleSQL/MySQL.lhs view
@@ -0,0 +1,40 @@++Tests for mysql dialect parsing++> module Language.SQL.SimpleSQL.MySQL (mySQLTests) where++> import Language.SQL.SimpleSQL.TestTypes+> import Language.SQL.SimpleSQL.Syntax++> mySQLTests :: TestItem+> mySQLTests = Group "mysql dialect"+> [backtickQuotes+> ,limit]++backtick quotes++limit syntax++[LIMIT {[offset,] row_count | row_count OFFSET offset}]++> backtickQuotes :: TestItem+> backtickQuotes = Group "backtickQuotes" (map (uncurry (TestValueExpr MySQL))+> [("`test`", Iden [DQName "`" "`" "test"])+> ]+> ++ [ParseValueExprFails SQL2011 "`test`"]+> )++> limit :: TestItem+> limit = Group "queries" ( map (uncurry (TestQueryExpr MySQL))+> [("select * from t limit 5"+> ,sel {qeFetchFirst = Just (NumLit "5")}+> )+> ]+> ++ [ParseQueryExprFails MySQL "select a from t fetch next 10 rows only;"+> ,ParseQueryExprFails SQL2011 "select * from t limit 5"]+> )+> where+> sel = makeSelect+> {qeSelectList = [(Star, Nothing)]+> ,qeFrom = [TRSimple [Name "t"]]+> }
tools/Language/SQL/SimpleSQL/Postgres.lhs view
@@ -6,10 +6,9 @@ > module Language.SQL.SimpleSQL.Postgres (postgresTests) where > import Language.SQL.SimpleSQL.TestTypes-> --import Language.SQL.SimpleSQL.Syntax > postgresTests :: TestItem-> postgresTests = Group "postgresTests" $ map ParseQueryExpr+> postgresTests = Group "postgresTests" $ map (ParseQueryExpr SQL2011) lexical syntax section
tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs view
@@ -28,7 +28,7 @@ > duplicates :: TestItem-> duplicates = Group "duplicates" $ map (uncurry TestQueryExpr)+> duplicates = Group "duplicates" $ map (uncurry (TestQueryExpr SQL2011)) > [("select a from t" ,ms SQDefault) > ,("select all a from t" ,ms All) > ,("select distinct a from t", ms Distinct)@@ -40,7 +40,7 @@ > ,qeFrom = [TRSimple [Name "t"]]} > selectLists :: TestItem-> selectLists = Group "selectLists" $ map (uncurry TestQueryExpr)+> selectLists = Group "selectLists" $ map (uncurry (TestQueryExpr SQL2011)) > [("select 1", > makeSelect {qeSelectList = [(NumLit "1",Nothing)]}) @@ -73,7 +73,7 @@ > ] > whereClause :: TestItem-> whereClause = Group "whereClause" $ map (uncurry TestQueryExpr)+> whereClause = Group "whereClause" $ map (uncurry (TestQueryExpr SQL2011)) > [("select a from t where a = 5" > ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing)] > ,qeFrom = [TRSimple [Name "t"]]@@ -81,7 +81,7 @@ > ] > having :: TestItem-> having = Group "having" $ map (uncurry TestQueryExpr)+> having = Group "having" $ map (uncurry (TestQueryExpr SQL2011)) > [("select a,sum(b) from t group by a having sum(b) > 5" > ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing) > ,(App [Name "sum"] [Iden [Name "b"]],Nothing)]@@ -93,7 +93,7 @@ > ] > orderBy :: TestItem-> orderBy = Group "orderBy" $ map (uncurry TestQueryExpr)+> orderBy = Group "orderBy" $ map (uncurry (TestQueryExpr SQL2011)) > [("select a from t order by a" > ,ms [SortSpec (Iden [Name "a"]) DirDefault NullsOrderDefault]) @@ -119,7 +119,7 @@ > ,qeOrderBy = o} > offsetFetch :: TestItem-> offsetFetch = Group "offsetFetch" $ map (uncurry TestQueryExpr)+> offsetFetch = Group "offsetFetch" $ map (uncurry (TestQueryExpr SQL2011)) > [-- ansi standard > ("select a from t offset 5 rows fetch next 10 rows only" > ,ms (Just $ NumLit "5") (Just $ NumLit "10"))@@ -142,7 +142,7 @@ > ,qeFetchFirst = l} > combos :: TestItem-> combos = Group "combos" $ map (uncurry TestQueryExpr)+> combos = Group "combos" $ map (uncurry (TestQueryExpr SQL2011)) > [("select a from t union select b from u" > ,CombineQueryExpr ms1 Union SQDefault Respectively ms2) @@ -173,7 +173,7 @@ > withQueries :: TestItem-> withQueries = Group "with queries" $ map (uncurry TestQueryExpr)+> withQueries = Group "with queries" $ map (uncurry (TestQueryExpr SQL2011)) > [("with u as (select a from t) select a from u" > ,With False [(Alias (Name "u") Nothing, ms1)] ms2) @@ -197,13 +197,13 @@ > ms3 = ms "a" "x" > values :: TestItem-> values = Group "values" $ map (uncurry TestQueryExpr)+> values = Group "values" $ map (uncurry (TestQueryExpr SQL2011)) > [("values (1,2),(3,4)" > ,Values [[NumLit "1", NumLit "2"] > ,[NumLit "3", NumLit "4"]]) > ] > tables :: TestItem-> tables = Group "tables" $ map (uncurry TestQueryExpr)+> tables = Group "tables" $ map (uncurry (TestQueryExpr SQL2011)) > [("table tbl", Table [Name "tbl"]) > ]
tools/Language/SQL/SimpleSQL/QueryExprs.lhs view
@@ -8,7 +8,7 @@ > import Language.SQL.SimpleSQL.Syntax > queryExprsTests :: TestItem-> queryExprsTests = Group "query exprs" $ map (uncurry TestQueryExprs)+> queryExprsTests = Group "query exprs" $ map (uncurry (TestQueryExprs SQL2011)) > [("select 1",[ms]) > ,("select 1;",[ms]) > ,("select 1;select 1",[ms,ms])
tools/Language/SQL/SimpleSQL/SQL2011.lhs view
@@ -482,7 +482,7 @@ > characterStringLiterals :: TestItem > characterStringLiterals = Group "character string literals"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("'a regular string literal'" > ,StringLit "a regular string literal") > ,("'something' ' some more' 'and more'"@@ -510,7 +510,7 @@ > nationalCharacterStringLiterals :: TestItem > nationalCharacterStringLiterals = Group "national character string literals"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("N'something'", CSStringLit "N" "something") > ,("n'something'", CSStringLit "n" "something") > ]@@ -527,7 +527,7 @@ > unicodeCharacterStringLiterals :: TestItem > unicodeCharacterStringLiterals = Group "unicode character string literals"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("U&'something'", CSStringLit "U&" "something") > ,("u&'something' escape =" > ,Escape (CSStringLit "u&" "something") '=')@@ -546,7 +546,7 @@ > binaryStringLiterals :: TestItem > binaryStringLiterals = Group "binary string literals"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [--("B'101010'", CSStringLit "B" "101010") > ("X'7f7f7f'", CSStringLit "X" "7f7f7f") > ,("X'7f7f7f' escape z", Escape (CSStringLit "X" "7f7f7f") 'z')@@ -576,7 +576,7 @@ > numericLiterals :: TestItem > numericLiterals = Group "numeric literals"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("11", NumLit "11") > ,("11.11", NumLit "11.11") @@ -682,7 +682,7 @@ > intervalLiterals :: TestItem > intervalLiterals = Group "intervalLiterals literals"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("interval '1'", TypedLit (TypeName [Name "interval"]) "1") > ,("interval '1' day" > ,IntervalLit Nothing "1" (Itf "day" Nothing) Nothing)@@ -705,7 +705,7 @@ > booleanLiterals :: TestItem > booleanLiterals = Group "boolean literals"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("true", Iden [Name "true"]) > ,("false", Iden [Name "false"]) > ,("unknown", Iden [Name "unknown"])@@ -725,7 +725,7 @@ > identifiers :: TestItem > identifiers = Group "identifiers"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("test",Iden [Name "test"]) > ,("_test",Iden [Name "_test"]) > ,("t1",Iden [Name "t1"])@@ -1166,7 +1166,7 @@ expression > typeNameTests :: TestItem-> typeNameTests = Group "type names" $ map (uncurry TestValueExpr)+> typeNameTests = Group "type names" $ map (uncurry (TestValueExpr SQL2011)) > $ concatMap makeTests typeNames > where > makeTests (ctn, stn) =@@ -1184,7 +1184,7 @@ > fieldDefinition :: TestItem > fieldDefinition = Group "field definition"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("cast('(1,2)' as row(a int,b char))" > ,Cast (StringLit "(1,2)") > $ RowTypeName [(Name "a", TypeName [Name "int"])@@ -1264,7 +1264,7 @@ > parenthesizedValueExpression :: TestItem > parenthesizedValueExpression = Group "parenthesized value expression"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("(3)", Parens (NumLit "3")) > ,("((3))", Parens $ Parens (NumLit "3")) > ]@@ -1300,7 +1300,7 @@ > generalValueSpecification :: TestItem > generalValueSpecification = Group "general value specification"-> $ map (uncurry TestValueExpr) $+> $ map (uncurry (TestValueExpr SQL2011)) $ > map mkIden ["CURRENT_DEFAULT_TRANSFORM_GROUP" > ,"CURRENT_PATH" > ,"CURRENT_ROLE"@@ -1354,7 +1354,7 @@ > parameterSpecification :: TestItem > parameterSpecification = Group "parameter specification"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [(":hostparam", HostParameter "hostparam" Nothing) > ,(":hostparam indicator :another_host_param" > ,HostParameter "hostparam" $ Just "another_host_param")@@ -1391,7 +1391,7 @@ > contextuallyTypedValueSpecification :: TestItem > contextuallyTypedValueSpecification = > Group "contextually typed value specification"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("null", Iden [Name "null"]) > ,("array[]", Array (Iden [Name "array"]) []) > ,("multiset[]", MultisetCtor [])@@ -1409,7 +1409,7 @@ > identifierChain :: TestItem > identifierChain = Group "identifier chain"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("a.b", Iden [Name "a",Name "b"])] == 6.7 <column reference>@@ -1423,7 +1423,7 @@ > columnReference :: TestItem > columnReference = Group "column reference"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("module.a.b", Iden [Name "module",Name "a",Name "b"])] == 6.8 <SQL parameter reference>@@ -1446,7 +1446,7 @@ > setFunctionSpecification :: TestItem > setFunctionSpecification = Group "set function specification"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("SELECT SalesQuota, SUM(SalesYTD) TotalSalesYTD,\n\ > \ GROUPING(SalesQuota) AS Grouping\n\ > \FROM Sales.SalesPerson\n\@@ -1647,7 +1647,7 @@ > castSpecification :: TestItem > castSpecification = Group "cast specification"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("cast(a as int)" > ,Cast (Iden [Name "a"]) (TypeName [Name "int"])) > ]@@ -1661,7 +1661,7 @@ > nextValueExpression :: TestItem > nextValueExpression = Group "next value expression"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("next value for a.b", NextValueFor [Name "a", Name "b"]) > ] @@ -1674,7 +1674,7 @@ > fieldReference :: TestItem > fieldReference = Group "field reference"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("f(something).a" > ,BinOp (App [Name "f"] [Iden [Name "something"]]) > [Name "."]@@ -1798,7 +1798,7 @@ > arrayElementReference :: TestItem > arrayElementReference = Group "array element reference"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("something[3]" > ,Array (Iden [Name "something"]) [NumLit "3"]) > ,("(something(a))[x]"@@ -1821,7 +1821,7 @@ > multisetElementReference :: TestItem > multisetElementReference = Group "multisetElementReference"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("element(something)" > ,App [Name "element"] [Iden [Name "something"]]) > ]@@ -1871,7 +1871,7 @@ > numericValueExpression :: TestItem > numericValueExpression = Group "numeric value expression"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("a + b", binOp "+") > ,("a - b", binOp "-") > ,("a * b", binOp "*")@@ -2328,7 +2328,7 @@ > booleanValueExpression :: TestItem > booleanValueExpression = Group "booleab value expression"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("a or b", BinOp a [Name "or"] b) > ,("a and b", BinOp a [Name "and"] b) > ,("not a", PrefixOp [Name "not"] a)@@ -2403,7 +2403,7 @@ > arrayValueConstructor :: TestItem > arrayValueConstructor = Group "array value constructor"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("array[1,2,3]" > ,Array (Iden [Name "array"]) > [NumLit "1", NumLit "2", NumLit "3"])@@ -2441,7 +2441,7 @@ > multisetValueExpression :: TestItem > multisetValueExpression = Group "multiset value expression"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("a multiset union b" > ,MultisetBinOp (Iden [Name "a"]) Union SQDefault (Iden [Name "b"])) > ,("a multiset union all b"@@ -2468,7 +2468,7 @@ > multisetValueFunction :: TestItem > multisetValueFunction = Group "multiset value function"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("set(a)", App [Name "set"] [Iden [Name "a"]]) > ] @@ -2496,7 +2496,7 @@ > multisetValueConstructor :: TestItem > multisetValueConstructor = Group "multiset value constructor"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("multiset[a,b,c]", MultisetCtor[Iden [Name "a"] > ,Iden [Name "b"], Iden [Name "c"]]) > ,("multiset(select * from t)", MultisetQueryCtor qe)@@ -2574,7 +2574,7 @@ > rowValueConstructor :: TestItem > rowValueConstructor = Group "row value constructor"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("(a,b)" > ,SpecialOp [Name "rowctor"] [Iden [Name "a"], Iden [Name "b"]]) > ,("row(1)",App [Name "row"] [NumLit "1"])@@ -2625,7 +2625,7 @@ > tableValueConstructor :: TestItem > tableValueConstructor = Group "table value constructor"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("values (1,2), (a+b,(select count(*) from t));" > ,Values [[NumLit "1", NumLit "2"] > ,[BinOp (Iden [Name "a"]) [Name "+"]@@ -2660,7 +2660,7 @@ > fromClause :: TestItem > fromClause = Group "fromClause"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("select * from tbl1,tbl2" > ,makeSelect > {qeSelectList = [(Star, Nothing)]@@ -2675,7 +2675,7 @@ > tableReference :: TestItem > tableReference = Group "table reference"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("select * from t", sel) <table reference> ::= <table factor> | <joined table>@@ -2856,7 +2856,7 @@ > joinedTable :: TestItem > joinedTable = Group "joined table"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("select * from a cross join b" > ,sel $ TRJoin a False JCross b Nothing) > ,("select * from a join b on true"@@ -2913,7 +2913,7 @@ > whereClause :: TestItem > whereClause = Group "where clause"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("select * from t where a = 5" > ,makeSelect > {qeSelectList = [(Star,Nothing)]@@ -2973,7 +2973,7 @@ > groupByClause :: TestItem > groupByClause = Group "group by clause"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("select a,sum(x) from t group by a" > ,qe [SimpleGroup $ Iden [Name "a"]]) > ,("select a,sum(x) from t group by a collate c"@@ -3021,7 +3021,7 @@ > havingClause :: TestItem > havingClause = Group "having clause"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("select a,sum(x) from t group by a having sum(x) > 1000" > ,makeSelect > {qeSelectList = [(Iden [Name "a"], Nothing)@@ -3144,7 +3144,7 @@ > querySpecification :: TestItem > querySpecification = Group "query specification"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("select a from t",qe) > ,("select all a from t",qe {qeSetQuantifier = All}) > ,("select distinct a from t",qe {qeSetQuantifier = Distinct})@@ -3212,7 +3212,7 @@ > setOpQueryExpression :: TestItem > setOpQueryExpression= Group "set operation query expression"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > -- todo: complete setop query expression tests > [{-("select * from t union select * from t" > ,undefined)@@ -3249,7 +3249,7 @@ > explicitTableQueryExpression :: TestItem > explicitTableQueryExpression= Group "explicit table query expression"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("table t", Table [Name "t"]) > ] @@ -3271,7 +3271,7 @@ > orderOffsetFetchQueryExpression :: TestItem > orderOffsetFetchQueryExpression = Group "order, offset, fetch query expression"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [-- todo: finish tests for order offset and fetch > ("select a from t order by a" > ,qe {qeOrderBy = [SortSpec (Iden [Name "a"])@@ -3428,7 +3428,7 @@ > comparisonPredicates :: TestItem > comparisonPredicates = Group "comparison predicates"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > $ map mkOp ["=", "<>", "<", ">", "<=", ">="] > ++ [("ROW(a) = ROW(b)" > ,BinOp (App [Name "ROW"] [a])@@ -3632,7 +3632,7 @@ > quantifiedComparisonPredicate :: TestItem > quantifiedComparisonPredicate = Group "quantified comparison predicate"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("a = any (select * from t)" > ,QuantifiedComparison (Iden [Name "a"]) [Name "="] CPAny qe)@@ -3659,7 +3659,7 @@ > existsPredicate :: TestItem > existsPredicate = Group "exists predicate"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("exists(select * from t where a = 4)" > ,SubQueryExpr SqExists > $ makeSelect@@ -3678,7 +3678,7 @@ > uniquePredicate :: TestItem > uniquePredicate = Group "unique predicate"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("unique(select * from t where a = 4)" > ,SubQueryExpr SqUnique > $ makeSelect@@ -3714,7 +3714,7 @@ > matchPredicate :: TestItem > matchPredicate = Group "match predicate"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("a match (select a from t)" > ,Match (Iden [Name "a"]) False qe) > ,("(a,b) match (select a,b from t)"@@ -4066,7 +4066,7 @@ > collateClause :: TestItem > collateClause = Group "collate clause"-> $ map (uncurry TestValueExpr)+> $ map (uncurry (TestValueExpr SQL2011)) > [("a collate my_collation" > ,Collate (Iden [Name "a"]) [Name "my_collation"])] @@ -4177,7 +4177,7 @@ > aggregateFunction :: TestItem > aggregateFunction = Group "aggregate function"-> $ map (uncurry TestValueExpr) $+> $ map (uncurry (TestValueExpr SQL2011)) $ > [("count(*)",App [Name "count"] [Star]) > ,("count(*) filter (where something > 5)" > ,AggregateApp [Name "count"] SQDefault [Star] [] fil)@@ -4272,7 +4272,7 @@ > sortSpecificationList :: TestItem > sortSpecificationList = Group "sort specification list"-> $ map (uncurry TestQueryExpr)+> $ map (uncurry (TestQueryExpr SQL2011)) > [("select * from t order by a" > ,qe {qeOrderBy = [SortSpec (Iden [Name "a"]) > DirDefault NullsOrderDefault]})
tools/Language/SQL/SimpleSQL/TableRefs.lhs view
@@ -9,7 +9,7 @@ > tableRefTests :: TestItem-> tableRefTests = Group "tableRefTests" $ map (uncurry TestQueryExpr)+> tableRefTests = Group "tableRefTests" $ map (uncurry (TestQueryExpr SQL2011)) > [("select a from t" > ,ms [TRSimple [Name "t"]])
tools/Language/SQL/SimpleSQL/TestTypes.lhs view
@@ -2,18 +2,30 @@ This is the types used to define the tests as pure data. See the Tests.lhs module for the 'interpreter'. -> module Language.SQL.SimpleSQL.TestTypes where+> module Language.SQL.SimpleSQL.TestTypes+> (TestItem(..)+> ,Dialect(..)) where > import Language.SQL.SimpleSQL.Syntax +TODO: maybe make the dialect args into [dialect], then each test+checks all the dialects mentioned work, and all the dialects not+mentioned give a parse error. Not sure if this will be too awkward due+to lots of tricky exceptions/variationsx.+ > data TestItem = Group String [TestItem]-> | TestValueExpr String ValueExpr-> | TestQueryExpr String QueryExpr-> | TestQueryExprs String [QueryExpr]+> | TestValueExpr Dialect String ValueExpr+> | TestQueryExpr Dialect String QueryExpr+> | TestQueryExprs Dialect String [QueryExpr] this just checks the sql parses without error, mostly just a intermediate when I'm too lazy to write out the parsed AST. These should all be TODO to convert to a testqueryexpr test. -> | ParseQueryExpr String+> | ParseQueryExpr Dialect String++check that the string given fails to parse++> | ParseQueryExprFails Dialect String+> | ParseValueExprFails Dialect String > deriving (Eq,Show)
tools/Language/SQL/SimpleSQL/Tests.lhs view
@@ -30,6 +30,8 @@ > import Language.SQL.SimpleSQL.SQL2011 +> import Language.SQL.SimpleSQL.MySQL+ Order the tests to start from the simplest first. This is also the order on the generated documentation. @@ -45,6 +47,7 @@ > ,postgresTests > ,tpchTests > ,sql2011Tests+> ,mySQLTests > ] > tests :: Test.Framework.Test@@ -56,29 +59,37 @@ > itemToTest :: TestItem -> Test.Framework.Test > itemToTest (Group nm ts) = > testGroup nm $ map itemToTest ts-> itemToTest (TestValueExpr str expected) =-> toTest parseValueExpr prettyValueExpr 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+> itemToTest (TestValueExpr d str expected) =+> toTest parseValueExpr prettyValueExpr d str expected+> itemToTest (TestQueryExpr d str expected) =+> toTest parseQueryExpr prettyQueryExpr d str expected+> itemToTest (TestQueryExprs d str expected) =+> toTest parseQueryExprs prettyQueryExprs d str expected+> itemToTest (ParseQueryExpr d str) =+> toPTest parseQueryExpr prettyQueryExpr d str +> itemToTest (ParseQueryExprFails d str) =+> toFTest parseQueryExpr prettyQueryExpr d str++> itemToTest (ParseValueExprFails d str) =+> toFTest parseValueExpr prettyValueExpr d str++ > toTest :: (Eq a, Show a) =>-> (String -> Maybe (Int,Int) -> String -> Either ParseError a)-> -> (a -> String)+> (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a)+> -> (Dialect -> a -> String)+> -> Dialect > -> String > -> a > -> Test.Framework.Test-> toTest parser pp str expected = testCase str $ do-> let egot = parser "" Nothing str+> toTest parser pp d str expected = testCase str $ do+> let egot = parser d "" 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'+> let str' = pp d got+> let egot' = parser d "" Nothing str' > case egot' of > Left e' -> H.assertFailure $ "pp roundtrip" > ++ "\n" ++ str'@@ -88,19 +99,34 @@ > expected got' > toPTest :: (Eq a, Show a) =>-> (String -> Maybe (Int,Int) -> String -> Either ParseError a)-> -> (a -> String)+> (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a)+> -> (Dialect -> a -> String)+> -> Dialect > -> String > -> Test.Framework.Test-> toPTest parser pp str = testCase str $ do-> let egot = parser "" Nothing str+> toPTest parser pp d str = testCase str $ do+> let egot = parser d "" Nothing str > case egot of > Left e -> H.assertFailure $ peFormattedError e > Right got -> do-> let str' = pp got-> let egot' = parser "" Nothing str'+> let str' = pp d got+> let egot' = parser d "" Nothing str' > case egot' of > Left e' -> H.assertFailure $ "pp roundtrip " > ++ "\n" ++ str' ++ "\n" > ++ peFormattedError e' > Right _got' -> return ()+++> toFTest :: (Eq a, Show a) =>+> (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a)+> -> (Dialect -> a -> String)+> -> Dialect+> -> String+> -> Test.Framework.Test+> toFTest parser pp d str = testCase str $ do+> let egot = parser d "" Nothing str+> case egot of+> Left e -> return ()+> Right got ->+> H.assertFailure $ "parse didn't fail: " ++ show d ++ "\n" ++ str
tools/Language/SQL/SimpleSQL/Tpch.lhs view
@@ -13,7 +13,7 @@ > tpchTests :: TestItem > tpchTests = > Group "parse tpch"-> $ map (ParseQueryExpr . snd) tpchQueries+> $ map (ParseQueryExpr SQL2011 . snd) tpchQueries > tpchQueries :: [(String,String)] > tpchQueries =
tools/Language/SQL/SimpleSQL/ValueExprs.lhs view
@@ -23,7 +23,7 @@ > ] > literals :: TestItem-> literals = Group "literals" $ map (uncurry TestValueExpr)+> literals = Group "literals" $ map (uncurry (TestValueExpr SQL2011)) > [("3", NumLit "3") > ,("3.", NumLit "3.") > ,("3.3", NumLit "3.3")@@ -45,27 +45,27 @@ > ] > identifiers :: TestItem-> identifiers = Group "identifiers" $ map (uncurry TestValueExpr)+> identifiers = Group "identifiers" $ map (uncurry (TestValueExpr SQL2011)) > [("iden1", Iden [Name "iden1"]) > --,("t.a", Iden2 "t" "a") > ,("\"quoted identifier\"", Iden [QName "quoted identifier"]) > ] > star :: TestItem-> star = Group "star" $ map (uncurry TestValueExpr)+> star = Group "star" $ map (uncurry (TestValueExpr SQL2011)) > [("*", Star) > --,("t.*", Star2 "t") > --,("ROW(t.*,42)", App "ROW" [Star2 "t", NumLit "42"]) > ] > parameter :: TestItem-> parameter = Group "parameter" $ map (uncurry TestValueExpr)+> parameter = Group "parameter" $ map (uncurry (TestValueExpr SQL2011)) > [("?", Parameter) > ] > dots :: TestItem-> dots = Group "dot" $ map (uncurry TestValueExpr)+> dots = Group "dot" $ map (uncurry (TestValueExpr SQL2011)) > [("t.a", Iden [Name "t",Name "a"]) > ,("t.*", BinOp (Iden [Name "t"]) [Name "."] Star) > ,("a.b.c", Iden [Name "a",Name "b",Name "c"])@@ -73,14 +73,14 @@ > ] > app :: TestItem-> app = Group "app" $ map (uncurry TestValueExpr)+> app = Group "app" $ map (uncurry (TestValueExpr SQL2011)) > [("f()", App [Name "f"] []) > ,("f(a)", App [Name "f"] [Iden [Name "a"]]) > ,("f(a,b)", App [Name "f"] [Iden [Name "a"], Iden [Name "b"]]) > ] > caseexp :: TestItem-> caseexp = Group "caseexp" $ map (uncurry TestValueExpr)+> caseexp = Group "caseexp" $ map (uncurry (TestValueExpr SQL2011)) > [("case a when 1 then 2 end" > ,Case (Just $ Iden [Name "a"]) [([NumLit "1"] > ,NumLit "2")] Nothing)@@ -116,7 +116,7 @@ > ,miscOps] > binaryOperators :: TestItem-> binaryOperators = Group "binaryOperators" $ map (uncurry TestValueExpr)+> binaryOperators = Group "binaryOperators" $ map (uncurry (TestValueExpr SQL2011)) > [("a + b", BinOp (Iden [Name "a"]) [Name "+"] (Iden [Name "b"])) > -- sanity check fixities > -- todo: add more fixity checking@@ -131,7 +131,7 @@ > ] > unaryOperators :: TestItem-> unaryOperators = Group "unaryOperators" $ map (uncurry TestValueExpr)+> unaryOperators = Group "unaryOperators" $ map (uncurry (TestValueExpr SQL2011)) > [("not a", PrefixOp [Name "not"] $ Iden [Name "a"]) > ,("not not a", PrefixOp [Name "not"] $ PrefixOp [Name "not"] $ Iden [Name "a"]) > ,("+a", PrefixOp [Name "+"] $ Iden [Name "a"])@@ -140,7 +140,7 @@ > casts :: TestItem-> casts = Group "operators" $ map (uncurry TestValueExpr)+> casts = Group "operators" $ map (uncurry (TestValueExpr SQL2011)) > [("cast('1' as int)" > ,Cast (StringLit "1") $ TypeName [Name "int"]) @@ -162,7 +162,7 @@ > ] > subqueries :: TestItem-> subqueries = Group "unaryOperators" $ map (uncurry TestValueExpr)+> subqueries = Group "unaryOperators" $ map (uncurry (TestValueExpr SQL2011)) > [("exists (select a from t)", SubQueryExpr SqExists ms) > ,("(select a from t)", SubQueryExpr SqSq ms) @@ -188,7 +188,7 @@ > } > miscOps :: TestItem-> miscOps = Group "unaryOperators" $ map (uncurry TestValueExpr)+> miscOps = Group "unaryOperators" $ map (uncurry (TestValueExpr SQL2011)) > [("a in (1,2,3)" > ,In True (Iden [Name "a"]) $ InList $ map NumLit ["1","2","3"]) @@ -326,7 +326,7 @@ > ] > aggregates :: TestItem-> aggregates = Group "aggregates" $ map (uncurry TestValueExpr)+> aggregates = Group "aggregates" $ map (uncurry (TestValueExpr SQL2011)) > [("count(*)",App [Name "count"] [Star]) > ,("sum(a order by a)"@@ -341,7 +341,7 @@ > ] > windowFunctions :: TestItem-> windowFunctions = Group "windowFunctions" $ map (uncurry TestValueExpr)+> windowFunctions = Group "windowFunctions" $ map (uncurry (TestValueExpr SQL2011)) > [("max(a) over ()", WindowApp [Name "max"] [Iden [Name "a"]] [] [] Nothing) > ,("count(*) over ()", WindowApp [Name "count"] [Star] [] [] Nothing) @@ -400,7 +400,7 @@ > ] > parens :: TestItem-> parens = Group "parens" $ map (uncurry TestValueExpr)+> parens = Group "parens" $ map (uncurry (TestValueExpr SQL2011)) > [("(a)", Parens (Iden [Name "a"])) > ,("(a + b)", Parens (BinOp (Iden [Name "a"]) [Name "+"] (Iden [Name "b"]))) > ]