example how to switch parsing and pretty printing depending on dialect
This commit is contained in:
Jake Wheat
parent
7d63c8f8e5
commit
c1c514af35
|
|
@ -17,7 +17,9 @@
|
|||
|
||||
> 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
|
||||
|
|
@ -27,7 +29,7 @@ instead, and create an alternative suffix parser
|
|||
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 @@ hand result, taken from uu-parsinglib
|
|||
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 @@ 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
|
||||
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 @@ succeeding.
|
|||
|
||||
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)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -190,10 +190,11 @@ fixing them in the syntax but leaving them till the semantic checking
|
|||
> 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)
|
||||
|
|
@ -256,15 +257,15 @@ converts the error return to the nice wrapper
|
|||
> -> 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
|
||||
|
|
@ -301,12 +302,14 @@ with U& or u&
|
|||
u&"example quoted"
|
||||
|
||||
> name :: Parser Name
|
||||
> name = choice [QName <$> quotedIdentifier
|
||||
> name = do
|
||||
> choice [QName <$> quotedIdentifier
|
||||
> ,UQName <$> uquotedIdentifier
|
||||
> ,Name <$> identifierBlacklist blacklist
|
||||
> ,dqName]
|
||||
> where
|
||||
> dqName = lexeme (DQName "`" "`"
|
||||
> dqName = guardDialect [MySQL] *>
|
||||
> lexeme (DQName "`" "`"
|
||||
> <$> (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
|
||||
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
|
||||
|
|
@ -1303,11 +1306,13 @@ allows offset and fetch in either order
|
|||
> fetch :: Parser ValueExpr
|
||||
> fetch = fetchFirst <|> limit
|
||||
> where
|
||||
> fetchFirst = fs *> valueExpr <* ro
|
||||
> 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 = keyword_ "limit" *> valueExpr
|
||||
> limit = guardDialect [MySQL] *>
|
||||
> keyword_ "limit" *> valueExpr
|
||||
|
||||
== common table expressions
|
||||
|
||||
|
|
@ -1635,16 +1640,7 @@ helper function to improve error messages
|
|||
> <?> "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 = 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
|
||||
|
|
@ -1989,3 +1985,17 @@ means).
|
|||
> -- added for mysql dialect, todo: make dialect specific lists
|
||||
> ,"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)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
> prettyQueryExpr :: Dialect -> QueryExpr -> String
|
||||
> prettyQueryExpr _ = render . queryExpr
|
||||
> prettyQueryExpr d = render . queryExpr d
|
||||
|
||||
> -- | Convert a value expr ast to concrete syntax.
|
||||
> prettyValueExpr :: Dialect -> ValueExpr -> String
|
||||
> prettyValueExpr _ = render . valueExpr
|
||||
> prettyValueExpr d = render . valueExpr d
|
||||
|
||||
> -- | Convert a list of query exprs to concrete syntax. A semi colon
|
||||
> -- is inserted after each query expr.
|
||||
> prettyQueryExprs :: Dialect -> [QueryExpr] -> String
|
||||
> prettyQueryExprs _ = render . vcat . map ((<> text ";\n") . queryExpr)
|
||||
> 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 @@ which have been changed to try to improve the layout of the output.
|
|||
> 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"]
|
||||
> valueExpr dia (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]
|
||||
> 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,23 +202,23 @@ which have been changed to try to improve the layout of the output.
|
|||
> 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
|
||||
|
||||
|
||||
|
|
@ -238,6 +238,7 @@ which have been changed to try to improve the layout of the output.
|
|||
> 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
|
||||
|
|
@ -310,25 +311,31 @@ which have been changed to try to improve the layout of the output.
|
|||
|
||||
= 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"
|
||||
|
|
@ -340,17 +347,17 @@ which have been changed to try to improve the layout of the output.
|
|||
> <+> 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
|
||||
|
||||
|
||||
> alias :: Alias -> Doc
|
||||
|
|
@ -358,25 +365,25 @@ which have been changed to try to improve the layout of the output.
|
|||
> 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
|
||||
|
|
@ -390,34 +397,34 @@ which have been changed to try to improve the layout of the output.
|
|||
> 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"
|
||||
|
|
|
|||
|
|
@ -18,17 +18,21 @@ limit syntax
|
|||
[LIMIT {[offset,] row_count | row_count OFFSET offset}]
|
||||
|
||||
> backtickQuotes :: TestItem
|
||||
> backtickQuotes = Group "backtickQuotes" $ map (uncurry (TestValueExpr MySQL))
|
||||
> backtickQuotes = Group "backtickQuotes" (map (uncurry (TestValueExpr MySQL))
|
||||
> [("`test`", Iden [DQName "`" "`" "test"])
|
||||
> ]
|
||||
|
||||
> ++ [ParseValueExprFails SQL2011 "`test`"]
|
||||
> )
|
||||
|
||||
> limit :: TestItem
|
||||
> limit = Group "queries" $ map (uncurry (TestQueryExpr MySQL))
|
||||
> 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)]
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
> | ParseQueryExpr Dialect String
|
||||
|
||||
check that the string given fails to parse
|
||||
|
||||
> | ParseQueryExprFails Dialect String
|
||||
> | ParseValueExprFails Dialect String
|
||||
> deriving (Eq,Show)
|
||||
|
|
|
|||
|
|
@ -68,6 +68,13 @@ order on the generated documentation.
|
|||
> 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) =>
|
||||
> (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a)
|
||||
> -> (Dialect -> a -> String)
|
||||
|
|
@ -109,3 +116,17 @@ order on the generated documentation.
|
|||
> ++ "\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
|
||||
|
|
|
|||
Loading…
Reference in a new issue