simple-sql-parser 0.2.0 → 0.3.0
raw patch · 16 files changed
+1043/−979 lines, 16 filesnew-component:exe:SQLIndent
Files
- Language/SQL/SimpleSQL/Fixity.lhs +0/−181
- Language/SQL/SimpleSQL/Parser.lhs +334/−290
- Language/SQL/SimpleSQL/Pretty.lhs +77/−78
- Language/SQL/SimpleSQL/Syntax.lhs +86/−59
- changelog +43/−4
- simple-sql-parser.cabal +22/−6
- tools/Language/SQL/SimpleSQL/FullQueries.lhs +6/−6
- tools/Language/SQL/SimpleSQL/GroupBy.lhs +6/−6
- tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs +36/−29
- tools/Language/SQL/SimpleSQL/QueryExprs.lhs +1/−1
- tools/Language/SQL/SimpleSQL/ScalarExprs.lhs +0/−304
- tools/Language/SQL/SimpleSQL/TableRefs.lhs +1/−1
- tools/Language/SQL/SimpleSQL/TestTypes.lhs +1/−1
- tools/Language/SQL/SimpleSQL/Tests.lhs +7/−13
- tools/Language/SQL/SimpleSQL/ValueExprs.lhs +407/−0
- tools/SQLIndent.lhs +16/−0
− Language/SQL/SimpleSQL/Fixity.lhs
@@ -1,181 +0,0 @@--This is the module which deals with fixing up the scalar expression-trees for the operator precedence and associativity (aka 'fixity').--It currently uses haskell-src-exts as a hack, the algorithm from there-should be ported to work on these trees natively. Maybe it could be-made generic to use in places other than the scalar expr parser?--> {-# LANGUAGE TupleSections #-}-> module Language.SQL.SimpleSQL.Fixity-> (fixFixities-> ,Fixity(..)-> ,Assoc(..)-> ,infixl_-> ,infixr_-> ,infix_-> ) where--> import qualified Language.Haskell.Exts.Syntax as HSE-> import qualified Language.Haskell.Exts.Fixity as HSE-> import Control.Monad.Identity-> import Control.Applicative-> import Data.Maybe--> import Language.SQL.SimpleSQL.Syntax--> data Fixity = Fixity String --name of op-> Assoc-> deriving (Eq,Show)--> data Assoc = AssocLeft | AssocRight | AssocNone-> deriving (Eq,Show)--> infixl_ :: [String] -> [Fixity]-> infixl_ = map (`Fixity` AssocLeft)--> infixr_ :: [String] -> [Fixity]-> infixr_ = map (`Fixity` AssocRight)--> infix_ :: [String] -> [Fixity]-> infix_ = map (`Fixity` AssocNone)--> toHSEFixity :: [[Fixity]] -> [HSE.Fixity]-> toHSEFixity fs =-> let fs' = zip [0..] $ reverse fs-> in concatMap f fs'-> where-> f :: (Int, [Fixity]) -> [HSE.Fixity]-> f (n,fs') = flip concatMap fs' $ \(Fixity nm assoc) ->-> case assoc of-> AssocLeft -> HSE.infixl_ n [nm]-> AssocRight -> HSE.infixr_ n [nm]-> AssocNone -> HSE.infix_ n [nm]--fix the fixities in the given scalar expr. All the expressions to be-fixed should be left associative and equal precedence to be fixed-correctly. It doesn't descend into query expressions in subqueries and-the scalar expressions they contain.--TODO: get it to work on prefix and postfix unary operators also maybe-it should work on some of the other syntax (such as in).--> fixFixities :: [[Fixity]] -> ScalarExpr -> ScalarExpr-> fixFixities fs se =-> runIdentity $ toSql <$> HSE.applyFixities (toHSEFixity fs) (toHaskell se)--Now have to convert all our scalar exprs to Haskell and back again.-Have to come up with a recipe for each ctor. Only continue if you have-a strong stomach. Probably would have been less effort to just write-the fixity code.--> toHaskell :: ScalarExpr -> HSE.Exp-> toHaskell e = case e of-> BinOp e0 op e1 -> HSE.InfixApp-> (toHaskell e0)-> (HSE.QVarOp $ sym $ name op)-> (toHaskell e1)-> Iden {} -> str ('v':show e)-> StringLit {} -> str ('v':show e)-> NumLit {} -> str ('v':show e)-> App n es -> HSE.App (var ('f':name n)) $ ltoh es-> Parens e0 -> HSE.Paren $ toHaskell e0-> IntervalLit {} -> str ('v':show e)-> Star -> str ('v':show e)-> AggregateApp nm d es od ->-> HSE.App (var ('a':name nm))-> $ HSE.List [str $ show (d,orderInf od)-> ,HSE.List $ map toHaskell es-> ,HSE.List $ orderExps od]-> WindowApp nm es pb od r ->-> HSE.App (var ('w':name nm))-> $ HSE.List [str $ show (orderInf od, r)-> ,HSE.List $ map toHaskell es-> ,HSE.List $ map toHaskell pb-> ,HSE.List $ orderExps od]-> PrefixOp nm e0 ->-> HSE.App (HSE.Var $ sym $ name nm) (toHaskell e0)-> PostfixOp nm e0 ->-> HSE.App (HSE.Var $ sym ('p':name nm)) (toHaskell e0)-> SpecialOp nm es ->-> HSE.App (var ('s':name nm)) $ HSE.List $ map toHaskell es-> -- map the two maybes to lists with either 0 or 1 element-> Case v ts el -> HSE.App (var "$case")-> (HSE.List [ltoh $ maybeToList v-> ,HSE.List $ map (ltoh . (\(a,b) -> b:a)) ts-> ,ltoh $ maybeToList el])-> Cast e0 tn -> HSE.App (str ('c':show tn)) $ toHaskell e0-> TypedLit {} -> str ('v':show e)-> SubQueryExpr {} -> str ('v': show e)-> In b e0 (InList l) ->-> HSE.App (str ('i':show b))-> $ HSE.List [toHaskell e0, HSE.List $ map toHaskell l]-> In b e0 i -> HSE.App (str ('j':show (b,i))) $ toHaskell e0-> where-> ltoh = HSE.List . map toHaskell-> str = HSE.Lit . HSE.String-> var = HSE.Var . HSE.UnQual . HSE.Ident-> sym = HSE.UnQual . HSE.Symbol-> name n = case n of-> QName q -> '"' : q-> Name m -> m-> orderExps = map (toHaskell . (\(OrderField a _ _) -> a))-> orderInf = map (\(OrderField _ b c) -> (b,c))-----> toSql :: HSE.Exp -> ScalarExpr-> toSql e = case e of---> HSE.InfixApp e0 (HSE.QVarOp (HSE.UnQual (HSE.Symbol n))) e1 ->-> BinOp (toSql e0) (unname n) (toSql e1)-> HSE.Lit (HSE.String ('v':l)) -> read l-> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('f':i))))-> (HSE.List es) -> App (unname i) $ map toSql es-> HSE.Paren e0 -> Parens $ toSql e0-> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('a':i))))-> (HSE.List [HSE.Lit (HSE.String vs)-> ,HSE.List es-> ,HSE.List od]) ->-> let (d,oinf) = read vs-> in AggregateApp (unname i) d (map toSql es)-> $ sord oinf od-> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('w':i))))-> (HSE.List [HSE.Lit (HSE.String vs)-> ,HSE.List es-> ,HSE.List pb-> ,HSE.List od]) ->-> let (oinf,r) = read vs-> in WindowApp (unname i) (map toSql es) (map toSql pb)-> (sord oinf od) r-> HSE.App (HSE.Var (HSE.UnQual (HSE.Symbol ('p':nm)))) e0 ->-> PostfixOp (unname nm) $ toSql e0-> HSE.App (HSE.Var (HSE.UnQual (HSE.Symbol nm))) e0 ->-> PrefixOp (unname nm) $ toSql e0-> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('s':nm)))) (HSE.List es) ->-> SpecialOp (unname nm) $ map toSql es-> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident "$case")))-> (HSE.List [v,ts,el]) ->-> Case (ltom v) (whens ts) (ltom el)-> HSE.App (HSE.Lit (HSE.String ('c':nm))) e0 ->-> Cast (toSql e0) (read nm)-> HSE.App (HSE.Lit (HSE.String ('i':nm)))-> (HSE.List [e0, HSE.List es]) ->-> In (read nm) (toSql e0) (InList $ map toSql es)-> HSE.App (HSE.Lit (HSE.String ('j':nm))) e0 ->-> let (b,sq) = read nm-> in In b (toSql e0) sq-> _ -> err e-> where-> sord = zipWith (\(i0,i1) ce -> OrderField (toSql ce) i0 i1)-> ltom (HSE.List []) = Nothing-> ltom (HSE.List [ex]) = Just $ toSql ex-> ltom ex = err ex-> whens (HSE.List l) = map (\(HSE.List (t:ws)) -> (map toSql ws, toSql t)) l-> whens ex = err ex-> err :: Show a => a -> e-> err a = error $ "simple-sql-parser: internal fixity error " ++ show a-> unname ('"':nm) = QName nm-> unname n = Name n
Language/SQL/SimpleSQL/Parser.lhs view
@@ -1,21 +1,28 @@ +> {-# LANGUAGE TupleSections #-} > -- | This is the module with the parser functions. > module Language.SQL.SimpleSQL.Parser > (parseQueryExpr-> ,parseScalarExpr+> ,parseValueExpr > ,parseQueryExprs > ,ParseError(..)) where -> import Control.Monad.Identity-> import Control.Applicative hiding (many, (<|>), optional)-> import Data.Maybe-> import Data.Char-> import Text.Parsec hiding (ParseError)-> import qualified Text.Parsec as P-> import Text.Parsec.Perm+> import Control.Monad.Identity (Identity)+> import Control.Monad (guard, void)+> import Control.Applicative ((<$), (<$>), (<*>) ,(<*), (*>))+> import Data.Maybe (fromMaybe,catMaybes)+> import Data.Char (toLower)+> import Text.Parsec (errorPos,sourceLine,sourceColumn,sourceName+> ,setPosition,setSourceColumn,setSourceLine,getPosition+> ,option,between,sepBy,sepBy1,string,manyTill,anyChar+> ,try,string,many1,oneOf,digit,(<|>),choice,char,eof+> ,optionMaybe,optional,many,letter,alphaNum,parse)+> import Text.Parsec.String (Parser)+> import qualified Text.Parsec as P (ParseError)+> import Text.Parsec.Perm (permute,(<$?>), (<|?>))+> import qualified Text.Parsec.Expr as E > import Language.SQL.SimpleSQL.Syntax-> import Language.SQL.SimpleSQL.Fixity The public API functions. @@ -23,32 +30,35 @@ > parseQueryExpr :: FilePath > -- ^ filename to use in errors > -> Maybe (Int,Int)-> -- ^ line number and column number to use in errors+> -- ^ line number and column number of the first character+> -- in the source (to use in errors) > -> String > -- ^ the SQL source to parse > -> Either ParseError QueryExpr > parseQueryExpr = wrapParse topLevelQueryExpr -> -- | Parses a list of query exprs, with semi colons between+> -- | Parses a list of query expressions, with semi colons between > -- them. The final semicolon is optional. > parseQueryExprs :: FilePath > -- ^ filename to use in errors > -> Maybe (Int,Int)-> -- ^ line number and column number to use in errors+> -- ^ line number and column number of the first character+> -- in the source (to use in errors) > -> String > -- ^ the SQL source to parse > -> Either ParseError [QueryExpr] > parseQueryExprs = wrapParse queryExprs -> -- | Parses a scalar expression.-> parseScalarExpr :: FilePath+> -- | Parses a value expression.+> parseValueExpr :: FilePath > -- ^ filename to use in errors > -> Maybe (Int,Int)-> -- ^ line number and column number to use in errors+> -- ^ line number and column number of the first character+> -- in the source (to use in errors) > -> String > -- ^ the SQL source to parse-> -> Either ParseError ScalarExpr-> parseScalarExpr = wrapParse scalarExpr+> -> Either ParseError ValueExpr+> parseValueExpr = wrapParse valueExpr This helper function takes the parser given and: @@ -57,7 +67,7 @@ checks the parser parses all the input using eof converts the error return to the nice wrapper -> wrapParse :: P a+> wrapParse :: Parser a > -> FilePath > -> Maybe (Int,Int) > -> String@@ -81,18 +91,16 @@ ------------------------------------------------ -> type P a = ParsecT String () Identity a--= scalar expressions+= value expressions == literals See the stringLiteral lexer below for notes on string literal syntax. -> estring :: P ScalarExpr+> estring :: Parser ValueExpr > estring = StringLit <$> stringLiteral -> number :: P ScalarExpr+> number :: Parser ValueExpr > number = NumLit <$> numberLiteral parse SQL interval literals, something like@@ -104,14 +112,14 @@ interval '3 days' which parses as a typed literal -> interval :: P ScalarExpr+> interval :: Parser ValueExpr > interval = try (keyword_ "interval" >> > IntervalLit > <$> stringLiteral > <*> identifierString > <*> optionMaybe (try $ parens integerLiteral)) -> literal :: P ScalarExpr+> literal :: Parser ValueExpr > literal = number <|> estring <|> interval == identifiers@@ -119,11 +127,11 @@ Uses the identifierString 'lexer'. See this function for notes on identifiers. -> name :: P Name+> name :: Parser Name > name = choice [QName <$> quotedIdentifier > ,Name <$> identifierString] -> identifier :: P ScalarExpr+> identifier :: Parser ValueExpr > identifier = Iden <$> name == star@@ -131,33 +139,40 @@ used in select *, select x.*, and agg(*) variations, and some other places as well. Because it is quite general, the parser doesn't attempt to check that the star is in a valid context, it parses it OK-in any scalar expression context.+in any value expression context. -> star :: P ScalarExpr+> star :: Parser ValueExpr > star = Star <$ symbol "*" +== parameter++use in e.g. select * from t where a = ?++> parameter :: Parser ValueExpr+> parameter = Parameter <$ symbol "?"+ == function application, aggregates and windows this represents anything which syntactically looks like regular C-function application: an identifier, parens with comma sep scalar+function application: an identifier, parens with comma sep value expression arguments. The parsing for the aggregate extensions is here as well: aggregate([all|distinct] args [order by orderitems]) -> aggOrApp :: P ScalarExpr+> aggOrApp :: Parser ValueExpr > aggOrApp = > makeApp > <$> name > <*> parens ((,,) <$> try duplicates-> <*> choice [commaSep scalarExpr']+> <*> choice [commaSep valueExpr] > <*> try (optionMaybe orderBy)) > where > makeApp i (Nothing,es,Nothing) = App i es > makeApp i (d,es,od) = AggregateApp i d es (fromMaybe [] od) -> duplicates :: P (Maybe Duplicates)+> duplicates :: Parser (Maybe SetQuantifier) > duplicates = optionMaybe $ try $ > choice [All <$ keyword_ "all" > ,Distinct <$ keyword "distinct"]@@ -172,7 +187,7 @@ parser names means that they have been left factored. These are almost always used with the optionSuffix combinator. -> windowSuffix :: ScalarExpr -> P ScalarExpr+> windowSuffix :: ValueExpr -> Parser ValueExpr > windowSuffix (App f es) = > try (keyword_ "over") > *> parens (WindowApp f es@@ -181,7 +196,7 @@ > <*> optionMaybe frameClause) > where > partitionBy = try (keyword_ "partition") >>-> keyword_ "by" >> commaSep1 scalarExpr'+> keyword_ "by" >> commaSep1 valueExpr > frameClause = > mkFrame <$> choice [FrameRows <$ keyword_ "rows" > ,FrameRange <$ keyword_ "range"]@@ -200,7 +215,7 @@ > choice [UnboundedPreceding <$ keyword_ "preceding" > ,UnboundedFollowing <$ keyword_ "following"] > ,do-> e <- if useB then scalarExprB else scalarExpr+> e <- if useB then valueExprB else valueExpr > choice [Preceding e <$ keyword_ "preceding" > ,Following e <$ keyword_ "following"] > ]@@ -209,21 +224,21 @@ > mkFrame rs c = c rs > windowSuffix _ = fail "" -> app :: P ScalarExpr+> app :: Parser ValueExpr > app = aggOrApp >>= optionSuffix windowSuffix == case expression -> scase :: P ScalarExpr+> scase :: Parser ValueExpr > scase =-> Case <$> (try (keyword_ "case") *> optionMaybe (try scalarExpr'))+> Case <$> (try (keyword_ "case") *> optionMaybe (try valueExpr)) > <*> many1 swhen-> <*> optionMaybe (try (keyword_ "else") *> scalarExpr')+> <*> optionMaybe (try (keyword_ "else") *> valueExpr) > <* keyword_ "end" > where > swhen = keyword_ "when" *>-> ((,) <$> commaSep1 scalarExpr'-> <*> (keyword_ "then" *> scalarExpr'))+> ((,) <$> commaSep1 valueExpr+> <*> (keyword_ "then" *> valueExpr)) == miscellaneous keyword operators @@ -234,50 +249,141 @@ cast: cast(expr as type) -> cast :: P ScalarExpr+> cast :: Parser ValueExpr > cast = parensCast <|> prefixCast > where > parensCast = try (keyword_ "cast") >>-> parens (Cast <$> scalarExpr'+> parens (Cast <$> valueExpr > <*> (keyword_ "as" *> typeName)) > prefixCast = try (TypedLit <$> typeName > <*> stringLiteral) -extract(id from expr)+the special op keywords+parse an operator which is+operatorname(firstArg keyword0 arg0 keyword1 arg1 etc.) -> extract :: P ScalarExpr-> extract = try (keyword_ "extract") >>-> parens (makeOp <$> name-> <*> (keyword_ "from" *> scalarExpr'))-> where makeOp n e = SpecialOp (Name "extract") [Iden n, e]+> data SpecialOpKFirstArg = SOKNone+> | SOKOptional+> | SOKMandatory -substring(x from expr to expr)+> specialOpK :: String -- name of the operator+> -> SpecialOpKFirstArg -- has a first arg without a keyword+> -> [(String,Bool)] -- the other args with their keywords+> -- and whether they are optional+> -> Parser ValueExpr+> specialOpK opName firstArg kws =+> keyword_ opName >> do+> void $ symbol "("+> let pfa = do+> e <- valueExpr+> -- check we haven't parsed the first+> -- keyword as an identifier+> guard (case (e,kws) of+> (Iden (Name i), (k,_):_) | map toLower i == k -> False+> _ -> True)+> return e+> fa <- case firstArg of+> SOKNone -> return Nothing+> SOKOptional -> optionMaybe (try pfa)+> SOKMandatory -> Just <$> pfa+> as <- mapM parseArg kws+> void $ symbol ")"+> return $ SpecialOpK (Name opName) fa $ catMaybes as+> where+> parseArg (nm,mand) =+> let p = keyword_ nm >> valueExpr+> in fmap (nm,) <$> if mand+> then Just <$> p+> else optionMaybe (try p) -todo: also support substring(x from expr)+The actual operators: -> substring :: P ScalarExpr-> substring = try (keyword_ "substring") >>-> parens (makeOp <$> scalarExpr'-> <*> (keyword_ "from" *> scalarExpr')-> <*> (keyword_ "for" *> scalarExpr')-> )-> where makeOp a b c = SpecialOp (Name "substring") [a,b,c]+EXTRACT( date_part FROM expression ) +POSITION( string1 IN string2 )++SUBSTRING(extraction_string FROM starting_position [FOR length]+[COLLATE collation_name])++CONVERT(char_value USING conversion_char_name)++TRANSLATE(char_value USING translation_name)++OVERLAY(string PLACING embedded_string FROM start+[FOR length])++TRIM( [ [{LEADING | TRAILING | BOTH}] [removal_char] FROM ]+target_string+[COLLATE collation_name] )++> specialOpKs :: Parser ValueExpr+> specialOpKs = choice $ map try+> [extract, position, substring, convert, translate, overlay, trim]++> extract :: Parser ValueExpr+> extract = specialOpK "extract" SOKMandatory [("from", True)]++> position :: Parser ValueExpr+> position = specialOpK "position" SOKMandatory [("in", True)]++strictly speaking, the substring must have at least one of from and+for, but the parser doens't enforce this++> substring :: Parser ValueExpr+> substring = specialOpK "substring" SOKMandatory+> [("from", False),("for", False),("collate", False)]++> convert :: Parser ValueExpr+> convert = specialOpK "convert" SOKMandatory [("using", True)]+++> translate :: Parser ValueExpr+> translate = specialOpK "translate" SOKMandatory [("using", True)]++> overlay :: Parser ValueExpr+> overlay = specialOpK "overlay" SOKMandatory+> [("placing", True),("from", True),("for", False)]++trim is too different because of the optional char, so a custom parser+the both ' ' is filled in as the default if either parts are missing+in the source++> trim :: Parser ValueExpr+> trim =+> keyword "trim" >>+> parens (mkTrim+> <$> option "both" sides+> <*> option " " stringLiteral+> <*> (keyword_ "from" *> valueExpr)+> <*> optionMaybe (keyword_ "collate" *> stringLiteral))+> where+> sides = choice ["leading" <$ keyword_ "leading"+> ,"trailing" <$ keyword_ "trailing"+> ,"both" <$ keyword_ "both"]+> mkTrim fa ch fr cl =+> SpecialOpK (Name "trim") Nothing+> $ catMaybes [Just (fa,StringLit ch)+> ,Just ("from", fr)+> ,fmap (("collate",) . StringLit) cl]+ in: two variations: a in (expr0, expr1, ...) a in (queryexpr) -> inSuffix :: ScalarExpr -> P ScalarExpr-> inSuffix e =-> In <$> inty-> <*> return e-> <*> parens (choice-> [InQueryExpr <$> queryExpr-> ,InList <$> commaSep1 scalarExpr'])+this is parsed as a postfix operator which is why it is in this form++> inSuffix :: Parser (ValueExpr -> ValueExpr)+> inSuffix =+> mkIn <$> inty+> <*> parens (choice+> [InQueryExpr <$> queryExpr+> ,InList <$> commaSep1 valueExpr]) > where > inty = try $ choice [True <$ keyword_ "in" > ,False <$ keyword_ "not" <* keyword_ "in"]+> mkIn i v = \e -> In i e v + between: expr between expr and expr @@ -287,26 +393,25 @@ postgres does, which might be standard across SQL implementations, which is that you can't have a binary and operator in the middle expression in a between unless it is wrapped in parens. The 'bExpr-parsing' is used to create alternative scalar expression parser which+parsing' is used to create alternative value expression parser which is identical to the normal one expect it doesn't recognise the binary-and operator. This is the call to scalarExpr'' True.+and operator. This is the call to valueExprB. -> betweenSuffix :: ScalarExpr -> P ScalarExpr-> betweenSuffix e =+> betweenSuffix :: Parser (ValueExpr -> ValueExpr)+> betweenSuffix = > makeOp <$> (Name <$> opName)-> <*> return e-> <*> scalarExpr'' True-> <*> (keyword_ "and" *> scalarExpr'' True)+> <*> valueExprB+> <*> (keyword_ "and" *> valueExprB) > where > opName = try $ choice > ["between" <$ keyword_ "between" > ,"not between" <$ keyword_ "not" <* keyword_ "between"]-> makeOp n a b c = SpecialOp n [a,b,c]+> makeOp n b c = \a -> SpecialOp n [a,b,c] subquery expression: [exists|all|any|some] (queryexpr) -> subquery :: P ScalarExpr+> subquery :: Parser ValueExpr > subquery = > choice > [try $ SubQueryExpr SqSq <$> parens queryExpr@@ -321,25 +426,47 @@ typename: used in casts. Special cases for the multi keyword typenames that SQL supports. -> typeName :: P TypeName-> typeName = choice-> [TypeName "double precision"-> <$ try (keyword_ "double" <* keyword_ "precision")-> ,TypeName "character varying"-> <$ try (keyword_ "character" <* keyword_ "varying")-> ,TypeName <$> identifierString] >>= optionSuffix precision+> typeName :: Parser TypeName+> typeName = choice (multiWordParsers+> ++ [TypeName <$> identifierString])+> >>= optionSuffix precision > where+> multiWordParsers =+> flip map multiWordTypeNames+> $ \ks -> (TypeName . unwords) <$> try (mapM keyword ks)+> multiWordTypeNames = map words+> ["double precision"+> ,"character varying"+> ,"char varying"+> ,"character large object"+> ,"char large object"+> ,"national character"+> ,"national char"+> ,"national character varying"+> ,"national char varying"+> ,"national character large object"+> ,"nchar large object"+> ,"nchar varying"+> ,"bit varying"+> ]++todo: timestamp types:++ | TIME [ <left paren> <time precision> <right paren> ] [ WITH TIME ZONE ]+ | TIMESTAMParser [ <left paren> <timestamp precision> <right paren> ] [ WITH TIME ZONE ]++ > precision t = try (parens (commaSep integerLiteral)) >>= makeWrap t > makeWrap (TypeName t) [a] = return $ PrecTypeName t a > makeWrap (TypeName t) [a,b] = return $ PrecScaleTypeName t a b > makeWrap _ _ = fail "there must be one or two precision components" -== scalar parens and row ctor+== value expression parens and row ctor -> sparens :: P ScalarExpr+> sparens :: Parser ValueExpr > sparens =-> ctor <$> parens (commaSep1 scalarExpr')+> ctor <$> parens (commaSep1 valueExpr) > where > ctor [a] = Parens a > ctor as = SpecialOp (Name "rowctor") as@@ -352,177 +479,94 @@ can be symbols (a + b), single keywords (a and b) or multiple keywords (a is similar to b). -First, the list of the regulars operators split by operator type-(prefix, postfix, binary) and by symbol/single keyword/ multiple-keyword.--> binOpSymbolNames :: [String]-> binOpSymbolNames =-> ["=", "<=", ">=", "!=", "<>", "<", ">"-> ,"*", "/", "+", "-", "%"-> ,"||", "."-> ,"^", "|", "&"-> ]--> binOpKeywordNames :: [String]-> binOpKeywordNames = ["and", "or", "like", "overlaps"]--> binOpMultiKeywordNames :: [[String]]-> binOpMultiKeywordNames = map words-> ["not like"-> ,"is similar to"-> ,"is not similar to"-> ,"is distinct from"-> ,"is not distinct from"]--used for between parsing--> binOpKeywordNamesNoAnd :: [String]-> binOpKeywordNamesNoAnd = filter (/="and") binOpKeywordNames--There aren't any multi keyword prefix operators currently supported.--> prefixUnOpKeywordNames :: [String]-> prefixUnOpKeywordNames = ["not"]--> prefixUnOpSymbolNames :: [String]-> prefixUnOpSymbolNames = ["+", "-", "~"]--There aren't any single keyword postfix operators currently-supported. Maybe all these 'is's can be left factored?--> postfixOpKeywords :: [String]-> postfixOpKeywords = ["is null"-> ,"is not null"-> ,"is true"-> ,"is not true"-> ,"is false"-> ,"is not false"-> ,"is unknown"-> ,"is not unknown"]--The parsers:--> prefixUnaryOp :: P ScalarExpr-> prefixUnaryOp =-> PrefixOp <$> (Name <$> opSymbol) <*> scalarExpr'-> where-> opSymbol = choice (map (try . symbol) prefixUnOpSymbolNames-> ++ map (try . keyword) prefixUnOpKeywordNames)--TODO: the handling of multikeyword args is different in-postfixopsuffix and binaryoperatorsuffix. It should be the same in-both cases--> postfixOpSuffix :: ScalarExpr -> P ScalarExpr-> postfixOpSuffix e =-> try $ choice $ map makeOp opPairs-> where-> opPairs = flip map postfixOpKeywords $ \o -> (o, words o)-> makeOp (o,ws) = try $ PostfixOp (Name o) e <$ keywords_ ws-> keywords_ = try . mapM_ keyword_--All the binary operators are parsed as same precedence and left-associativity. This is fixed with a separate pass over the AST.--> binaryOperatorSuffix :: Bool -> ScalarExpr -> P ScalarExpr-> binaryOperatorSuffix bExpr e0 =-> BinOp e0 <$> (Name <$> opSymbol) <*> factor-> where-> opSymbol = choice-> (map (try . symbol) binOpSymbolNames-> ++ map (try . keywords) binOpMultiKeywordNames-> ++ map (try . keyword)-> (if bExpr-> then binOpKeywordNamesNoAnd-> else binOpKeywordNames))-> keywords ks = unwords <$> mapM keyword ks+TODO: carefully review the precedences and associativities. -> sqlFixities :: [[Fixity]]-> sqlFixities = highPrec ++ defaultPrec ++ lowPrec+> opTable :: Bool -> [[E.Operator String () Identity ValueExpr]]+> opTable bExpr =+> [[binarySym "." E.AssocLeft]+> ,[prefixSym "+", prefixSym "-"]+> ,[binarySym "^" E.AssocLeft]+> ,[binarySym "*" E.AssocLeft+> ,binarySym "/" E.AssocLeft+> ,binarySym "%" E.AssocLeft]+> ,[binarySym "+" E.AssocLeft+> ,binarySym "-" E.AssocLeft]+> ,[binarySym ">=" E.AssocNone+> ,binarySym "<=" E.AssocNone+> ,binarySym "!=" E.AssocRight+> ,binarySym "<>" E.AssocRight+> ,binarySym "||" E.AssocRight+> ,prefixSym "~"+> ,binarySym "&" E.AssocRight+> ,binarySym "|" E.AssocRight+> ,binaryKeyword "like" E.AssocNone+> ,binaryKeyword "overlaps" E.AssocNone]+> ++ map (`binaryKeywords` E.AssocNone)+> ["not like"+> ,"is similar to"+> ,"is not similar to"+> ,"is distinct from"+> ,"is not distinct from"]+> ++ map postfixKeywords+> ["is null"+> ,"is not null"+> ,"is true"+> ,"is not true"+> ,"is false"+> ,"is not false"+> ,"is unknown"+> ,"is not unknown"]+> ++ [E.Postfix $ try inSuffix,E.Postfix $ try betweenSuffix]+> ]+> +++> [[binarySym "<" E.AssocNone+> ,binarySym ">" E.AssocNone]+> ,[binarySym "=" E.AssocRight]+> ,[prefixKeyword "not"]]+> +++> if bExpr then [] else [[binaryKeyword "and" E.AssocLeft]]+> +++> [[binaryKeyword "or" E.AssocLeft]] > where-> allOps = binOpSymbolNames ++ binOpKeywordNames-> ++ map unwords binOpMultiKeywordNames-> ++ prefixUnOpKeywordNames ++ prefixUnOpSymbolNames-> ++ postfixOpKeywords-> -- these are the ops with the highest precedence in order-> highPrec = [infixl_ ["."]-> ,infixl_ ["*","/", "%"]-> ,infixl_ ["+", "-"]-> ,infixl_ ["<=",">=","!=","<>","||","like"]-> ]-> -- these are the ops with the lowest precedence in order-> lowPrec = [infix_ ["<",">"]-> ,infixr_ ["="]-> ,infixr_ ["not"]-> ,infixl_ ["and"]-> ,infixl_ ["or"]]-> already = concatMap (map fName) highPrec-> ++ concatMap (map fName) lowPrec-> -- all the other ops have equal precedence and go between the-> -- high and low precedence ops-> defaultPrecOps = filter (`notElem` already) allOps-> -- almost correct, have to do some more work to-> -- get the associativity correct for these operators-> defaultPrec = [infixl_ defaultPrecOps]-> fName (Fixity n _) = n-+> binarySym nm assoc = binary (try $ symbol_ nm) nm assoc+> binaryKeyword nm assoc = binary (try $ keyword_ nm) nm assoc+> binaryKeywords nm assoc = binary (try $ mapM_ keyword_ (words nm)) nm assoc+> binary p nm assoc =+> E.Infix (p >> return (\a b -> BinOp a (Name nm) b)) assoc+> prefixKeyword nm = prefix (try $ keyword_ nm) nm+> prefixSym nm = prefix (try $ symbol_ nm) nm+> prefix p nm = E.Prefix (p >> return (PrefixOp (Name nm)))+> postfixKeywords nm = postfix (try $ mapM_ keyword_ (words nm)) nm+> postfix p nm = E.Postfix (p >> return (PostfixOp (Name nm))) -== scalar expressions+== value expressions TODO: left factor stuff which starts with identifier -This parses most of the scalar exprs. I'm not sure if factor is the-correct terminology here. The order of the parsers and use of try is-carefully done to make everything work. It is a little fragile and-could at least do with some heavy explanation.--> factor :: P ScalarExpr-> factor = choice [literal-> ,scase-> ,cast-> ,extract-> ,substring-> ,subquery-> ,prefixUnaryOp-> ,try app-> ,try star-> ,identifier-> ,sparens]--putting the factor together with the extra bits--> scalarExpr'' :: Bool -> P ScalarExpr-> scalarExpr'' bExpr = factor >>= trysuffix-> where-> trysuffix e = try (suffix e) <|> return e-> suffix e0 = choice-> [binaryOperatorSuffix bExpr e0-> ,inSuffix e0-> ,betweenSuffix e0-> ,postfixOpSuffix e0-> ] >>= trysuffix--Wrapper for non 'bExpr' parsing. See the between parser for-explanation.--> scalarExpr' :: P ScalarExpr-> scalarExpr' = scalarExpr'' False+This parses most of the value exprs.The order of the parsers and use+of try is carefully done to make everything work. It is a little+fragile and could at least do with some heavy explanation. -The scalarExpr wrapper. The idea is that directly nested scalar-expressions use the scalarExpr' parser, then other code uses the-scalarExpr parser and then everyone gets the fixity fixes and it's-easy to ensure that this fix is only applied once to each scalar-expression tree (for efficiency and code clarity).+> valueExpr :: Parser ValueExpr+> valueExpr = E.buildExpressionParser (opTable False) term -> scalarExpr :: P ScalarExpr-> scalarExpr = fixFixities sqlFixities <$> scalarExpr'+> term :: Parser ValueExpr+> term = choice [literal+> ,parameter+> ,scase+> ,cast+> ,try specialOpKs+> ,subquery+> ,try app+> ,try star+> ,identifier+> ,sparens] expose the b expression for window frame clause range between -> scalarExprB :: P ScalarExpr-> scalarExprB = fixFixities sqlFixities <$> scalarExpr'' True+> valueExprB :: Parser ValueExpr+> valueExprB = E.buildExpressionParser (opTable True) term -------------------------------------------------@@ -531,11 +575,11 @@ == select lists -> selectItem :: P (Maybe Name, ScalarExpr)-> selectItem = flip (,) <$> scalarExpr <*> optionMaybe (try als)+> selectItem :: Parser (ValueExpr,Maybe Name)+> selectItem = (,) <$> valueExpr <*> optionMaybe (try als) > where als = optional (try (keyword_ "as")) *> name -> selectList :: P [(Maybe Name,ScalarExpr)]+> selectList :: Parser [(ValueExpr,Maybe Name)] > selectList = commaSep1 selectItem == from@@ -547,7 +591,7 @@ tref [on expr | using (...)] -> from :: P [TableRef]+> from :: Parser [TableRef] > from = try (keyword_ "from") *> commaSep1 tref > where > tref = nonJoinTref >>= optionSuffix joinTrefSuffix@@ -556,7 +600,7 @@ > ,TRLateral <$> (try (keyword_ "lateral") > *> nonJoinTref) > ,try (TRFunction <$> name-> <*> parens (commaSep scalarExpr))+> <*> parens (commaSep valueExpr)) > ,TRSimple <$> name] > >>= optionSuffix aliasSuffix > aliasSuffix j = option j (TRAlias j <$> alias)@@ -579,12 +623,12 @@ > joinCondition nat = > choice [guard nat >> return JoinNatural > ,try (keyword_ "on") >>-> JoinOn <$> scalarExpr+> JoinOn <$> valueExpr > ,try (keyword_ "using") >> > JoinUsing <$> parens (commaSep1 name) > ] -> alias :: P Alias+> alias :: Parser Alias > alias = Alias <$> try tableAlias <*> try columnAliases > where > tableAlias = optional (try $ keyword_ "as") *> name@@ -598,13 +642,13 @@ Here is a helper for parsing a few parts of the query expr (currently where, having, limit, offset). -> keywordScalarExpr :: String -> P ScalarExpr-> keywordScalarExpr k = try (keyword_ k) *> scalarExpr+> keywordValueExpr :: String -> Parser ValueExpr+> keywordValueExpr k = try (keyword_ k) *> valueExpr -> swhere :: P ScalarExpr-> swhere = keywordScalarExpr "where"+> swhere :: Parser ValueExpr+> swhere = keywordValueExpr "where" -> sgroupBy :: P [GroupingExpr]+> sgroupBy :: Parser [GroupingExpr] > sgroupBy = try (keyword_ "group") > *> keyword_ "by" > *> commaSep1 groupingExpression@@ -618,17 +662,17 @@ > ,GroupingParens <$> parens (commaSep groupingExpression) > ,try (keyword_ "grouping") >> keyword_ "sets" >> > GroupingSets <$> parens (commaSep groupingExpression)-> ,SimpleGroup <$> scalarExpr+> ,SimpleGroup <$> valueExpr > ] -> having :: P ScalarExpr-> having = keywordScalarExpr "having"+> having :: Parser ValueExpr+> having = keywordValueExpr "having" -> orderBy :: P [OrderField]+> orderBy :: Parser [SortSpec] > orderBy = try (keyword_ "order") *> keyword_ "by" *> commaSep1 ob > where-> ob = OrderField-> <$> scalarExpr+> ob = SortSpec+> <$> valueExpr > <*> option Asc (choice [Asc <$ keyword_ "asc" > ,Desc <$ keyword_ "desc"]) > <*> option NullsOrderDefault@@ -639,27 +683,27 @@ allows offset and fetch in either order + postgresql offset without row(s) and limit instead of fetch also -> offsetFetch :: P (Maybe ScalarExpr, Maybe ScalarExpr)+> offsetFetch :: Parser (Maybe ValueExpr, Maybe ValueExpr) > offsetFetch = permute ((,) <$?> (Nothing, Just <$> offset) > <|?> (Nothing, Just <$> fetch)) -> offset :: P ScalarExpr-> offset = try (keyword_ "offset") *> scalarExpr+> offset :: Parser ValueExpr+> offset = try (keyword_ "offset") *> valueExpr > <* option () (try $ choice [try (keyword_ "rows"),keyword_ "row"]) -> fetch :: P ScalarExpr+> fetch :: Parser ValueExpr > fetch = choice [ansiFetch, limit] > where > ansiFetch = try (keyword_ "fetch") >> > choice [keyword_ "first",keyword_ "next"]-> *> scalarExpr+> *> valueExpr > <* choice [keyword_ "rows",keyword_ "row"] > <* keyword_ "only"-> limit = try (keyword_ "limit") *> scalarExpr+> limit = try (keyword_ "limit") *> valueExpr == common table expressions -> with :: P QueryExpr+> with :: Parser QueryExpr > with = try (keyword_ "with") >> > With <$> option False (try (True <$ keyword_ "recursive")) > <*> commaSep1 withQuery <*> queryExpr@@ -673,7 +717,7 @@ This parser parses any query expression variant: normal select, cte, and union, etc.. -> queryExpr :: P QueryExpr+> queryExpr :: Parser QueryExpr > queryExpr = > choice [with > ,choice [values,table, select]@@ -692,10 +736,10 @@ > mkSelect d sl f w g h od (ofs,fe) = > Select d sl f w g h od ofs fe > values = try (keyword_ "values")-> >> Values <$> commaSep (parens (commaSep scalarExpr))+> >> Values <$> commaSep (parens (commaSep valueExpr)) > table = try (keyword_ "table") >> Table <$> name -> queryExprSuffix :: QueryExpr -> P QueryExpr+> queryExprSuffix :: QueryExpr -> Parser QueryExpr > queryExprSuffix qe = > (CombineQueryExpr qe > <$> try (choice@@ -710,7 +754,7 @@ wrapper for query expr which ignores optional trailing semicolon. -> topLevelQueryExpr :: P QueryExpr+> topLevelQueryExpr :: Parser QueryExpr > topLevelQueryExpr = > queryExpr >>= optionSuffix ((symbol ";" *>) . return) @@ -718,7 +762,7 @@ must be separated by semicolon, but for the last expression, the trailing semicolon is optional. -> queryExprs :: P [QueryExpr]+> queryExprs :: Parser [QueryExpr] > queryExprs = > (:[]) <$> queryExpr > >>= optionSuffix ((symbol ";" *>) . return)@@ -734,24 +778,24 @@ string, digit, etc.), except for the parsers which only indirectly access them via these functions, if you follow? -> symbol :: String -> P String+> symbol :: String -> Parser String > symbol s = string s > -- <* notFollowedBy (oneOf "+-/*<>=!|") > <* whiteSpace -> symbol_ :: String -> P ()+> symbol_ :: String -> Parser () > symbol_ s = symbol s *> return () TODO: now that keyword has try in it, a lot of the trys above can be removed -> keyword :: String -> P String+> keyword :: String -> Parser String > keyword s = try $ do > i <- identifierRaw > guard (map toLower i == map toLower s) > return i -> keyword_ :: String -> P ()+> keyword_ :: String -> Parser () > keyword_ s = keyword s *> return () Identifiers are very simple at the moment: start with a letter or@@ -762,14 +806,14 @@ the identifier raw doesn't check the blacklist since it is used by the keyword parser also -> identifierRaw :: P String+> identifierRaw :: Parser String > identifierRaw = (:) <$> letterOrUnderscore > <*> many letterDigitOrUnderscore <* whiteSpace > where > letterOrUnderscore = char '_' <|> letter > letterDigitOrUnderscore = char '_' <|> alphaNum -> identifierString :: P String+> identifierString :: Parser String > identifierString = do > s <- identifierRaw > guard (map toLower s `notElem` blacklist)@@ -791,14 +835,14 @@ could be tuned differently for each place the identifierString/ identifier parsers are used to only blacklist the bare minimum. -> quotedIdentifier :: P String+> quotedIdentifier :: Parser String > quotedIdentifier = char '"' *> manyTill anyChar (symbol_ "\"") String literals: limited at the moment, no escaping \' or other variations. -> stringLiteral :: P String+> stringLiteral :: Parser String > stringLiteral = (char '\'' *> manyTill anyChar (char '\'') > >>= optionSuffix moreString) <* whiteSpace > where@@ -820,7 +864,7 @@ making a decision on how to represent numbers, the client code can make this choice. -> numberLiteral :: P String+> numberLiteral :: Parser String > numberLiteral = > choice [int > >>= optionSuffix dot@@ -841,12 +885,12 @@ lexer for integer literals which appear in some places in SQL -> integerLiteral :: P Int+> integerLiteral :: Parser Int > integerLiteral = read <$> many1 digit <* whiteSpace whitespace parser which skips comments also -> whiteSpace :: P ()+> whiteSpace :: Parser () > whiteSpace = > choice [simpleWhiteSpace *> whiteSpace > ,lineComment *> whiteSpace@@ -869,24 +913,24 @@ all these uses and figure out if any should be right associative instead, and create an alternative suffix parser -> optionSuffix :: (a -> P a) -> a -> P a+> optionSuffix :: (a -> Parser a) -> a -> Parser a > optionSuffix p a = option a (p a) -> parens :: P a -> P a+> parens :: Parser a -> Parser a > parens = between (symbol_ "(") (symbol_ ")") -> commaSep :: P a -> P [a]+> commaSep :: Parser a -> Parser [a] > commaSep = (`sepBy` symbol_ ",") -> commaSep1 :: P a -> P [a]+> commaSep1 :: Parser a -> Parser [a] > commaSep1 = (`sepBy1` symbol_ ",") -------------------------------------------- = helper functions -> setPos :: Maybe (Int,Int) -> P ()+> setPos :: Maybe (Int,Int) -> Parser () > setPos Nothing = return () > setPos (Just (l,c)) = fmap f getPosition >>= setPosition > where f = flip setSourceColumn c
Language/SQL/SimpleSQL/Pretty.lhs view
@@ -4,61 +4,67 @@ > -- readable way. > module Language.SQL.SimpleSQL.Pretty > (prettyQueryExpr-> ,prettyScalarExpr+> ,prettyValueExpr > ,prettyQueryExprs > ) where +TODO: there should be more comments in this file, especially the bits+which have been changed to try to improve the layout of the output.+ > import Language.SQL.SimpleSQL.Syntax-> import Text.PrettyPrint-> import Data.Maybe+> import Text.PrettyPrint (render, vcat, text, (<>), (<+>), empty, parens,+> nest, Doc, punctuate, comma, sep, quotes,+> doubleQuotes)+> import Data.Maybe (maybeToList, catMaybes) > -- | Convert a query expr ast to concrete syntax. > prettyQueryExpr :: QueryExpr -> String > prettyQueryExpr = render . queryExpr -> -- | Convert a scalar expr ast to concrete syntax.-> prettyScalarExpr :: ScalarExpr -> String-> prettyScalarExpr = render . scalarExpr+> -- | Convert a value expr ast to concrete syntax.+> prettyValueExpr :: ValueExpr -> String+> prettyValueExpr = render . valueExpr > -- | Convert a list of query exprs to concrete syntax. A semi colon > -- is inserted after each query expr. > prettyQueryExprs :: [QueryExpr] -> String > prettyQueryExprs = render . vcat . map ((<> text ";\n") . queryExpr) -= scalar expressions+= value expressions -> scalarExpr :: ScalarExpr -> Doc-> scalarExpr (StringLit s) = quotes $ text $ doubleUpQuotes s+> valueExpr :: ValueExpr -> Doc+> valueExpr (StringLit s) = quotes $ text $ doubleUpQuotes s > where doubleUpQuotes [] = [] > doubleUpQuotes ('\'':cs) = '\'':'\'':doubleUpQuotes cs > doubleUpQuotes (c:cs) = c:doubleUpQuotes cs -> scalarExpr (NumLit s) = text s-> scalarExpr (IntervalLit v u p) =+> valueExpr (NumLit s) = text s+> valueExpr (IntervalLit v u p) = > text "interval" <+> quotes (text v) > <+> text u > <+> maybe empty (parens . text . show ) p-> scalarExpr (Iden i) = name i-> scalarExpr Star = text "*"+> valueExpr (Iden i) = name i+> valueExpr Star = text "*"+> valueExpr Parameter = text "?" -> scalarExpr (App f es) = name f <> parens (commaSep (map scalarExpr es))+> valueExpr (App f es) = name f <> parens (commaSep (map valueExpr es)) -> scalarExpr (AggregateApp f d es od) =+> valueExpr (AggregateApp f d es od) = > name f > <> parens ((case d of > Just Distinct -> text "distinct" > Just All -> text "all" > Nothing -> empty)-> <+> commaSep (map scalarExpr es)+> <+> commaSep (map valueExpr es) > <+> orderBy od) -> scalarExpr (WindowApp f es pb od fr) =-> name f <> parens (commaSep $ map scalarExpr es)+> valueExpr (WindowApp f es pb od fr) =+> name f <> parens (commaSep $ map valueExpr es) > <+> text "over" > <+> parens ((case pb of > [] -> empty > _ -> text "partition by"-> <+> nest 13 (commaSep $ map scalarExpr pb))+> <+> nest 13 (commaSep $ map valueExpr pb)) > <+> orderBy od > <+> maybe empty frd fr) > where@@ -72,71 +78,64 @@ > fpd UnboundedPreceding = text "unbounded preceding" > fpd UnboundedFollowing = text "unbounded following" > fpd Current = text "current row"-> fpd (Preceding e) = scalarExpr e <+> text "preceding"-> fpd (Following e) = scalarExpr e <+> text "following"+> fpd (Preceding e) = valueExpr e <+> text "preceding"+> fpd (Following e) = valueExpr e <+> text "following" -> scalarExpr (SpecialOp nm [a,b,c]) | nm `elem` [Name "between"+> valueExpr (SpecialOp nm [a,b,c]) | nm `elem` [Name "between" > ,Name "not between"] =-> sep [scalarExpr a-> ,name nm <+> scalarExpr b-> ,nest (length (unname nm) + 1) $ text "and" <+> scalarExpr c]--> scalarExpr (SpecialOp (Name "extract") [a,n]) =-> text "extract" <> parens (scalarExpr a-> <+> text "from"-> <+> scalarExpr n)+> sep [valueExpr a+> ,name nm <+> valueExpr b+> ,nest (length (unname nm) + 1) $ text "and" <+> valueExpr c] -> scalarExpr (SpecialOp (Name "substring") [a,s,e]) =-> text "substring" <> parens (scalarExpr a-> <+> text "from"-> <+> scalarExpr s-> <+> text "for"-> <+> scalarExpr e)+> valueExpr (SpecialOp (Name "rowctor") as) =+> parens $ commaSep $ map valueExpr as -> scalarExpr (SpecialOp (Name "rowctor") as) =-> parens $ commaSep $ map scalarExpr as+> valueExpr (SpecialOp nm es) =+> name nm <+> parens (commaSep $ map valueExpr es) -> scalarExpr (SpecialOp nm es) =-> name nm <+> parens (commaSep $ map scalarExpr es)+> valueExpr (SpecialOpK nm fs as) =+> name nm <> parens (sep $ catMaybes+> (fmap valueExpr fs+> : map (\(n,e) -> Just (text n <+> valueExpr e)) as)) -> scalarExpr (PrefixOp f e) = name f <+> scalarExpr e-> scalarExpr (PostfixOp f e) = scalarExpr e <+> name f-> scalarExpr e@(BinOp _ op _) | op `elem` [Name "and", Name "or"] =+> valueExpr (PrefixOp f e) = name f <+> valueExpr e+> valueExpr (PostfixOp f e) = valueExpr e <+> name f+> valueExpr 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 (scalarExpr e'-> : map ((name op <+>) . scalarExpr) es)+> (e':es) -> vcat (valueExpr e'+> : map ((name op <+>) . valueExpr) 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-> scalarExpr (BinOp e0 (Name ".") e1) =-> scalarExpr e0 <> text "." <> scalarExpr e1-> scalarExpr (BinOp e0 f e1) =-> scalarExpr e0 <+> name f <+> scalarExpr e1+> valueExpr (BinOp e0 (Name ".") e1) =+> valueExpr e0 <> text "." <> valueExpr e1+> valueExpr (BinOp e0 f e1) =+> valueExpr e0 <+> name f <+> valueExpr e1 -> scalarExpr (Case t ws els) =-> sep $ [text "case" <+> maybe empty scalarExpr t]+> valueExpr (Case t ws els) =+> sep $ [text "case" <+> maybe empty valueExpr t] > ++ map w ws > ++ maybeToList (fmap e els) > ++ [text "end"] > where > w (t0,t1) =-> text "when" <+> nest 5 (commaSep $ map scalarExpr t0)-> <+> text "then" <+> nest 5 (scalarExpr t1)-> e el = text "else" <+> nest 5 (scalarExpr el)-> scalarExpr (Parens e) = parens $ scalarExpr e-> scalarExpr (Cast e tn) =-> text "cast" <> parens (sep [scalarExpr e+> 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 "as" > ,typeName tn]) -> scalarExpr (TypedLit tn s) =+> valueExpr (TypedLit tn s) = > typeName tn <+> quotes (text s) -> scalarExpr (SubQueryExpr ty qe) =+> valueExpr (SubQueryExpr ty qe) = > (case ty of > SqSq -> empty > SqExists -> text "exists"@@ -145,13 +144,13 @@ > SqAny -> text "any" > ) <+> parens (queryExpr qe) -> scalarExpr (In b se x) =-> scalarExpr se <+>+> valueExpr (In b se x) =+> valueExpr se <+> > (if b then empty else text "not") > <+> text "in" > <+> parens (nest (if b then 3 else 7) $ > case x of-> InList es -> commaSep $ map scalarExpr es+> InList es -> commaSep $ map valueExpr es > InQueryExpr qe -> queryExpr qe) > unname :: Name -> String@@ -179,12 +178,12 @@ > Distinct -> text "distinct" > ,nest 7 $ sep [selectList sl] > ,from fr-> ,maybeScalarExpr "where" wh+> ,maybeValueExpr "where" wh > ,grpBy gb-> ,maybeScalarExpr "having" hv+> ,maybeValueExpr "having" hv > ,orderBy od-> ,maybe empty (\e -> text "offset" <+> scalarExpr e <+> text "rows") off-> ,maybe empty (\e -> text "fetch next" <+> scalarExpr e+> ,maybe empty (\e -> text "offset" <+> valueExpr e <+> text "rows") off+> ,maybe empty (\e -> text "fetch first" <+> valueExpr e > <+> text "rows only") fe > ] > queryExpr (CombineQueryExpr q1 ct d c q2) =@@ -208,7 +207,7 @@ > ,queryExpr qe] > queryExpr (Values vs) = > text "values"-> <+> nest 7 (commaSep (map (parens . commaSep . map scalarExpr) vs))+> <+> nest 7 (commaSep (map (parens . commaSep . map valueExpr) vs)) > queryExpr (Table t) = text "table" <+> name t @@ -217,10 +216,10 @@ > text "as" <+> name nm > <+> maybe empty (parens . commaSep . map name) cols -> selectList :: [(Maybe Name, ScalarExpr)] -> Doc+> selectList :: [(ValueExpr,Maybe Name)] -> Doc > selectList is = commaSep $ map si is > where-> si (al,e) = scalarExpr e <+> maybe empty als al+> si (e,al) = valueExpr e <+> maybe empty als al > als al = text "as" <+> name al > from :: [TableRef] -> Doc@@ -232,7 +231,7 @@ > tr (TRSimple t) = name t > tr (TRLateral t) = text "lateral" <+> tr t > tr (TRFunction f as) =-> name f <> parens (commaSep $ map scalarExpr as)+> name f <> parens (commaSep $ map valueExpr as) > tr (TRAlias t a) = sep [tr t, alias a] > tr (TRParens t) = parens $ tr t > tr (TRQueryExpr q) = parens $ queryExpr q@@ -251,35 +250,35 @@ > JFull -> text "full" > JCross -> text "cross" > ,text "join"]-> joinCond (Just (JoinOn e)) = text "on" <+> scalarExpr e+> joinCond (Just (JoinOn e)) = text "on" <+> valueExpr e > joinCond (Just (JoinUsing es)) = > text "using" <+> parens (commaSep $ map name es) > joinCond Nothing = empty > joinCond (Just JoinNatural) = empty -> maybeScalarExpr :: String -> Maybe ScalarExpr -> Doc-> maybeScalarExpr k = maybe empty+> maybeValueExpr :: String -> Maybe ValueExpr -> Doc+> maybeValueExpr k = maybe empty > (\e -> sep [text k-> ,nest (length k + 1) $ scalarExpr e])+> ,nest (length k + 1) $ valueExpr e]) > grpBy :: [GroupingExpr] -> Doc > grpBy [] = empty > grpBy gs = sep [text "group by" > ,nest 9 $ commaSep $ map ge gs] > where-> ge (SimpleGroup e) = scalarExpr e+> ge (SimpleGroup e) = valueExpr 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 :: [OrderField] -> Doc+> orderBy :: [SortSpec] -> Doc > orderBy [] = empty > orderBy os = sep [text "order by" > ,nest 9 $ commaSep $ map f os] > where-> f (OrderField e d n) =-> scalarExpr e+> f (SortSpec e d n) =+> valueExpr e > <+> (if d == Asc then empty else text "desc") > <+> (case n of > NullsOrderDefault -> empty
Language/SQL/SimpleSQL/Syntax.lhs view
@@ -1,15 +1,15 @@ > -- | The AST for SQL queries. > module Language.SQL.SimpleSQL.Syntax-> (-- * Scalar expressions-> ScalarExpr(..)+> (-- * Value expressions+> ValueExpr(..) > ,Name(..) > ,TypeName(..)-> ,Duplicates(..)-> ,OrderField(..)+> ,SetQuantifier(..)+> ,SortSpec(..) > ,Direction(..) > ,NullsOrder(..)-> ,InThing(..)+> ,InPredValue(..) > ,SubQueryExprType(..) > ,Frame(..) > ,FrameRows(..)@@ -27,8 +27,11 @@ > ,JoinCondition(..) > ) where -> -- | Represents a scalar expression.-> data ScalarExpr++> -- | Represents a value expression. This is used for the expressions+> -- in select lists. It is also used for expressions in where, group+> -- by, having, order by and so on.+> data ValueExpr > = -- | a numeric literal optional decimal point, e+- > -- integral exponent, e.g > --@@ -60,62 +63,68 @@ > | Star > -- | function application (anything that looks like c style > -- function application syntactically)-> | App Name [ScalarExpr]+> | App Name [ValueExpr] > -- | aggregate application, which adds distinct or all, and > -- order by, to regular function application > | AggregateApp > {aggName :: Name -- ^ aggregate function name-> ,aggDistinct :: Maybe Duplicates -- ^ distinct-> ,aggArgs :: [ScalarExpr]-- ^ args-> ,aggOrderBy :: [OrderField] -- ^ order by+> ,aggDistinct :: Maybe SetQuantifier -- ^ distinct+> ,aggArgs :: [ValueExpr]-- ^ args+> ,aggOrderBy :: [SortSpec] -- ^ order by > } > -- | window application, which adds over (partition by a order > -- by b) to regular function application. Explicit frames are > -- not currently supported > | WindowApp > {wnName :: Name -- ^ window function name-> ,wnArgs :: [ScalarExpr] -- ^ args-> ,wnPartition :: [ScalarExpr] -- ^ partition by-> ,wnOrderBy :: [OrderField] -- ^ order by+> ,wnArgs :: [ValueExpr] -- ^ args+> ,wnPartition :: [ValueExpr] -- ^ partition by+> ,wnOrderBy :: [SortSpec] -- ^ order by > ,wnFrame :: Maybe Frame -- ^ frame clause > } > -- | Infix binary operators. This is used for symbol operators > -- (a + b), keyword operators (a and b) and multiple keyword > -- operators (a is similar to b)-> | BinOp ScalarExpr Name ScalarExpr+> | BinOp ValueExpr Name ValueExpr > -- | Prefix unary operators. This is used for symbol-> -- operators, keyword operators and multiple keyword operators-> | PrefixOp Name ScalarExpr+> -- operators, keyword operators and multiple keyword operators.+> | PrefixOp Name ValueExpr > -- | Postfix unary operators. This is used for symbol-> -- operators, keyword operators and multiple keyword operators-> | PostfixOp Name ScalarExpr+> -- operators, keyword operators and multiple keyword operators.+> | PostfixOp Name ValueExpr > -- | Used for ternary, mixfix and other non orthodox-> -- operators, including the function looking calls which use-> -- keywords instead of commas to separate the arguments,-> -- e.g. substring(t from 1 to 5)-> | SpecialOp Name [ScalarExpr]+> -- operators. Currently used for row constructors, and for+> -- between.+> | SpecialOp Name [ValueExpr]+> -- | Used for the operators which look like functions+> -- except the arguments are separated by keywords instead+> -- of commas. The maybe is for the first unnamed argument+> -- if it is present, and the list is for the keyword argument+> -- pairs.+> | SpecialOpK Name (Maybe ValueExpr) [(String,ValueExpr)] > -- | case expression. both flavours supported > | Case-> {caseTest :: Maybe ScalarExpr -- ^ test value-> ,caseWhens :: [([ScalarExpr],ScalarExpr)] -- ^ when branches-> ,caseElse :: Maybe ScalarExpr -- ^ else value+> {caseTest :: Maybe ValueExpr -- ^ test value+> ,caseWhens :: [([ValueExpr],ValueExpr)] -- ^ when branches+> ,caseElse :: Maybe ValueExpr -- ^ else value > }-> | Parens ScalarExpr+> | Parens ValueExpr > -- | cast(a as typename)-> | Cast ScalarExpr TypeName+> | Cast ValueExpr TypeName > -- | prefix 'typed literal', e.g. int '42' > | TypedLit TypeName String > -- | exists, all, any, some subqueries > | SubQueryExpr SubQueryExprType QueryExpr > -- | in list literal and in subquery, if the bool is false it > -- means not in was used ('a not in (1,2)')-> | In Bool ScalarExpr InThing+> | In Bool ValueExpr InPredValue+> | Parameter -- ^ Represents a ? in a parameterized query > deriving (Eq,Show,Read) > -- | Represents an identifier name, which can be quoted or unquoted. > data Name = Name String > | QName String-> deriving (Eq,Show,Read)+> deriving (Eq,Show,Read) > -- | Represents a type name, used in casts. > data TypeName = TypeName String@@ -124,13 +133,13 @@ > deriving (Eq,Show,Read) -> -- | Used for 'expr in (scalar expression list)', and 'expr in+> -- | Used for 'expr in (value expression list)', and 'expr in > -- (subquery)' syntax.-> data InThing = InList [ScalarExpr]-> | InQueryExpr QueryExpr-> deriving (Eq,Show,Read)+> data InPredValue = InList [ValueExpr]+> | InQueryExpr QueryExpr+> deriving (Eq,Show,Read) -> -- | A subquery in a scalar expression.+> -- | A subquery in a value expression. > data SubQueryExprType > = -- | exists (query expr) > SqExists@@ -145,8 +154,8 @@ > deriving (Eq,Show,Read) > -- | Represents one field in an order by list.-> data OrderField = OrderField ScalarExpr Direction NullsOrder-> deriving (Eq,Show,Read)+> data SortSpec = SortSpec ValueExpr Direction NullsOrder+> deriving (Eq,Show,Read) > -- | Represents 'nulls first' or 'nulls last' in an order by clause. > data NullsOrder = NullsOrderDefault@@ -167,9 +176,9 @@ > -- | represents the start or end of a frame > data FramePos = UnboundedPreceding-> | Preceding ScalarExpr+> | Preceding ValueExpr > | Current-> | Following ScalarExpr+> | Following ValueExpr > | UnboundedFollowing > deriving (Eq,Show,Read) @@ -181,27 +190,33 @@ > -- > -- * a common table expression (with); > ---> -- * a values expression;+> -- * a table value constructor (values (1,2),(3,4)); or > ---> -- * or the table syntax - 'table t', shorthand for 'select * from-> -- t'.+> -- * an explicit table (table t). > data QueryExpr > = Select-> {qeDuplicates :: Duplicates-> ,qeSelectList :: [(Maybe Name,ScalarExpr)]-> -- ^ the column aliases and the expressions+> {qeSetQuantifier :: SetQuantifier+> ,qeSelectList :: [(ValueExpr,Maybe Name)]+> -- ^ the expressions and the column aliases++TODO: consider breaking this up. The SQL grammar has+queryexpr = select <select list> [<table expression>]+table expression = <from> [where] [groupby] [having] ...++This would make some things a bit cleaner?+ > ,qeFrom :: [TableRef]-> ,qeWhere :: Maybe ScalarExpr+> ,qeWhere :: Maybe ValueExpr > ,qeGroupBy :: [GroupingExpr]-> ,qeHaving :: Maybe ScalarExpr-> ,qeOrderBy :: [OrderField]-> ,qeOffset :: Maybe ScalarExpr-> ,qeFetch :: Maybe ScalarExpr+> ,qeHaving :: Maybe ValueExpr+> ,qeOrderBy :: [SortSpec]+> ,qeOffset :: Maybe ValueExpr+> ,qeFetchFirst :: Maybe ValueExpr > } > | CombineQueryExpr > {qe0 :: QueryExpr > ,qeCombOp :: CombineOp-> ,qeDuplicates :: Duplicates+> ,qeSetQuantifier :: SetQuantifier > ,qeCorresponding :: Corresponding > ,qe1 :: QueryExpr > }@@ -209,7 +224,7 @@ > {qeWithRecursive :: Bool > ,qeViews :: [(Alias,QueryExpr)] > ,qeQueryExpression :: QueryExpr}-> | Values [[ScalarExpr]]+> | Values [[ValueExpr]] > | Table Name > deriving (Eq,Show,Read) @@ -218,9 +233,21 @@ I'm not sure if this is valid syntax or not. > -- | Helper/'default' value for query exprs to make creating query-> -- expr values a little easier.+> -- expr values a little easier. It is defined like this:+> --+> -- > makeSelect :: QueryExpr+> -- > makeSelect = Select {qeSetQuantifier = All+> -- > ,qeSelectList = []+> -- > ,qeFrom = []+> -- > ,qeWhere = Nothing+> -- > ,qeGroupBy = []+> -- > ,qeHaving = Nothing+> -- > ,qeOrderBy = []+> -- > ,qeOffset = Nothing+> -- > ,qeFetchFirst = Nothing}+ > makeSelect :: QueryExpr-> makeSelect = Select {qeDuplicates = All+> makeSelect = Select {qeSetQuantifier = All > ,qeSelectList = [] > ,qeFrom = [] > ,qeWhere = Nothing@@ -228,13 +255,13 @@ > ,qeHaving = Nothing > ,qeOrderBy = [] > ,qeOffset = Nothing-> ,qeFetch = 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.-> data Duplicates = Distinct | All deriving (Eq,Show,Read)+> data SetQuantifier = Distinct | All deriving (Eq,Show,Read) > -- | The direction for a column in order by. > data Direction = Asc | Desc deriving (Eq,Show,Read)@@ -249,7 +276,7 @@ > | Cube [GroupingExpr] > | Rollup [GroupingExpr] > | GroupingSets [GroupingExpr]-> | SimpleGroup ScalarExpr+> | SimpleGroup ValueExpr > deriving (Eq,Show,Read) > -- | Represents a entry in the csv of tables in the from clause.@@ -264,7 +291,7 @@ > -- | from (query expr) > | TRQueryExpr QueryExpr > -- | from function(args)-> | TRFunction Name [ScalarExpr]+> | TRFunction Name [ValueExpr] > -- | from lateral t > | TRLateral TableRef > deriving (Eq,Show,Read)@@ -280,7 +307,7 @@ > deriving (Eq,Show,Read) > -- | The join condition.-> data JoinCondition = JoinOn ScalarExpr -- ^ on expr+> data JoinCondition = JoinOn ValueExpr -- ^ on expr > | JoinUsing [Name] -- ^ using (column list) > | JoinNatural -- ^ natural join was used > deriving (Eq,Show,Read)
changelog view
@@ -1,5 +1,43 @@-0.2.0.0- last update on commit a53578c6c27d94a33d104d404547cc02b4ad36c3+0.3.0 (commit 9e75fa93650b4f1a08d94f4225a243bcc50445ae)+ fix the basic operator fixity parsing+ swap the order in select item abstract syntax so it is now+ (expression, alias) which matches the order in the concrete+ syntax+ rename ScalarExpr -> ValueExpr+ rename Duplicates to SetQuantifier+ rename qeDuplicates to qeSetQuantifier+ rename OrderField to SortSpec+ rename InThing to InPredValue+ add support for ? for parameterized queries+ add new abstract syntax for special operators whose concrete+ syntax is a kind of limited named parameters syntax+ add more parsing for these operators: position, convert,+ translate, overlay, trim, and improve the substring parsing+ add support for multi keyword type names+ previously:+ double precision+ character varying+ now:+ double precision,+ character varying,+ char varying,+ character large object,+ char large object,+ national character,+ national char,+ national character varying,+ national char varying,+ national character large object,+ nchar large object,+ nchar varying,+ bit varying+ rename tools/PrettyIt to tools/SQLIdent and add to cabal file as+ optional executable (disabled by default)+ rename the qeFetch field in Select to qeFetchFirst+ change the pretty printer to use 'fetch first' instead of+ 'fetch next'++0.2.0 (commit 9ea29c1a0ceb2c3f3157fb161d1ea819ea5d64d4) '' quotes in string literal parse simple interval literal e.g. "interval '1 week'" support . in identifiers as a dot operator@@ -25,5 +63,6 @@ support ansi standard syntax for offset n rows and fetch first n rows only fix keyword parsing to be case insensitive-0.1.0.0- initial version++0.1.0.0 (commit 9bf4012fc40a74ad9a039fcb936e3b9dfc3f90f0)+ initial release
simple-sql-parser.cabal view
@@ -1,5 +1,5 @@ name: simple-sql-parser-version: 0.2.0+version: 0.3.0 synopsis: A parser for SQL queries description: A parser for SQL queries. Please see the homepage for more information <http://jakewheat.github.io/simple-sql-parser/>. @@ -19,17 +19,19 @@ type: git location: https://github.com/JakeWheat/simple-sql-parser.git +Flag sqlindent+ Description: Build SQLIndent exe+ Default: False+ library exposed-modules: Language.SQL.SimpleSQL.Pretty, Language.SQL.SimpleSQL.Parser, Language.SQL.SimpleSQL.Syntax- other-modules: Language.SQL.SimpleSQL.Fixity other-extensions: TupleSections build-depends: base >=4.6 && <4.7, parsec >=3.1 && <3.2, mtl >=2.1 && <2.2,- pretty >= 1.1 && < 1.2,- haskell-src-exts >= 1.14 && < 1.15+ pretty >= 1.1 && < 1.2 -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall@@ -51,14 +53,13 @@ Other-Modules: Language.SQL.SimpleSQL.Pretty, Language.SQL.SimpleSQL.Parser, Language.SQL.SimpleSQL.Syntax,- Language.SQL.SimpleSQL.Fixity, Language.SQL.SimpleSQL.FullQueries, Language.SQL.SimpleSQL.GroupBy, Language.SQL.SimpleSQL.Postgres, Language.SQL.SimpleSQL.QueryExprComponents, Language.SQL.SimpleSQL.QueryExprs,- Language.SQL.SimpleSQL.ScalarExprs,+ Language.SQL.SimpleSQL.ValueExprs, Language.SQL.SimpleSQL.TableRefs, Language.SQL.SimpleSQL.TestTypes, Language.SQL.SimpleSQL.Tests,@@ -67,3 +68,18 @@ other-extensions: TupleSections,OverloadedStrings default-language: Haskell2010 ghc-options: -Wall++executable SQLIndent+ main-is: SQLIndent.lhs+ hs-source-dirs: .,tools+ Build-Depends: base >=4.6 && <4.7,+ parsec >=3.1 && <3.2,+ mtl >=2.1 && <2.2,+ pretty >= 1.1 && < 1.2,+ haskell-src-exts >= 1.14 && < 1.15+ default-language: Haskell2010+ ghc-options: -Wall+ if flag(sqlindent)+ buildable: True+ else+ buildable: False
tools/Language/SQL/SimpleSQL/FullQueries.lhs view
@@ -12,7 +12,7 @@ > fullQueriesTests = Group "queries" $ map (uncurry TestQueryExpr) > [("select count(*) from t" > ,makeSelect-> {qeSelectList = [(Nothing, App "count" [Star])]+> {qeSelectList = [(App "count" [Star], Nothing)] > ,qeFrom = [TRSimple "t"] > } > )@@ -24,16 +24,16 @@ > \ having count(1) > 5\n\ > \ order by s" > ,makeSelect-> {qeSelectList = [(Nothing, Iden "a")-> ,(Just "s"-> ,App "sum" [BinOp (Iden "c")-> "+" (Iden "d")])]+> {qeSelectList = [(Iden "a", Nothing)+> ,(App "sum" [BinOp (Iden "c")+> "+" (Iden "d")]+> ,Just "s")] > ,qeFrom = [TRSimple "t", TRSimple "u"] > ,qeWhere = Just $ BinOp (Iden "a") ">" (NumLit "5") > ,qeGroupBy = [SimpleGroup $ Iden "a"] > ,qeHaving = Just $ BinOp (App "count" [NumLit "1"]) > ">" (NumLit "5")-> ,qeOrderBy = [OrderField (Iden "s") Asc NullsOrderDefault]+> ,qeOrderBy = [SortSpec (Iden "s") Asc NullsOrderDefault] > } > ) > ]
tools/Language/SQL/SimpleSQL/GroupBy.lhs view
@@ -18,16 +18,16 @@ > simpleGroupBy :: TestItem > simpleGroupBy = Group "simpleGroupBy" $ map (uncurry TestQueryExpr) > [("select a,sum(b) from t group by a"-> ,makeSelect {qeSelectList = [(Nothing, Iden "a")-> ,(Nothing, App "sum" [Iden "b"])]+> ,makeSelect {qeSelectList = [(Iden "a",Nothing)+> ,(App "sum" [Iden "b"],Nothing)] > ,qeFrom = [TRSimple "t"] > ,qeGroupBy = [SimpleGroup $ Iden "a"] > }) > ,("select a,b,sum(c) from t group by a,b"-> ,makeSelect {qeSelectList = [(Nothing, Iden "a")-> ,(Nothing, Iden "b")-> ,(Nothing, App "sum" [Iden "c"])]+> ,makeSelect {qeSelectList = [(Iden "a",Nothing)+> ,(Iden "b",Nothing)+> ,(App "sum" [Iden "c"],Nothing)] > ,qeFrom = [TRSimple "t"] > ,qeGroupBy = [SimpleGroup $ Iden "a" > ,SimpleGroup $ Iden "b"]@@ -49,7 +49,7 @@ > ,ms [Rollup [SimpleGroup $ Iden "a", SimpleGroup $ Iden "b"]]) > ] > where-> ms g = makeSelect {qeSelectList = [(Nothing,Star)]+> ms g = makeSelect {qeSelectList = [(Star,Nothing)] > ,qeFrom = [TRSimple "t"] > ,qeGroupBy = g}
tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs view
@@ -36,40 +36,47 @@ > ] > where > ms d = makeSelect-> {qeDuplicates = d-> ,qeSelectList = [(Nothing,Iden "a")]+> {qeSetQuantifier = d+> ,qeSelectList = [(Iden "a",Nothing)] > ,qeFrom = [TRSimple "t"]} > selectLists :: TestItem > selectLists = Group "selectLists" $ map (uncurry TestQueryExpr) > [("select 1",-> makeSelect {qeSelectList = [(Nothing,NumLit "1")]})+> makeSelect {qeSelectList = [(NumLit "1",Nothing)]}) > ,("select a"-> ,makeSelect {qeSelectList = [(Nothing,Iden "a")]})+> ,makeSelect {qeSelectList = [(Iden "a",Nothing)]}) > ,("select a,b"-> ,makeSelect {qeSelectList = [(Nothing,Iden "a")-> ,(Nothing,Iden "b")]})+> ,makeSelect {qeSelectList = [(Iden "a",Nothing)+> ,(Iden "b",Nothing)]}) > ,("select 1+2,3+4" > ,makeSelect {qeSelectList =-> [(Nothing,BinOp (NumLit "1") "+" (NumLit "2"))-> ,(Nothing,BinOp (NumLit "3") "+" (NumLit "4"))]})+> [(BinOp (NumLit "1") "+" (NumLit "2"),Nothing)+> ,(BinOp (NumLit "3") "+" (NumLit "4"),Nothing)]}) > ,("select a as a, /*comment*/ b as b"-> ,makeSelect {qeSelectList = [(Just "a", Iden "a")-> ,(Just "b", Iden "b")]})+> ,makeSelect {qeSelectList = [(Iden "a", Just "a")+> ,(Iden "b", Just "b")]}) > ,("select a a, b b"-> ,makeSelect {qeSelectList = [(Just "a", Iden "a")-> ,(Just "b", Iden "b")]})+> ,makeSelect {qeSelectList = [(Iden "a", Just "a")+> ,(Iden "b", Just "b")]})++> ,("select a + b * c"+> ,makeSelect {qeSelectList =+> [(BinOp (Iden (Name "a")) (Name "+")+> (BinOp (Iden (Name "b")) (Name "*") (Iden (Name "c")))+> ,Nothing)]})+ > ] > whereClause :: TestItem > whereClause = Group "whereClause" $ map (uncurry TestQueryExpr) > [("select a from t where a = 5"-> ,makeSelect {qeSelectList = [(Nothing,Iden "a")]+> ,makeSelect {qeSelectList = [(Iden "a",Nothing)] > ,qeFrom = [TRSimple "t"] > ,qeWhere = Just $ BinOp (Iden "a") "=" (NumLit "5")}) > ]@@ -77,8 +84,8 @@ > having :: TestItem > having = Group "having" $ map (uncurry TestQueryExpr) > [("select a,sum(b) from t group by a having sum(b) > 5"-> ,makeSelect {qeSelectList = [(Nothing, Iden "a")-> ,(Nothing, App "sum" [Iden "b"])]+> ,makeSelect {qeSelectList = [(Iden "a",Nothing)+> ,(App "sum" [Iden "b"],Nothing)] > ,qeFrom = [TRSimple "t"] > ,qeGroupBy = [SimpleGroup $ Iden "a"] > ,qeHaving = Just $ BinOp (App "sum" [Iden "b"])@@ -89,26 +96,26 @@ > orderBy :: TestItem > orderBy = Group "orderBy" $ map (uncurry TestQueryExpr) > [("select a from t order by a"-> ,ms [OrderField (Iden "a") Asc NullsOrderDefault])+> ,ms [SortSpec (Iden "a") Asc NullsOrderDefault]) > ,("select a from t order by a, b"-> ,ms [OrderField (Iden "a") Asc NullsOrderDefault-> ,OrderField (Iden "b") Asc NullsOrderDefault])+> ,ms [SortSpec (Iden "a") Asc NullsOrderDefault+> ,SortSpec (Iden "b") Asc NullsOrderDefault]) > ,("select a from t order by a asc"-> ,ms [OrderField (Iden "a") Asc NullsOrderDefault])+> ,ms [SortSpec (Iden "a") Asc NullsOrderDefault]) > ,("select a from t order by a desc, b desc"-> ,ms [OrderField (Iden "a") Desc NullsOrderDefault-> ,OrderField (Iden "b") Desc NullsOrderDefault])+> ,ms [SortSpec (Iden "a") Desc NullsOrderDefault+> ,SortSpec (Iden "b") Desc NullsOrderDefault]) > ,("select a from t order by a desc nulls first, b desc nulls last"-> ,ms [OrderField (Iden "a") Desc NullsFirst-> ,OrderField (Iden "b") Desc NullsLast])+> ,ms [SortSpec (Iden "a") Desc NullsFirst+> ,SortSpec (Iden "b") Desc NullsLast]) > ] > where-> ms o = makeSelect {qeSelectList = [(Nothing,Iden "a")]+> ms o = makeSelect {qeSelectList = [(Iden "a",Nothing)] > ,qeFrom = [TRSimple "t"] > ,qeOrderBy = o} @@ -129,10 +136,10 @@ > ] > where > ms o l = makeSelect-> {qeSelectList = [(Nothing,Iden "a")]+> {qeSelectList = [(Iden "a",Nothing)] > ,qeFrom = [TRSimple "t"] > ,qeOffset = o-> ,qeFetch = l}+> ,qeFetchFirst = l} > combos :: TestItem > combos = Group "combos" $ map (uncurry TestQueryExpr)@@ -158,10 +165,10 @@ > ] > where > ms1 = makeSelect-> {qeSelectList = [(Nothing,Iden "a")]+> {qeSelectList = [(Iden "a",Nothing)] > ,qeFrom = [TRSimple "t"]} > ms2 = makeSelect-> {qeSelectList = [(Nothing,Iden "b")]+> {qeSelectList = [(Iden "b",Nothing)] > ,qeFrom = [TRSimple "u"]} @@ -183,7 +190,7 @@ > ] > where > ms c t = makeSelect-> {qeSelectList = [(Nothing,Iden c)]+> {qeSelectList = [(Iden c,Nothing)] > ,qeFrom = [TRSimple t]} > ms1 = ms "a" "t" > ms2 = ms "a" "u"
tools/Language/SQL/SimpleSQL/QueryExprs.lhs view
@@ -15,4 +15,4 @@ > ,(" select 1;select 1; ",[ms,ms]) > ] > where-> ms = makeSelect {qeSelectList = [(Nothing,NumLit "1")]}+> ms = makeSelect {qeSelectList = [(NumLit "1",Nothing)]}
− tools/Language/SQL/SimpleSQL/ScalarExprs.lhs
@@ -1,304 +0,0 @@--Tests for parsing scalar expressions--> {-# LANGUAGE OverloadedStrings #-}-> module Language.SQL.SimpleSQL.ScalarExprs (scalarExprTests) where--> import Language.SQL.SimpleSQL.TestTypes-> import Language.SQL.SimpleSQL.Syntax--> scalarExprTests :: TestItem-> scalarExprTests = Group "scalarExprTests"-> [literals-> ,identifiers-> ,star-> ,dots-> ,app-> ,caseexp-> ,operators-> ,parens-> ,subqueries-> ,aggregates-> ,windowFunctions-> ]--> literals :: TestItem-> literals = Group "literals" $ map (uncurry TestScalarExpr)-> [("3", NumLit "3")-> ,("3.", NumLit "3.")-> ,("3.3", NumLit "3.3")-> ,(".3", NumLit ".3")-> ,("3.e3", NumLit "3.e3")-> ,("3.3e3", NumLit "3.3e3")-> ,(".3e3", NumLit ".3e3")-> ,("3e3", NumLit "3e3")-> ,("3e+3", NumLit "3e+3")-> ,("3e-3", NumLit "3e-3")-> ,("'string'", StringLit "string")-> ,("'string with a '' quote'", StringLit "string with a ' quote")-> ,("'1'", StringLit "1")-> ,("interval '3' day", IntervalLit "3" "day" Nothing)-> ,("interval '3' day (3)", IntervalLit "3" "day" $ Just 3)-> ,("interval '3 weeks'", TypedLit (TypeName "interval") "3 weeks")-> ]--> identifiers :: TestItem-> identifiers = Group "identifiers" $ map (uncurry TestScalarExpr)-> [("iden1", Iden "iden1")-> --,("t.a", Iden2 "t" "a")-> ,("\"quoted identifier\"", Iden $ QName "quoted identifier")-> ]--> star :: TestItem-> star = Group "star" $ map (uncurry TestScalarExpr)-> [("*", Star)-> --,("t.*", Star2 "t")-> --,("ROW(t.*,42)", App "ROW" [Star2 "t", NumLit "42"])-> ]--> dots :: TestItem-> dots = Group "dot" $ map (uncurry TestScalarExpr)-> [("t.a", BinOp (Iden "t") "." (Iden "a"))-> ,("t.*", BinOp (Iden "t") "." Star)-> ,("a.b.c", BinOp (BinOp (Iden "a") "." (Iden "b")) "." (Iden "c"))-> ,("ROW(t.*,42)", App "ROW" [BinOp (Iden "t") "." Star, NumLit "42"])-> ]--> app :: TestItem-> app = Group "app" $ map (uncurry TestScalarExpr)-> [("f()", App "f" [])-> ,("f(a)", App "f" [Iden "a"])-> ,("f(a,b)", App "f" [Iden "a", Iden "b"])-> ]--> caseexp :: TestItem-> caseexp = Group "caseexp" $ map (uncurry TestScalarExpr)-> [("case a when 1 then 2 end"-> ,Case (Just $ Iden "a") [([NumLit "1"]-> ,NumLit "2")] Nothing)--> ,("case a when 1 then 2 when 3 then 4 end"-> ,Case (Just $ Iden "a") [([NumLit "1"], NumLit "2")-> ,([NumLit "3"], NumLit "4")] Nothing)--> ,("case a when 1 then 2 when 3 then 4 else 5 end"-> ,Case (Just $ Iden "a") [([NumLit "1"], NumLit "2")-> ,([NumLit "3"], NumLit "4")]-> (Just $ NumLit "5"))--> ,("case when a=1 then 2 when a=3 then 4 else 5 end"-> ,Case Nothing [([BinOp (Iden "a") "=" (NumLit "1")], NumLit "2")-> ,([BinOp (Iden "a") "=" (NumLit "3")], NumLit "4")]-> (Just $ NumLit "5"))--> ,("case a when 1,2 then 10 when 3,4 then 20 end"-> ,Case (Just $ Iden "a") [([NumLit "1",NumLit "2"]-> ,NumLit "10")-> ,([NumLit "3",NumLit "4"]-> ,NumLit "20")]-> Nothing)--> ]--> operators :: TestItem-> operators = Group "operators"-> [binaryOperators-> ,unaryOperators-> ,casts-> ,miscOps]--> binaryOperators :: TestItem-> binaryOperators = Group "binaryOperators" $ map (uncurry TestScalarExpr)-> [("a + b", BinOp (Iden "a") "+" (Iden "b"))-> -- sanity check fixities-> -- todo: add more fixity checking--> ,("a + b * c"-> ,BinOp (Iden "a") "+"-> (BinOp (Iden "b") "*" (Iden "c")))--> ,("a * b + c"-> ,BinOp (BinOp (Iden "a") "*" (Iden "b"))-> "+" (Iden "c"))-> ]--> unaryOperators :: TestItem-> unaryOperators = Group "unaryOperators" $ map (uncurry TestScalarExpr)-> [("not a", PrefixOp "not" $ Iden "a")-> ,("not not a", PrefixOp "not" $ PrefixOp "not" $ Iden "a")-> ,("+a", PrefixOp "+" $ Iden "a")-> ,("-a", PrefixOp "-" $ Iden "a")-> ]---> casts :: TestItem-> casts = Group "operators" $ map (uncurry TestScalarExpr)-> [("cast('1' as int)"-> ,Cast (StringLit "1") $ TypeName "int")--> ,("int '3'"-> ,TypedLit (TypeName "int") "3")--> ,("cast('1' as double precision)"-> ,Cast (StringLit "1") $ TypeName "double precision")--> ,("cast('1' as float(8))"-> ,Cast (StringLit "1") $ PrecTypeName "float" 8)--> ,("cast('1' as decimal(15,2))"-> ,Cast (StringLit "1") $ PrecScaleTypeName "decimal" 15 2)---> ,("double precision '3'"-> ,TypedLit (TypeName "double precision") "3")-> ]--> subqueries :: TestItem-> subqueries = Group "unaryOperators" $ map (uncurry TestScalarExpr)-> [("exists (select a from t)", SubQueryExpr SqExists ms)-> ,("(select a from t)", SubQueryExpr SqSq ms)--> ,("a in (select a from t)"-> ,In True (Iden "a") (InQueryExpr ms))--> ,("a not in (select a from t)"-> ,In False (Iden "a") (InQueryExpr ms))--> ,("a > all (select a from t)"-> ,BinOp (Iden "a") ">" (SubQueryExpr SqAll ms))--> ,("a = some (select a from t)"-> ,BinOp (Iden "a") "=" (SubQueryExpr SqSome ms))--> ,("a <= any (select a from t)"-> ,BinOp (Iden "a") "<=" (SubQueryExpr SqAny ms))-> ]-> where-> ms = makeSelect-> {qeSelectList = [(Nothing,Iden "a")]-> ,qeFrom = [TRSimple "t"]-> }--> miscOps :: TestItem-> miscOps = Group "unaryOperators" $ map (uncurry TestScalarExpr)-> [("a in (1,2,3)"-> ,In True (Iden "a") $ InList $ map NumLit ["1","2","3"])--> ,("a between b and c", SpecialOp "between" [Iden "a"-> ,Iden "b"-> ,Iden "c"])--> ,("a not between b and c", SpecialOp "not between" [Iden "a"-> ,Iden "b"-> ,Iden "c"])--> ,("a is null", PostfixOp "is null" (Iden "a"))-> ,("a is not null", PostfixOp "is not null" (Iden "a"))-> ,("a is true", PostfixOp "is true" (Iden "a"))-> ,("a is not true", PostfixOp "is not true" (Iden "a"))-> ,("a is false", PostfixOp "is false" (Iden "a"))-> ,("a is not false", PostfixOp "is not false" (Iden "a"))-> ,("a is unknown", PostfixOp "is unknown" (Iden "a"))-> ,("a is not unknown", PostfixOp "is not unknown" (Iden "a"))-> ,("a is distinct from b", BinOp (Iden "a") "is distinct from"(Iden "b"))--> ,("a is not distinct from b"-> ,BinOp (Iden "a") "is not distinct from" (Iden "b"))--> ,("a like b", BinOp (Iden "a") "like" (Iden "b"))-> ,("a not like b", BinOp (Iden "a") "not like" (Iden "b"))-> ,("a is similar to b", BinOp (Iden "a") "is similar to" (Iden "b"))--> ,("a is not similar to b"-> ,BinOp (Iden "a") "is not similar to" (Iden "b"))--> ,("a overlaps b", BinOp (Iden "a") "overlaps" (Iden "b"))-> ,("extract(day from t)", SpecialOp "extract" [Iden "day", Iden "t"])--> ,("substring(x from 1 for 2)"-> ,SpecialOp "substring" [Iden "x", NumLit "1", NumLit "2"])--> ,("(1,2)"-> ,SpecialOp "rowctor" [NumLit "1", NumLit "2"])--> ]--> aggregates :: TestItem-> aggregates = Group "aggregates" $ map (uncurry TestScalarExpr)-> [("count(*)",App "count" [Star])--> ,("sum(a order by a)"-> ,AggregateApp "sum" Nothing [Iden "a"]-> [OrderField (Iden "a") Asc NullsOrderDefault])--> ,("sum(all a)"-> ,AggregateApp "sum" (Just All) [Iden "a"] [])--> ,("count(distinct a)"-> ,AggregateApp "count" (Just Distinct) [Iden "a"] [])-> ]--> windowFunctions :: TestItem-> windowFunctions = Group "windowFunctions" $ map (uncurry TestScalarExpr)-> [("max(a) over ()", WindowApp "max" [Iden "a"] [] [] Nothing)-> ,("count(*) over ()", WindowApp "count" [Star] [] [] Nothing)--> ,("max(a) over (partition by b)"-> ,WindowApp "max" [Iden "a"] [Iden "b"] [] Nothing)--> ,("max(a) over (partition by b,c)"-> ,WindowApp "max" [Iden "a"] [Iden "b",Iden "c"] [] Nothing)--> ,("sum(a) over (order by b)"-> ,WindowApp "sum" [Iden "a"] []-> [OrderField (Iden "b") Asc NullsOrderDefault] Nothing)--> ,("sum(a) over (order by b desc,c)"-> ,WindowApp "sum" [Iden "a"] []-> [OrderField (Iden "b") Desc NullsOrderDefault-> ,OrderField (Iden "c") Asc NullsOrderDefault] Nothing)--> ,("sum(a) over (partition by b order by c)"-> ,WindowApp "sum" [Iden "a"] [Iden "b"]-> [OrderField (Iden "c") Asc NullsOrderDefault] Nothing)--> ,("sum(a) over (partition by b order by c range unbounded preceding)"-> ,WindowApp "sum" [Iden "a"] [Iden "b"]-> [OrderField (Iden "c") Asc NullsOrderDefault]-> $ Just $ FrameFrom FrameRange UnboundedPreceding)--> ,("sum(a) over (partition by b order by c range 5 preceding)"-> ,WindowApp "sum" [Iden "a"] [Iden "b"]-> [OrderField (Iden "c") Asc NullsOrderDefault]-> $ Just $ FrameFrom FrameRange $ Preceding (NumLit "5"))--> ,("sum(a) over (partition by b order by c range current row)"-> ,WindowApp "sum" [Iden "a"] [Iden "b"]-> [OrderField (Iden "c") Asc NullsOrderDefault]-> $ Just $ FrameFrom FrameRange Current)--> ,("sum(a) over (partition by b order by c rows 5 following)"-> ,WindowApp "sum" [Iden "a"] [Iden "b"]-> [OrderField (Iden "c") Asc NullsOrderDefault]-> $ Just $ FrameFrom FrameRows $ Following (NumLit "5"))--> ,("sum(a) over (partition by b order by c range unbounded following)"-> ,WindowApp "sum" [Iden "a"] [Iden "b"]-> [OrderField (Iden "c") Asc NullsOrderDefault]-> $ Just $ FrameFrom FrameRange UnboundedFollowing)--> ,("sum(a) over (partition by b order by c \n\-> \range between 5 preceding and 5 following)"-> ,WindowApp "sum" [Iden "a"] [Iden "b"]-> [OrderField (Iden "c") Asc NullsOrderDefault]-> $ Just $ FrameBetween FrameRange-> (Preceding (NumLit "5"))-> (Following (NumLit "5")))--> ]--> parens :: TestItem-> parens = Group "parens" $ map (uncurry TestScalarExpr)-> [("(a)", Parens (Iden "a"))-> ,("(a + b)", Parens (BinOp (Iden "a") "+" (Iden "b")))-> ]
tools/Language/SQL/SimpleSQL/TableRefs.lhs view
@@ -100,5 +100,5 @@ > JCross (TRSimple "v") Nothing]) > ] > where-> ms f = makeSelect {qeSelectList = [(Nothing,Iden "a")]+> ms f = makeSelect {qeSelectList = [(Iden "a",Nothing)] > ,qeFrom = f}
tools/Language/SQL/SimpleSQL/TestTypes.lhs view
@@ -9,7 +9,7 @@ > import Data.String > data TestItem = Group String [TestItem]-> | TestScalarExpr String ScalarExpr+> | TestValueExpr String ValueExpr > | TestQueryExpr String QueryExpr > | TestQueryExprs String [QueryExpr]
tools/Language/SQL/SimpleSQL/Tests.lhs view
@@ -1,13 +1,7 @@ -TODO:--split into multiple files:-scalar expressions-tablerefs-other queryexpr parts: not enough to split into multiple files-full queries-tpch tests-+This is the main tests module which exposes the test data plus the+Test.Framework tests. It also contains the code which converts the+test data to the Test.Framework tests. > module Language.SQL.SimpleSQL.Tests > (testData@@ -31,7 +25,7 @@ > import Language.SQL.SimpleSQL.QueryExprComponents > import Language.SQL.SimpleSQL.QueryExprs > import Language.SQL.SimpleSQL.TableRefs-> import Language.SQL.SimpleSQL.ScalarExprs+> import Language.SQL.SimpleSQL.ValueExprs > import Language.SQL.SimpleSQL.Tpch @@ -42,7 +36,7 @@ > testData :: TestItem > testData = > Group "parserTest"-> [scalarExprTests+> [valueExprTests > ,queryExprComponentTests > ,queryExprsTests > ,tableRefTests@@ -61,8 +55,8 @@ > itemToTest :: TestItem -> Test.Framework.Test > itemToTest (Group nm ts) = > testGroup nm $ map itemToTest ts-> itemToTest (TestScalarExpr str expected) =-> toTest parseScalarExpr prettyScalarExpr str expected+> itemToTest (TestValueExpr str expected) =+> toTest parseValueExpr prettyValueExpr str expected > itemToTest (TestQueryExpr str expected) = > toTest parseQueryExpr prettyQueryExpr str expected > itemToTest (TestQueryExprs str expected) =
+ tools/Language/SQL/SimpleSQL/ValueExprs.lhs view
@@ -0,0 +1,407 @@++Tests for parsing value expressions++> {-# LANGUAGE OverloadedStrings #-}+> module Language.SQL.SimpleSQL.ValueExprs (valueExprTests) where++> import Language.SQL.SimpleSQL.TestTypes+> import Language.SQL.SimpleSQL.Syntax++> valueExprTests :: TestItem+> valueExprTests = Group "valueExprTests"+> [literals+> ,identifiers+> ,star+> ,parameter+> ,dots+> ,app+> ,caseexp+> ,operators+> ,parens+> ,subqueries+> ,aggregates+> ,windowFunctions+> ]++> literals :: TestItem+> literals = Group "literals" $ map (uncurry TestValueExpr)+> [("3", NumLit "3")+> ,("3.", NumLit "3.")+> ,("3.3", NumLit "3.3")+> ,(".3", NumLit ".3")+> ,("3.e3", NumLit "3.e3")+> ,("3.3e3", NumLit "3.3e3")+> ,(".3e3", NumLit ".3e3")+> ,("3e3", NumLit "3e3")+> ,("3e+3", NumLit "3e+3")+> ,("3e-3", NumLit "3e-3")+> ,("'string'", StringLit "string")+> ,("'string with a '' quote'", StringLit "string with a ' quote")+> ,("'1'", StringLit "1")+> ,("interval '3' day", IntervalLit "3" "day" Nothing)+> ,("interval '3' day (3)", IntervalLit "3" "day" $ Just 3)+> ,("interval '3 weeks'", TypedLit (TypeName "interval") "3 weeks")+> ]++> identifiers :: TestItem+> identifiers = Group "identifiers" $ map (uncurry TestValueExpr)+> [("iden1", Iden "iden1")+> --,("t.a", Iden2 "t" "a")+> ,("\"quoted identifier\"", Iden $ QName "quoted identifier")+> ]++> star :: TestItem+> star = Group "star" $ map (uncurry TestValueExpr)+> [("*", Star)+> --,("t.*", Star2 "t")+> --,("ROW(t.*,42)", App "ROW" [Star2 "t", NumLit "42"])+> ]++> parameter :: TestItem+> parameter = Group "parameter" $ map (uncurry TestValueExpr)+> [("?", Parameter)+> ]+++> dots :: TestItem+> dots = Group "dot" $ map (uncurry TestValueExpr)+> [("t.a", BinOp (Iden "t") "." (Iden "a"))+> ,("t.*", BinOp (Iden "t") "." Star)+> ,("a.b.c", BinOp (BinOp (Iden "a") "." (Iden "b")) "." (Iden "c"))+> ,("ROW(t.*,42)", App "ROW" [BinOp (Iden "t") "." Star, NumLit "42"])+> ]++> app :: TestItem+> app = Group "app" $ map (uncurry TestValueExpr)+> [("f()", App "f" [])+> ,("f(a)", App "f" [Iden "a"])+> ,("f(a,b)", App "f" [Iden "a", Iden "b"])+> ]++> caseexp :: TestItem+> caseexp = Group "caseexp" $ map (uncurry TestValueExpr)+> [("case a when 1 then 2 end"+> ,Case (Just $ Iden "a") [([NumLit "1"]+> ,NumLit "2")] Nothing)++> ,("case a when 1 then 2 when 3 then 4 end"+> ,Case (Just $ Iden "a") [([NumLit "1"], NumLit "2")+> ,([NumLit "3"], NumLit "4")] Nothing)++> ,("case a when 1 then 2 when 3 then 4 else 5 end"+> ,Case (Just $ Iden "a") [([NumLit "1"], NumLit "2")+> ,([NumLit "3"], NumLit "4")]+> (Just $ NumLit "5"))++> ,("case when a=1 then 2 when a=3 then 4 else 5 end"+> ,Case Nothing [([BinOp (Iden "a") "=" (NumLit "1")], NumLit "2")+> ,([BinOp (Iden "a") "=" (NumLit "3")], NumLit "4")]+> (Just $ NumLit "5"))++> ,("case a when 1,2 then 10 when 3,4 then 20 end"+> ,Case (Just $ Iden "a") [([NumLit "1",NumLit "2"]+> ,NumLit "10")+> ,([NumLit "3",NumLit "4"]+> ,NumLit "20")]+> Nothing)++> ]++> operators :: TestItem+> operators = Group "operators"+> [binaryOperators+> ,unaryOperators+> ,casts+> ,miscOps]++> binaryOperators :: TestItem+> binaryOperators = Group "binaryOperators" $ map (uncurry TestValueExpr)+> [("a + b", BinOp (Iden "a") "+" (Iden "b"))+> -- sanity check fixities+> -- todo: add more fixity checking++> ,("a + b * c"+> ,BinOp (Iden "a") "+"+> (BinOp (Iden "b") "*" (Iden "c")))++> ,("a * b + c"+> ,BinOp (BinOp (Iden "a") "*" (Iden "b"))+> "+" (Iden "c"))+> ]++> unaryOperators :: TestItem+> unaryOperators = Group "unaryOperators" $ map (uncurry TestValueExpr)+> [("not a", PrefixOp "not" $ Iden "a")+> -- I think this is a missing feature or bug in parsec buildExpressionParser+> --,("not not a", PrefixOp "not" $ PrefixOp "not" $ Iden "a")+> ,("+a", PrefixOp "+" $ Iden "a")+> ,("-a", PrefixOp "-" $ Iden "a")+> ]+++> casts :: TestItem+> casts = Group "operators" $ map (uncurry TestValueExpr)+> [("cast('1' as int)"+> ,Cast (StringLit "1") $ TypeName "int")++> ,("int '3'"+> ,TypedLit (TypeName "int") "3")++> ,("cast('1' as double precision)"+> ,Cast (StringLit "1") $ TypeName "double precision")++> ,("cast('1' as float(8))"+> ,Cast (StringLit "1") $ PrecTypeName "float" 8)++> ,("cast('1' as decimal(15,2))"+> ,Cast (StringLit "1") $ PrecScaleTypeName "decimal" 15 2)+++> ,("double precision '3'"+> ,TypedLit (TypeName "double precision") "3")+> ]++> subqueries :: TestItem+> subqueries = Group "unaryOperators" $ map (uncurry TestValueExpr)+> [("exists (select a from t)", SubQueryExpr SqExists ms)+> ,("(select a from t)", SubQueryExpr SqSq ms)++> ,("a in (select a from t)"+> ,In True (Iden "a") (InQueryExpr ms))++> ,("a not in (select a from t)"+> ,In False (Iden "a") (InQueryExpr ms))++> ,("a > all (select a from t)"+> ,BinOp (Iden "a") ">" (SubQueryExpr SqAll ms))++> ,("a = some (select a from t)"+> ,BinOp (Iden "a") "=" (SubQueryExpr SqSome ms))++> ,("a <= any (select a from t)"+> ,BinOp (Iden "a") "<=" (SubQueryExpr SqAny ms))+> ]+> where+> ms = makeSelect+> {qeSelectList = [(Iden "a",Nothing)]+> ,qeFrom = [TRSimple "t"]+> }++> miscOps :: TestItem+> miscOps = Group "unaryOperators" $ map (uncurry TestValueExpr)+> [("a in (1,2,3)"+> ,In True (Iden "a") $ InList $ map NumLit ["1","2","3"])++> ,("a is null", PostfixOp "is null" (Iden "a"))+> ,("a is not null", PostfixOp "is not null" (Iden "a"))+> ,("a is true", PostfixOp "is true" (Iden "a"))+> ,("a is not true", PostfixOp "is not true" (Iden "a"))+> ,("a is false", PostfixOp "is false" (Iden "a"))+> ,("a is not false", PostfixOp "is not false" (Iden "a"))+> ,("a is unknown", PostfixOp "is unknown" (Iden "a"))+> ,("a is not unknown", PostfixOp "is not unknown" (Iden "a"))+> ,("a is distinct from b", BinOp (Iden "a") "is distinct from"(Iden "b"))++> ,("a is not distinct from b"+> ,BinOp (Iden "a") "is not distinct from" (Iden "b"))++> ,("a like b", BinOp (Iden "a") "like" (Iden "b"))+> ,("a not like b", BinOp (Iden "a") "not like" (Iden "b"))+> ,("a is similar to b", BinOp (Iden "a") "is similar to" (Iden "b"))++> ,("a is not similar to b"+> ,BinOp (Iden "a") "is not similar to" (Iden "b"))++> ,("a overlaps b", BinOp (Iden "a") "overlaps" (Iden "b"))+++special operators++> ,("a between b and c", SpecialOp "between" [Iden "a"+> ,Iden "b"+> ,Iden "c"])++> ,("a not between b and c", SpecialOp "not between" [Iden "a"+> ,Iden "b"+> ,Iden "c"])+> ,("(1,2)"+> ,SpecialOp "rowctor" [NumLit "1", NumLit "2"])+++keyword special operators++> ,("extract(day from t)"+> , SpecialOpK "extract" (Just $ Iden "day") [("from", Iden "t")])++> ,("substring(x from 1 for 2)"+> ,SpecialOpK "substring" (Just $ Iden "x") [("from", NumLit "1")+> ,("for", NumLit "2")])++> ,("substring(x from 1)"+> ,SpecialOpK "substring" (Just $ Iden "x") [("from", NumLit "1")])++> ,("substring(x for 2)"+> ,SpecialOpK "substring" (Just $ Iden "x") [("for", NumLit "2")])++> ,("substring(x from 1 for 2 collate 'C')"+> ,SpecialOpK "substring" (Just $ Iden "x") [("from", NumLit "1")+> ,("for", NumLit "2")+> ,("collate", StringLit "C")])++this doesn't work because of a overlap in the 'in' parser++> ,("POSITION( string1 IN string2 )"+> ,SpecialOpK "position" (Just $ Iden "string1") [("in", Iden "string2")])++> ,("CONVERT(char_value USING conversion_char_name)"+> ,SpecialOpK "convert" (Just $ Iden "char_value")+> [("using", Iden "conversion_char_name")])++> ,("TRANSLATE(char_value USING translation_name)"+> ,SpecialOpK "translate" (Just $ Iden "char_value")+> [("using", Iden "translation_name")])++OVERLAY(string PLACING embedded_string FROM start+[FOR length])++> ,("OVERLAY(string PLACING embedded_string FROM start)"+> ,SpecialOpK "overlay" (Just $ Iden "string")+> [("placing", Iden "embedded_string")+> ,("from", Iden "start")])++> ,("OVERLAY(string PLACING embedded_string FROM start FOR length)"+> ,SpecialOpK "overlay" (Just $ Iden "string")+> [("placing", Iden "embedded_string")+> ,("from", Iden "start")+> ,("for", Iden "length")])++TRIM( [ [{LEADING | TRAILING | BOTH}] [removal_char] FROM ]+target_string+[COLLATE collation_name] )++++> ,("trim(from target_string)"+> ,SpecialOpK "trim" Nothing+> [("both", StringLit " ")+> ,("from", Iden "target_string")])++> ,("trim(leading from target_string)"+> ,SpecialOpK "trim" Nothing+> [("leading", StringLit " ")+> ,("from", Iden "target_string")])++> ,("trim(trailing from target_string)"+> ,SpecialOpK "trim" Nothing+> [("trailing", StringLit " ")+> ,("from", Iden "target_string")])++> ,("trim(both from target_string)"+> ,SpecialOpK "trim" Nothing+> [("both", StringLit " ")+> ,("from", Iden "target_string")])+++> ,("trim(leading 'x' from target_string)"+> ,SpecialOpK "trim" Nothing+> [("leading", StringLit "x")+> ,("from", Iden "target_string")])++> ,("trim(trailing 'y' from target_string)"+> ,SpecialOpK "trim" Nothing+> [("trailing", StringLit "y")+> ,("from", Iden "target_string")])++> ,("trim(both 'z' from target_string collate 'C')"+> ,SpecialOpK "trim" Nothing+> [("both", StringLit "z")+> ,("from", Iden "target_string")+> ,("collate", StringLit "C")])++> ,("trim(leading from target_string)"+> ,SpecialOpK "trim" Nothing+> [("leading", StringLit " ")+> ,("from", Iden "target_string")])+++> ]++> aggregates :: TestItem+> aggregates = Group "aggregates" $ map (uncurry TestValueExpr)+> [("count(*)",App "count" [Star])++> ,("sum(a order by a)"+> ,AggregateApp "sum" Nothing [Iden "a"]+> [SortSpec (Iden "a") Asc NullsOrderDefault])++> ,("sum(all a)"+> ,AggregateApp "sum" (Just All) [Iden "a"] [])++> ,("count(distinct a)"+> ,AggregateApp "count" (Just Distinct) [Iden "a"] [])+> ]++> windowFunctions :: TestItem+> windowFunctions = Group "windowFunctions" $ map (uncurry TestValueExpr)+> [("max(a) over ()", WindowApp "max" [Iden "a"] [] [] Nothing)+> ,("count(*) over ()", WindowApp "count" [Star] [] [] Nothing)++> ,("max(a) over (partition by b)"+> ,WindowApp "max" [Iden "a"] [Iden "b"] [] Nothing)++> ,("max(a) over (partition by b,c)"+> ,WindowApp "max" [Iden "a"] [Iden "b",Iden "c"] [] Nothing)++> ,("sum(a) over (order by b)"+> ,WindowApp "sum" [Iden "a"] []+> [SortSpec (Iden "b") Asc NullsOrderDefault] Nothing)++> ,("sum(a) over (order by b desc,c)"+> ,WindowApp "sum" [Iden "a"] []+> [SortSpec (Iden "b") Desc NullsOrderDefault+> ,SortSpec (Iden "c") Asc NullsOrderDefault] Nothing)++> ,("sum(a) over (partition by b order by c)"+> ,WindowApp "sum" [Iden "a"] [Iden "b"]+> [SortSpec (Iden "c") Asc NullsOrderDefault] Nothing)++> ,("sum(a) over (partition by b order by c range unbounded preceding)"+> ,WindowApp "sum" [Iden "a"] [Iden "b"]+> [SortSpec (Iden "c") Asc NullsOrderDefault]+> $ Just $ FrameFrom FrameRange UnboundedPreceding)++> ,("sum(a) over (partition by b order by c range 5 preceding)"+> ,WindowApp "sum" [Iden "a"] [Iden "b"]+> [SortSpec (Iden "c") Asc NullsOrderDefault]+> $ Just $ FrameFrom FrameRange $ Preceding (NumLit "5"))++> ,("sum(a) over (partition by b order by c range current row)"+> ,WindowApp "sum" [Iden "a"] [Iden "b"]+> [SortSpec (Iden "c") Asc NullsOrderDefault]+> $ Just $ FrameFrom FrameRange Current)++> ,("sum(a) over (partition by b order by c rows 5 following)"+> ,WindowApp "sum" [Iden "a"] [Iden "b"]+> [SortSpec (Iden "c") Asc NullsOrderDefault]+> $ Just $ FrameFrom FrameRows $ Following (NumLit "5"))++> ,("sum(a) over (partition by b order by c range unbounded following)"+> ,WindowApp "sum" [Iden "a"] [Iden "b"]+> [SortSpec (Iden "c") Asc NullsOrderDefault]+> $ Just $ FrameFrom FrameRange UnboundedFollowing)++> ,("sum(a) over (partition by b order by c \n\+> \range between 5 preceding and 5 following)"+> ,WindowApp "sum" [Iden "a"] [Iden "b"]+> [SortSpec (Iden "c") Asc NullsOrderDefault]+> $ Just $ FrameBetween FrameRange+> (Preceding (NumLit "5"))+> (Following (NumLit "5")))++> ]++> parens :: TestItem+> parens = Group "parens" $ map (uncurry TestValueExpr)+> [("(a)", Parens (Iden "a"))+> ,("(a + b)", Parens (BinOp (Iden "a") "+" (Iden "b")))+> ]
+ tools/SQLIndent.lhs view
@@ -0,0 +1,16 @@++> import System.Environment++> import Language.SQL.SimpleSQL.Pretty+> import Language.SQL.SimpleSQL.Parser++> main :: IO ()+> main = do+> args <- getArgs+> case args of+> [f] -> do+> src <- readFile f+> either (error . peFormattedError)+> (putStrLn . prettyQueryExprs)+> $ parseQueryExprs f Nothing src+> _ -> error "please pass filename to indent"