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

example how to switch parsing and pretty printing depending on dialect

Browse source
This commit is contained in:
Jake Wheat 2014-06-28 15:41:11 +03:00
parent 7d63c8f8e5
commit c1c514af35
6 changed files with 206 additions and 157 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
Language/SQL/SimpleSQL/Combinators.lhs
View file

@ -17,7 +17,9 @@
> import Control.Applicative ((<$>), (<*>), (<**>), pure, Applicative) > import Control.Applicative ((<$>), (<*>), (<**>), pure, Applicative)
> import Text.Parsec (option,many) > 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 a possible issue with the option suffix is that it enforces left
associativity when chaining it recursively. Have to review associativity when chaining it recursively. Have to review
@ -27,7 +29,7 @@ instead, and create an alternative suffix parser
This function style is not good, and should be replaced with chain and This function style is not good, and should be replaced with chain and
<??> which has a different type <??> 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) > optionSuffix p a = option a (p a)
@ -37,7 +39,7 @@ hand result, taken from uu-parsinglib
TODO: make sure the precedence higher than <|> and lower than the TODO: make sure the precedence higher than <|> and lower than the
other operators so it can be used nicely 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 > p <??> q = p <**> option id q
@ -78,7 +80,7 @@ composing suffix parsers, not sure about the name. This is used to add
a second or more suffix parser contingent on the first suffix parser a second or more suffix parser contingent on the first suffix parser
succeeding. 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 > (<??.>) pa pb = (.) `c` pa <*> option id pb
> -- todo: fix this mess > -- todo: fix this mess
> where c = (<$>) . flip > where c = (<$>) . flip
@ -86,7 +88,7 @@ succeeding.
0 to many repeated applications of suffix parser 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) > p <??*> q = foldr ($) <$> p <*> (reverse <$> many q)

50
Language/SQL/SimpleSQL/Parser.lhs
View file

@ -190,10 +190,11 @@ fixing them in the syntax but leaving them till the semantic checking
> import Text.Parsec (setPosition,setSourceColumn,setSourceLine,getPosition > import Text.Parsec (setPosition,setSourceColumn,setSourceLine,getPosition
> ,option,between,sepBy,sepBy1,string,manyTill,anyChar > ,option,between,sepBy,sepBy1,string,manyTill,anyChar
> ,try,string,many1,oneOf,digit,(<|>),choice,char,eof > ,try,string,many1,oneOf,digit,(<|>),choice,char,eof
> ,optionMaybe,optional,many,letter,parse > ,optionMaybe,optional,many,letter,runParser
> ,chainl1, chainr1,(<?>) {-,notFollowedBy,alphaNum-}, lookAhead) > ,chainl1, chainr1,(<?>) {-,notFollowedBy,alphaNum-}, lookAhead)
> import Text.Parsec.String (Parser) > -- import Text.Parsec.String (Parser)
> import Text.Parsec.Perm (permute,(<$?>), (<|?>)) > import Text.Parsec.Perm (permute,(<$?>), (<|?>))
> import Text.Parsec.Prim (Parsec, getState)
> import qualified Text.Parsec.Expr as E > import qualified Text.Parsec.Expr as E
> import Data.List (intercalate,sort,groupBy) > import Data.List (intercalate,sort,groupBy)
> import Data.Function (on) > import Data.Function (on)
@ -256,15 +257,15 @@ converts the error return to the nice wrapper
> -> Maybe (Int,Int) > -> Maybe (Int,Int)
> -> String > -> String
> -> Either ParseError a > -> Either ParseError a
> wrapParse parser _ f p src = > wrapParse parser d f p src =
> either (Left . convParseError src) Right > either (Left . convParseError src) Right
> $ parse (setPos p *> whitespace *> parser <* eof) f src > $ runParser (setPos p *> whitespace *> parser <* eof)
> d f src
> where > where
> setPos Nothing = pure () > setPos Nothing = pure ()
> setPos (Just (l,c)) = fmap up getPosition >>= setPosition > setPos (Just (l,c)) = fmap up getPosition >>= setPosition
> where up = flip setSourceColumn c . flip setSourceLine l > where up = flip setSourceColumn c . flip setSourceLine l
------------------------------------------------ ------------------------------------------------
= Names = Names
@ -301,12 +302,14 @@ with U& or u&
u&"example quoted" u&"example quoted"
> name :: Parser Name > name :: Parser Name
> name = choice [QName <$> quotedIdentifier > name = do
> choice [QName <$> quotedIdentifier
> ,UQName <$> uquotedIdentifier > ,UQName <$> uquotedIdentifier
> ,Name <$> identifierBlacklist blacklist > ,Name <$> identifierBlacklist blacklist
> ,dqName] > ,dqName]
> where > where
> dqName = lexeme (DQName "`" "`" > dqName = guardDialect [MySQL] *>
> lexeme (DQName "`" "`"
> <$> (char '`' > <$> (char '`'
> *> manyTill anyChar (char '`'))) > *> manyTill anyChar (char '`')))
@ -1014,7 +1017,7 @@ syntax is way too messy. It might be possible to avoid this if we
wanted to avoid extensibility and to not be concerned with parse error wanted to avoid extensibility and to not be concerned with parse error
messages, but both of these are too important. 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 = > opTable bExpr =
> [-- parse match and quantified comparisons as postfix ops > [-- parse match and quantified comparisons as postfix ops
> -- todo: left factor the quantified comparison with regular > -- todo: left factor the quantified comparison with regular
@ -1303,11 +1306,13 @@ allows offset and fetch in either order
> fetch :: Parser ValueExpr > fetch :: Parser ValueExpr
> fetch = fetchFirst <|> limit > fetch = fetchFirst <|> limit
> where > where
> fetchFirst = fs *> valueExpr <* ro > fetchFirst = guardDialect [SQL2011]
> *> fs *> valueExpr <* ro
> fs = makeKeywordTree ["fetch first", "fetch next"] > fs = makeKeywordTree ["fetch first", "fetch next"]
> ro = makeKeywordTree ["rows only", "row only"] > ro = makeKeywordTree ["rows only", "row only"]
> -- todo: not in ansi sql dialect > -- todo: not in ansi sql dialect
> limit = keyword_ "limit" *> valueExpr > limit = guardDialect [MySQL] *>
> keyword_ "limit" *> valueExpr
== common table expressions == common table expressions
@ -1635,16 +1640,7 @@ helper function to improve error messages
> <?> "identifier" > <?> "identifier"
> blacklist :: [String] > blacklist :: [String]
> blacklist = reservedWord {- > 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"
> ] -}
These blacklisted names are mostly needed when we parse something with 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 an optional alias, e.g. select a a from t. If we write select a from
@ -1989,3 +1985,17 @@ means).
> -- added for mysql dialect, todo: make dialect specific lists > -- added for mysql dialect, todo: make dialect specific lists
> ,"limit" > ,"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)

257
Language/SQL/SimpleSQL/Pretty.lhs
View file

@ -20,64 +20,64 @@ which have been changed to try to improve the layout of the output.
> -- | Convert a query expr ast to concrete syntax. > -- | Convert a query expr ast to concrete syntax.
> prettyQueryExpr :: Dialect -> QueryExpr -> String > prettyQueryExpr :: Dialect -> QueryExpr -> String
> prettyQueryExpr _ = render . queryExpr > prettyQueryExpr d = render . queryExpr d
> -- | Convert a value expr ast to concrete syntax. > -- | Convert a value expr ast to concrete syntax.
> prettyValueExpr :: Dialect -> ValueExpr -> String > prettyValueExpr :: Dialect -> ValueExpr -> String
> prettyValueExpr _ = render . valueExpr > prettyValueExpr d = render . valueExpr d
> -- | Convert a list of query exprs to concrete syntax. A semi colon > -- | Convert a list of query exprs to concrete syntax. A semi colon
> -- is inserted after each query expr. > -- is inserted after each query expr.
> prettyQueryExprs :: Dialect -> [QueryExpr] -> String > prettyQueryExprs :: Dialect -> [QueryExpr] -> String
> prettyQueryExprs _ = render . vcat . map ((<> text ";\n") . queryExpr) > prettyQueryExprs d = render . vcat . map ((<> text ";\n") . queryExpr d)
= value expressions = value expressions
> valueExpr :: ValueExpr -> Doc > valueExpr :: Dialect -> ValueExpr -> Doc
> valueExpr (StringLit s) = quotes $ text $ doubleUpQuotes s > valueExpr _ (StringLit s) = quotes $ text $ doubleUpQuotes s
> valueExpr (NumLit s) = text s > valueExpr _ (NumLit s) = text s
> valueExpr (IntervalLit s v f t) = > valueExpr _ (IntervalLit s v f t) =
> text "interval" > text "interval"
> <+> me (\x -> if x then text "+" else text "-") s > <+> me (\x -> if x then text "+" else text "-") s
> <+> quotes (text v) > <+> quotes (text v)
> <+> intervalTypeField f > <+> intervalTypeField f
> <+> me (\x -> text "to" <+> intervalTypeField x) t > <+> me (\x -> text "to" <+> intervalTypeField x) t
> valueExpr (Iden i) = names i > valueExpr _ (Iden i) = names i
> valueExpr Star = text "*" > valueExpr _ Star = text "*"
> valueExpr Parameter = text "?" > valueExpr _ Parameter = text "?"
> valueExpr (HostParameter p i) = > valueExpr _ (HostParameter p i) =
> text (':':p) > text (':':p)
> <+> me (\i' -> text "indicator" <+> text (':':i')) i > <+> 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 > names f
> <> parens ((case d of > <> parens ((case d of
> Distinct -> text "distinct" > Distinct -> text "distinct"
> All -> text "all" > All -> text "all"
> SQDefault -> empty) > SQDefault -> empty)
> <+> commaSep (map valueExpr es) > <+> commaSep (map (valueExpr dia) es)
> <+> orderBy od) > <+> orderBy dia od)
> <+> me (\x -> text "filter" > <+> 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 > names f
> <> parens (commaSep (map valueExpr es)) > <> parens (commaSep (map (valueExpr d) es))
> <+> if null od > <+> if null od
> then empty > then empty
> else text "within group" <+> parens(orderBy od) > else text "within group" <+> parens (orderBy d od)
> valueExpr (WindowApp f es pb od fr) = > valueExpr d (WindowApp f es pb od fr) =
> names f <> parens (commaSep $ map valueExpr es) > names f <> parens (commaSep $ map (valueExpr d) es)
> <+> text "over" > <+> text "over"
> <+> parens ((case pb of > <+> parens ((case pb of
> [] -> empty > [] -> empty
> _ -> text "partition by" > _ -> text "partition by"
> <+> nest 13 (commaSep $ map valueExpr pb)) > <+> nest 13 (commaSep $ map (valueExpr d) pb))
> <+> orderBy od > <+> orderBy d od
> <+> me frd fr) > <+> me frd fr)
> where > where
> frd (FrameFrom rs fp) = rsd rs <+> fpd fp > frd (FrameFrom rs fp) = rsd rs <+> fpd fp
@ -90,109 +90,109 @@ which have been changed to try to improve the layout of the output.
> fpd UnboundedPreceding = text "unbounded preceding" > fpd UnboundedPreceding = text "unbounded preceding"
> fpd UnboundedFollowing = text "unbounded following" > fpd UnboundedFollowing = text "unbounded following"
> fpd Current = text "current row" > fpd Current = text "current row"
> fpd (Preceding e) = valueExpr e <+> text "preceding" > fpd (Preceding e) = valueExpr d e <+> text "preceding"
> fpd (Following e) = valueExpr e <+> text "following" > fpd (Following e) = valueExpr d e <+> text "following"
> valueExpr (SpecialOp nm [a,b,c]) | nm `elem` [[Name "between"] > valueExpr dia (SpecialOp nm [a,b,c]) | nm `elem` [[Name "between"]
> ,[Name "not between"]] = > ,[Name "not between"]] =
> sep [valueExpr a > sep [valueExpr dia a
> ,names nm <+> valueExpr b > ,names nm <+> valueExpr dia b
> ,nest (length (unnames nm) + 1) $ text "and" <+> valueExpr c] > ,nest (length (unnames nm) + 1) $ text "and" <+> valueExpr dia c]
> valueExpr (SpecialOp [Name "rowctor"] as) = > valueExpr d (SpecialOp [Name "rowctor"] as) =
> parens $ commaSep $ map valueExpr as > parens $ commaSep $ map (valueExpr d) as
> valueExpr (SpecialOp nm es) = > valueExpr d (SpecialOp nm es) =
> names nm <+> parens (commaSep $ map valueExpr 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 > names nm <> parens (sep $ catMaybes
> (fmap valueExpr fs > (fmap (valueExpr d) fs
> : map (\(n,e) -> Just (text n <+> valueExpr e)) as)) > : map (\(n,e) -> Just (text n <+> valueExpr d e)) as))
> valueExpr (PrefixOp f e) = names f <+> valueExpr e > valueExpr d (PrefixOp f e) = names f <+> valueExpr d e
> valueExpr (PostfixOp f e) = valueExpr e <+> names f > valueExpr d (PostfixOp f e) = valueExpr d e <+> names f
> valueExpr e@(BinOp _ op _) | op `elem` [[Name "and"], [Name "or"]] = > 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 > -- special case for and, or, get all the ands so we can vcat them
> -- nicely > -- nicely
> case ands e of > case ands e of
> (e':es) -> vcat (valueExpr e' > (e':es) -> vcat (valueExpr d e'
> : map ((names op <+>) . valueExpr) es) > : map ((names op <+>) . valueExpr d) es)
> [] -> empty -- shouldn't be possible > [] -> empty -- shouldn't be possible
> where > where
> ands (BinOp a op' b) | op == op' = ands a ++ ands b > ands (BinOp a op' b) | op == op' = ands a ++ ands b
> ands x = [x] > ands x = [x]
> -- special case for . we don't use whitespace > -- special case for . we don't use whitespace
> valueExpr (BinOp e0 [Name "."] e1) = > valueExpr d (BinOp e0 [Name "."] e1) =
> valueExpr e0 <> text "." <> valueExpr e1 > valueExpr d e0 <> text "." <> valueExpr d e1
> valueExpr (BinOp e0 f e1) = > valueExpr d (BinOp e0 f e1) =
> valueExpr e0 <+> names f <+> valueExpr e1 > valueExpr d e0 <+> names f <+> valueExpr d e1
> valueExpr (Case t ws els) = > valueExpr dia (Case t ws els) =
> sep $ [text "case" <+> me valueExpr t] > sep $ [text "case" <+> me (valueExpr dia) t]
> ++ map w ws > ++ map w ws
> ++ maybeToList (fmap e els) > ++ maybeToList (fmap e els)
> ++ [text "end"] > ++ [text "end"]
> where > where
> w (t0,t1) = > w (t0,t1) =
> text "when" <+> nest 5 (commaSep $ map valueExpr t0) > text "when" <+> nest 5 (commaSep $ map (valueExpr dia) t0)
> <+> text "then" <+> nest 5 (valueExpr t1) > <+> text "then" <+> nest 5 (valueExpr dia t1)
> e el = text "else" <+> nest 5 (valueExpr el) > e el = text "else" <+> nest 5 (valueExpr dia el)
> valueExpr (Parens e) = parens $ valueExpr e > valueExpr d (Parens e) = parens $ valueExpr d e
> valueExpr (Cast e tn) = > valueExpr d (Cast e tn) =
> text "cast" <> parens (sep [valueExpr e > text "cast" <> parens (sep [valueExpr d e
> ,text "as" > ,text "as"
> ,typeName tn]) > ,typeName tn])
> valueExpr (TypedLit tn s) = > valueExpr _ (TypedLit tn s) =
> typeName tn <+> quotes (text s) > typeName tn <+> quotes (text s)
> valueExpr (SubQueryExpr ty qe) = > valueExpr d (SubQueryExpr ty qe) =
> (case ty of > (case ty of
> SqSq -> empty > SqSq -> empty
> SqExists -> text "exists" > SqExists -> text "exists"
> SqUnique -> text "unique" > SqUnique -> text "unique"
> ) <+> parens (queryExpr qe) > ) <+> parens (queryExpr d qe)
> valueExpr (QuantifiedComparison v c cp sq) = > valueExpr d (QuantifiedComparison v c cp sq) =
> valueExpr v > valueExpr d v
> <+> names c > <+> names c
> <+> (text $ case cp of > <+> (text $ case cp of
> CPAny -> "any" > CPAny -> "any"
> CPSome -> "some" > CPSome -> "some"
> CPAll -> "all") > CPAll -> "all")
> <+> parens (queryExpr sq) > <+> parens (queryExpr d sq)
> valueExpr (Match v u sq) = > valueExpr d (Match v u sq) =
> valueExpr v > valueExpr d v
> <+> text "match" > <+> text "match"
> <+> (if u then text "unique" else empty) > <+> (if u then text "unique" else empty)
> <+> parens (queryExpr sq) > <+> parens (queryExpr d sq)
> valueExpr (In b se x) = > valueExpr d (In b se x) =
> valueExpr se <+> > valueExpr d se <+>
> (if b then empty else text "not") > (if b then empty else text "not")
> <+> text "in" > <+> text "in"
> <+> parens (nest (if b then 3 else 7) $ > <+> parens (nest (if b then 3 else 7) $
> case x of > case x of
> InList es -> commaSep $ map valueExpr es > InList es -> commaSep $ map (valueExpr d) es
> InQueryExpr qe -> queryExpr qe) > InQueryExpr qe -> queryExpr d qe)
> valueExpr (Array v es) = > valueExpr d (Array v es) =
> valueExpr v <> brackets (commaSep $ map valueExpr es) > valueExpr d v <> brackets (commaSep $ map (valueExpr d) es)
> valueExpr (ArrayCtor q) = > valueExpr d (ArrayCtor q) =
> text "array" <> parens (queryExpr q) > text "array" <> parens (queryExpr d q)
> valueExpr (MultisetCtor es) = > valueExpr d (MultisetCtor es) =
> text "multiset" <> brackets (commaSep $ map valueExpr es) > text "multiset" <> brackets (commaSep $ map (valueExpr d) es)
> valueExpr (MultisetQueryCtor q) = > valueExpr d (MultisetQueryCtor q) =
> text "multiset" <> parens (queryExpr q) > text "multiset" <> parens (queryExpr d q)
> valueExpr (MultisetBinOp a c q b) = > valueExpr d (MultisetBinOp a c q b) =
> sep > sep
> [valueExpr a > [valueExpr d a
> ,text "multiset" > ,text "multiset"
> ,text $ case c of > ,text $ case c of
> Union -> "union" > Union -> "union"
@ -202,23 +202,23 @@ which have been changed to try to improve the layout of the output.
> SQDefault -> empty > SQDefault -> empty
> All -> text "all" > All -> text "all"
> Distinct -> text "distinct" > Distinct -> text "distinct"
> ,valueExpr b] > ,valueExpr d b]
> valueExpr (CSStringLit cs st) = > valueExpr _ (CSStringLit cs st) =
> text cs <> quotes (text $ doubleUpQuotes st) > text cs <> quotes (text $ doubleUpQuotes st)
> valueExpr (Escape v e) = > valueExpr d (Escape v e) =
> valueExpr v <+> text "escape" <+> text [e] > valueExpr d v <+> text "escape" <+> text [e]
> valueExpr (UEscape v e) = > valueExpr d (UEscape v e) =
> valueExpr v <+> text "uescape" <+> text [e] > valueExpr d v <+> text "uescape" <+> text [e]
> valueExpr (Collate v c) = > valueExpr d (Collate v c) =
> valueExpr v <+> text "collate" <+> names c > valueExpr d v <+> text "collate" <+> names c
> valueExpr (NextValueFor ns) = > valueExpr _ (NextValueFor ns) =
> text "next value for" <+> names ns > text "next value for" <+> names ns
@ -238,6 +238,7 @@ which have been changed to try to improve the layout of the output.
> unname (QName n) = "\"" ++ doubleUpDoubleQuotes n ++ "\"" > unname (QName n) = "\"" ++ doubleUpDoubleQuotes n ++ "\""
> unname (UQName n) = "U&\"" ++ doubleUpDoubleQuotes n ++ "\"" > unname (UQName n) = "U&\"" ++ doubleUpDoubleQuotes n ++ "\""
> unname (Name n) = n > unname (Name n) = n
> unname (DQName s e n) = s ++ n ++ e
> unnames :: [Name] -> String > unnames :: [Name] -> String
> unnames ns = intercalate "." $ map unname ns > unnames ns = intercalate "." $ map unname ns
@ -310,25 +311,31 @@ which have been changed to try to improve the layout of the output.
= query expressions = query expressions
> queryExpr :: QueryExpr -> Doc > queryExpr :: Dialect -> QueryExpr -> Doc
> queryExpr (Select d sl fr wh gb hv od off fe) = > queryExpr dia (Select d sl fr wh gb hv od off fe) =
> sep [text "select" > sep [text "select"
> ,case d of > ,case d of
> SQDefault -> empty > SQDefault -> empty
> All -> text "all" > All -> text "all"
> Distinct -> text "distinct" > Distinct -> text "distinct"
> ,nest 7 $ sep [selectList sl] > ,nest 7 $ sep [selectList dia sl]
> ,from fr > ,from dia fr
> ,maybeValueExpr "where" wh > ,maybeValueExpr dia "where" wh
> ,grpBy gb > ,grpBy dia gb
> ,maybeValueExpr "having" hv > ,maybeValueExpr dia "having" hv
> ,orderBy od > ,orderBy dia od
> ,me (\e -> text "offset" <+> valueExpr e <+> text "rows") off > ,me (\e -> text "offset" <+> valueExpr dia e <+> text "rows") off
> ,me (\e -> text "fetch first" <+> valueExpr e > ,fetchFirst
> <+> text "rows only") fe
> ] > ]
> queryExpr (CombineQueryExpr q1 ct d c q2) = > where
> sep [queryExpr q1 > 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 > ,text (case ct of
> Union -> "union" > Union -> "union"
> Intersect -> "intersect" > Intersect -> "intersect"
@ -340,17 +347,17 @@ which have been changed to try to improve the layout of the output.
> <+> case c of > <+> case c of
> Corresponding -> text "corresponding" > Corresponding -> text "corresponding"
> Respectively -> empty > Respectively -> empty
> ,queryExpr q2] > ,queryExpr dia q2]
> queryExpr (With rc withs qe) = > queryExpr d (With rc withs qe) =
> text "with" <+> (if rc then text "recursive" else empty) > text "with" <+> (if rc then text "recursive" else empty)
> <+> vcat [nest 5 > <+> vcat [nest 5
> (vcat $ punctuate comma $ flip map withs $ \(n,q) -> > (vcat $ punctuate comma $ flip map withs $ \(n,q) ->
> alias n <+> text "as" <+> parens (queryExpr q)) > alias n <+> text "as" <+> parens (queryExpr d q))
> ,queryExpr qe] > ,queryExpr d qe]
> queryExpr (Values vs) = > queryExpr d (Values vs) =
> text "values" > text "values"
> <+> nest 7 (commaSep (map (parens . commaSep . map valueExpr) vs)) > <+> nest 7 (commaSep (map (parens . commaSep . map (valueExpr d)) vs))
> queryExpr (Table t) = text "table" <+> names t > queryExpr _ (Table t) = text "table" <+> names t
> alias :: Alias -> Doc > alias :: Alias -> Doc
@ -358,25 +365,25 @@ which have been changed to try to improve the layout of the output.
> text "as" <+> name nm > text "as" <+> name nm
> <+> me (parens . commaSep . map name) cols > <+> me (parens . commaSep . map name) cols
> selectList :: [(ValueExpr,Maybe Name)] -> Doc > selectList :: Dialect -> [(ValueExpr,Maybe Name)] -> Doc
> selectList is = commaSep $ map si is > selectList d is = commaSep $ map si is
> where > where
> si (e,al) = valueExpr e <+> me als al > si (e,al) = valueExpr d e <+> me als al
> als al = text "as" <+> name al > als al = text "as" <+> name al
> from :: [TableRef] -> Doc > from :: Dialect -> [TableRef] -> Doc
> from [] = empty > from _ [] = empty
> from ts = > from d ts =
> sep [text "from" > sep [text "from"
> ,nest 5 $ vcat $ punctuate comma $ map tr ts] > ,nest 5 $ vcat $ punctuate comma $ map tr ts]
> where > where
> tr (TRSimple t) = names t > tr (TRSimple t) = names t
> tr (TRLateral t) = text "lateral" <+> tr t > tr (TRLateral t) = text "lateral" <+> tr t
> tr (TRFunction f as) = > 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 (TRAlias t a) = sep [tr t, alias a]
> tr (TRParens t) = parens $ tr t > 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) = > tr (TRJoin t0 b jt t1 jc) =
> sep [tr t0 > sep [tr t0
> ,if b then text "natural" else empty > ,if b then text "natural" else empty
@ -390,34 +397,34 @@ which have been changed to try to improve the layout of the output.
> JFull -> text "full" > JFull -> text "full"
> JCross -> text "cross" > JCross -> text "cross"
> ,text "join"] > ,text "join"]
> joinCond (Just (JoinOn e)) = text "on" <+> valueExpr e > joinCond (Just (JoinOn e)) = text "on" <+> valueExpr d e
> joinCond (Just (JoinUsing es)) = > joinCond (Just (JoinUsing es)) =
> text "using" <+> parens (commaSep $ map name es) > text "using" <+> parens (commaSep $ map name es)
> joinCond Nothing = empty > joinCond Nothing = empty
> maybeValueExpr :: String -> Maybe ValueExpr -> Doc > maybeValueExpr :: Dialect -> String -> Maybe ValueExpr -> Doc
> maybeValueExpr k = me > maybeValueExpr d k = me
> (\e -> sep [text k > (\e -> sep [text k
> ,nest (length k + 1) $ valueExpr e]) > ,nest (length k + 1) $ valueExpr d e])
> grpBy :: [GroupingExpr] -> Doc > grpBy :: Dialect -> [GroupingExpr] -> Doc
> grpBy [] = empty > grpBy _ [] = empty
> grpBy gs = sep [text "group by" > grpBy d gs = sep [text "group by"
> ,nest 9 $ commaSep $ map ge gs] > ,nest 9 $ commaSep $ map ge gs]
> where > where
> ge (SimpleGroup e) = valueExpr e > ge (SimpleGroup e) = valueExpr d e
> ge (GroupingParens g) = parens (commaSep $ map ge g) > ge (GroupingParens g) = parens (commaSep $ map ge g)
> ge (Cube es) = text "cube" <> parens (commaSep $ map ge es) > ge (Cube es) = text "cube" <> parens (commaSep $ map ge es)
> ge (Rollup es) = text "rollup" <> 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) > ge (GroupingSets es) = text "grouping sets" <> parens (commaSep $ map ge es)
> orderBy :: [SortSpec] -> Doc > orderBy :: Dialect -> [SortSpec] -> Doc
> orderBy [] = empty > orderBy _ [] = empty
> orderBy os = sep [text "order by" > orderBy dia os = sep [text "order by"
> ,nest 9 $ commaSep $ map f os] > ,nest 9 $ commaSep $ map f os]
> where > where
> f (SortSpec e d n) = > f (SortSpec e d n) =
> valueExpr e > valueExpr dia e
> <+> (case d of > <+> (case d of
> Asc -> text "asc" > Asc -> text "asc"
> Desc -> text "desc" > Desc -> text "desc"

10
tools/Language/SQL/SimpleSQL/MySQL.lhs
View file

@ -18,17 +18,21 @@ limit syntax
[LIMIT {[offset,] row_count | row_count OFFSET offset}] [LIMIT {[offset,] row_count | row_count OFFSET offset}]
> backtickQuotes :: TestItem > backtickQuotes :: TestItem
> backtickQuotes = Group "backtickQuotes" $ map (uncurry (TestValueExpr MySQL)) > backtickQuotes = Group "backtickQuotes" (map (uncurry (TestValueExpr MySQL))
> [("`test`", Iden [DQName "`" "`" "test"]) > [("`test`", Iden [DQName "`" "`" "test"])
> ] > ]
> ++ [ParseValueExprFails SQL2011 "`test`"]
> )
> limit :: TestItem > limit :: TestItem
> limit = Group "queries" $ map (uncurry (TestQueryExpr MySQL)) > limit = Group "queries" ( map (uncurry (TestQueryExpr MySQL))
> [("select * from t limit 5" > [("select * from t limit 5"
> ,sel {qeFetchFirst = Just (NumLit "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 > where
> sel = makeSelect > sel = makeSelect
> {qeSelectList = [(Star, Nothing)] > {qeSelectList = [(Star, Nothing)]

5
tools/Language/SQL/SimpleSQL/TestTypes.lhs
View file

@ -18,4 +18,9 @@ intermediate when I'm too lazy to write out the parsed AST. These
should all be TODO to convert to a testqueryexpr test. should all be TODO to convert to a testqueryexpr test.
> | ParseQueryExpr Dialect String > | ParseQueryExpr Dialect String
check that the string given fails to parse
> | ParseQueryExprFails Dialect String
> | ParseValueExprFails Dialect String
> deriving (Eq,Show) > deriving (Eq,Show)

21
tools/Language/SQL/SimpleSQL/Tests.lhs
View file

@ -68,6 +68,13 @@ order on the generated documentation.
> itemToTest (ParseQueryExpr d str) = > itemToTest (ParseQueryExpr d str) =
> toPTest parseQueryExpr prettyQueryExpr 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) => > toTest :: (Eq a, Show a) =>
> (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a) > (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a)
> -> (Dialect -> a -> String) > -> (Dialect -> a -> String)
@ -109,3 +116,17 @@ order on the generated documentation.
> ++ "\n" ++ str' ++ "\n" > ++ "\n" ++ str' ++ "\n"
> ++ peFormattedError e' > ++ peFormattedError e'
> Right _got' -> return () > 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