give in and use the parsec buildExpressionParser for now
This commit is contained in:
jake
parent
40c64c7631
commit
9d8c1badbd
|
|
@ -1,249 +0,0 @@
|
|||
|
||||
This is the module which deals with fixing up the value 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 value expr parser?
|
||||
|
||||
|
||||
|
||||
New plan to write custom fixity code to work directly on
|
||||
simple-query-parser AST.
|
||||
|
||||
Might also want to run simple fixity fixes on CombineQueryExprs, and
|
||||
on tableref trees.
|
||||
|
||||
these operators take part in fixity:
|
||||
binop prefixop postfixop
|
||||
in, any, some, all
|
||||
between: maybe postfix ops might be either in the last expr in the
|
||||
between or outside the between (& not between)
|
||||
collate
|
||||
|
||||
these don't: we just recursively apply on each sub value expr
|
||||
independently
|
||||
all special ops, except the special case for between
|
||||
case, should check nested cases work nice
|
||||
app, agg app, winapp, parens
|
||||
casts:
|
||||
cast(a as b) doesn't
|
||||
int 'sdasd' doesn't since the argument is a string literal only
|
||||
a::b does, this is postgres which isn't currently supported. Would
|
||||
like to support it in the future though. This will not be a ast
|
||||
binary op since the second argument is a typename and not a value
|
||||
expr
|
||||
|
||||
because the parser applies the fixity fix to every 'top level' value
|
||||
expr, we don't need to descend into query exprs to find the value
|
||||
exprs inside them.
|
||||
|
||||
start creating test list:
|
||||
|
||||
create tests with an explicit fixity table to check the features of
|
||||
the fixity code, then create tests for sql value expressions which
|
||||
sanity check the fixity applied to these expressions.
|
||||
|
||||
basic fixity tests:
|
||||
|
||||
a + b + c
|
||||
a + b * c
|
||||
a * b + c
|
||||
a + b + c * d
|
||||
a * b + c + d
|
||||
|
||||
try also with right assocative
|
||||
|
||||
a HI b PostfixLow
|
||||
|
||||
a low b PostfixHigh
|
||||
|
||||
a LOWEST b HI c PostfixMEDIUM
|
||||
+ variations
|
||||
|
||||
same with prefix
|
||||
same with chained binops
|
||||
|
||||
----
|
||||
|
||||
now sanity check the basic operators (these use BinOp, PrefixOp,
|
||||
PostfixOp) then sanity check all the other operators which take part
|
||||
in the fixity
|
||||
|
||||
|
||||
> {-# 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 value 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 value 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]] -> ValueExpr -> ValueExpr
|
||||
> fixFixities fs se =
|
||||
> runIdentity $ toSql <$> HSE.applyFixities (toHSEFixity fs) (toHaskell se)
|
||||
|
||||
Now have to convert all our value 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 :: ValueExpr -> HSE.Exp
|
||||
> toHaskell e = case e of
|
||||
> BinOp e0 op e1 -> HSE.InfixApp
|
||||
> (toHaskell e0)
|
||||
> (HSE.QVarOp $ sym $ name op)
|
||||
> (toHaskell e1)
|
||||
> -- TODO fix me
|
||||
> (SpecialOpK {}) -> str ('v':show e)
|
||||
> Iden {} -> str ('v':show e)
|
||||
> Parameter -> 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 . (\(SortSpec a _ _) -> a))
|
||||
> orderInf = map (\(SortSpec _ b c) -> (b,c))
|
||||
|
||||
|
||||
|
||||
|
||||
> toSql :: HSE.Exp -> ValueExpr
|
||||
> 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 -> SortSpec (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
|
||||
|
|
@ -1,3 +1,6 @@
|
|||
TODO:
|
||||
P -> P.Parser
|
||||
swap order in select items
|
||||
|
||||
> {-# LANGUAGE TupleSections #-}
|
||||
> -- | This is the module with the parser functions.
|
||||
|
|
@ -14,9 +17,9 @@
|
|||
> import Text.Parsec hiding (ParseError)
|
||||
> import qualified Text.Parsec as P
|
||||
> import Text.Parsec.Perm
|
||||
> import qualified Text.Parsec.Expr as E
|
||||
|
||||
> import Language.SQL.SimpleSQL.Syntax
|
||||
> import Language.SQL.SimpleSQL.Fixity
|
||||
|
||||
The public API functions.
|
||||
|
||||
|
|
@ -159,7 +162,7 @@ aggregate([all|distinct] args [order by orderitems])
|
|||
> makeApp
|
||||
> <$> name
|
||||
> <*> parens ((,,) <$> try duplicates
|
||||
> <*> choice [commaSep valueExpr']
|
||||
> <*> choice [commaSep valueExpr]
|
||||
> <*> try (optionMaybe orderBy))
|
||||
> where
|
||||
> makeApp i (Nothing,es,Nothing) = App i es
|
||||
|
|
@ -189,7 +192,7 @@ always used with the optionSuffix combinator.
|
|||
> <*> optionMaybe frameClause)
|
||||
> where
|
||||
> partitionBy = try (keyword_ "partition") >>
|
||||
> keyword_ "by" >> commaSep1 valueExpr'
|
||||
> keyword_ "by" >> commaSep1 valueExpr
|
||||
> frameClause =
|
||||
> mkFrame <$> choice [FrameRows <$ keyword_ "rows"
|
||||
> ,FrameRange <$ keyword_ "range"]
|
||||
|
|
@ -224,14 +227,14 @@ always used with the optionSuffix combinator.
|
|||
|
||||
> scase :: P ValueExpr
|
||||
> scase =
|
||||
> Case <$> (try (keyword_ "case") *> optionMaybe (try valueExpr'))
|
||||
> Case <$> (try (keyword_ "case") *> optionMaybe (try valueExpr))
|
||||
> <*> many1 swhen
|
||||
> <*> optionMaybe (try (keyword_ "else") *> valueExpr')
|
||||
> <*> optionMaybe (try (keyword_ "else") *> valueExpr)
|
||||
> <* keyword_ "end"
|
||||
> where
|
||||
> swhen = keyword_ "when" *>
|
||||
> ((,) <$> commaSep1 valueExpr'
|
||||
> <*> (keyword_ "then" *> valueExpr'))
|
||||
> ((,) <$> commaSep1 valueExpr
|
||||
> <*> (keyword_ "then" *> valueExpr))
|
||||
|
||||
== miscellaneous keyword operators
|
||||
|
||||
|
|
@ -246,7 +249,7 @@ cast: cast(expr as type)
|
|||
> cast = parensCast <|> prefixCast
|
||||
> where
|
||||
> parensCast = try (keyword_ "cast") >>
|
||||
> parens (Cast <$> valueExpr'
|
||||
> parens (Cast <$> valueExpr
|
||||
> <*> (keyword_ "as" *> typeName))
|
||||
> prefixCast = try (TypedLit <$> typeName
|
||||
> <*> stringLiteral)
|
||||
|
|
@ -268,7 +271,7 @@ operatorname(firstArg keyword0 arg0 keyword1 arg1 etc.)
|
|||
> keyword_ opName >> do
|
||||
> void $ symbol "("
|
||||
> let pfa = do
|
||||
> e <- valueExpr'
|
||||
> e <- valueExpr
|
||||
> -- check we haven't parsed the first
|
||||
> -- keyword as an identifier
|
||||
> guard (case (e,kws) of
|
||||
|
|
@ -284,7 +287,7 @@ operatorname(firstArg keyword0 arg0 keyword1 arg1 etc.)
|
|||
> return $ SpecialOpK (Name opName) fa $ catMaybes as
|
||||
> where
|
||||
> parseArg (nm,mand) =
|
||||
> let p = keyword_ nm >> valueExpr'
|
||||
> let p = keyword_ nm >> valueExpr
|
||||
> in fmap (nm,) <$> if mand
|
||||
> then Just <$> p
|
||||
> else optionMaybe (try p)
|
||||
|
|
@ -347,7 +350,7 @@ in the source
|
|||
> parens (mkTrim
|
||||
> <$> option "both" sides
|
||||
> <*> option " " stringLiteral
|
||||
> <*> (keyword_ "from" *> valueExpr')
|
||||
> <*> (keyword_ "from" *> valueExpr)
|
||||
> <*> optionMaybe (keyword_ "collate" *> stringLiteral))
|
||||
> where
|
||||
> sides = choice ["leading" <$ keyword_ "leading"
|
||||
|
|
@ -363,16 +366,19 @@ in: two variations:
|
|||
a in (expr0, expr1, ...)
|
||||
a in (queryexpr)
|
||||
|
||||
> inSuffix :: ValueExpr -> P ValueExpr
|
||||
> inSuffix e =
|
||||
> In <$> inty
|
||||
> <*> return e
|
||||
> <*> parens (choice
|
||||
> [InQueryExpr <$> queryExpr
|
||||
> ,InList <$> commaSep1 valueExpr'])
|
||||
this is parsed as a postfix operator which is why it is in this form
|
||||
|
||||
> inSuffix :: P (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
|
||||
|
|
@ -385,19 +391,18 @@ 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 value expression parser which
|
||||
is identical to the normal one expect it doesn't recognise the binary
|
||||
and operator. This is the call to valueExpr'' True.
|
||||
and operator. This is the call to valueExprB.
|
||||
|
||||
> betweenSuffix :: ValueExpr -> P ValueExpr
|
||||
> betweenSuffix e =
|
||||
> betweenSuffix :: P (ValueExpr -> ValueExpr)
|
||||
> betweenSuffix =
|
||||
> makeOp <$> (Name <$> opName)
|
||||
> <*> return e
|
||||
> <*> valueExpr'' True
|
||||
> <*> (keyword_ "and" *> valueExpr'' 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)
|
||||
|
|
@ -457,7 +462,7 @@ todo: timestamp types:
|
|||
|
||||
> sparens :: P ValueExpr
|
||||
> sparens =
|
||||
> ctor <$> parens (commaSep1 valueExpr')
|
||||
> ctor <$> parens (commaSep1 valueExpr)
|
||||
> where
|
||||
> ctor [a] = Parens a
|
||||
> ctor as = SpecialOp (Name "rowctor") as
|
||||
|
|
@ -470,177 +475,92 @@ unary prefix, unary postfix and binary infix operators. The operators
|
|||
can be symbols (a + b), single keywords (a and b) or multiple keywords
|
||||
(a is similar to b).
|
||||
|
||||
First, the list of the regulars operators split by operator type
|
||||
(prefix, postfix, binary) and by symbol/single keyword/ multiple
|
||||
keyword.
|
||||
|
||||
> binOpSymbolNames :: [String]
|
||||
> binOpSymbolNames =
|
||||
> ["=", "<=", ">=", "!=", "<>", "<", ">"
|
||||
> ,"*", "/", "+", "-", "%"
|
||||
> ,"||", "."
|
||||
> ,"^", "|", "&"
|
||||
> ]
|
||||
|
||||
> binOpKeywordNames :: [String]
|
||||
> binOpKeywordNames = ["and", "or", "like", "overlaps"]
|
||||
|
||||
> binOpMultiKeywordNames :: [[String]]
|
||||
> binOpMultiKeywordNames = map words
|
||||
> ["not like"
|
||||
> ,"is similar to"
|
||||
> ,"is not similar to"
|
||||
> ,"is distinct from"
|
||||
> ,"is not distinct from"]
|
||||
|
||||
used for between parsing
|
||||
|
||||
> binOpKeywordNamesNoAnd :: [String]
|
||||
> binOpKeywordNamesNoAnd = filter (/="and") binOpKeywordNames
|
||||
|
||||
There aren't any multi keyword prefix operators currently supported.
|
||||
|
||||
> prefixUnOpKeywordNames :: [String]
|
||||
> prefixUnOpKeywordNames = ["not"]
|
||||
|
||||
> prefixUnOpSymbolNames :: [String]
|
||||
> prefixUnOpSymbolNames = ["+", "-", "~"]
|
||||
|
||||
There aren't any single keyword postfix operators currently
|
||||
supported. Maybe all these 'is's can be left factored?
|
||||
|
||||
> postfixOpKeywords :: [String]
|
||||
> postfixOpKeywords = ["is null"
|
||||
> ,"is not null"
|
||||
> ,"is true"
|
||||
> ,"is not true"
|
||||
> ,"is false"
|
||||
> ,"is not false"
|
||||
> ,"is unknown"
|
||||
> ,"is not unknown"]
|
||||
|
||||
The parsers:
|
||||
|
||||
> prefixUnaryOp :: P ValueExpr
|
||||
> prefixUnaryOp =
|
||||
> PrefixOp <$> (Name <$> opSymbol) <*> valueExpr'
|
||||
> 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 (flip 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
|
||||
> 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 :: ValueExpr -> P ValueExpr
|
||||
> 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 -> ValueExpr -> P ValueExpr
|
||||
> 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
|
||||
|
||||
> sqlFixities :: [[Fixity]]
|
||||
> sqlFixities = highPrec ++ defaultPrec ++ lowPrec
|
||||
> where
|
||||
> allOps = binOpSymbolNames ++ binOpKeywordNames
|
||||
> ++ map unwords binOpMultiKeywordNames
|
||||
> ++ prefixUnOpKeywordNames ++ prefixUnOpSymbolNames
|
||||
> ++ postfixOpKeywords
|
||||
> -- these are the ops with the highest precedence in order
|
||||
> highPrec = [infixl_ ["."]
|
||||
> ,infixl_ ["*","/", "%"]
|
||||
> ,infixl_ ["+", "-"]
|
||||
> ,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)))
|
||||
|
||||
== value expressions
|
||||
|
||||
TODO:
|
||||
left factor stuff which starts with identifier
|
||||
|
||||
This parses most of the value 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 ValueExpr
|
||||
> factor = choice [literal
|
||||
> ,parameter
|
||||
> ,scase
|
||||
> ,cast
|
||||
> ,try specialOpKs
|
||||
> ,subquery
|
||||
> ,prefixUnaryOp
|
||||
> ,try app
|
||||
> ,try star
|
||||
> ,identifier
|
||||
> ,sparens]
|
||||
|
||||
putting the factor together with the extra bits
|
||||
|
||||
> valueExpr'' :: Bool -> P ValueExpr
|
||||
> valueExpr'' 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.
|
||||
|
||||
> valueExpr' :: P ValueExpr
|
||||
> valueExpr' = valueExpr'' False
|
||||
|
||||
The valueExpr wrapper. The idea is that directly nested value
|
||||
expressions use the valueExpr' parser, then other code uses the
|
||||
valueExpr parser and then everyone gets the fixity fixes and it's
|
||||
easy to ensure that this fix is only applied once to each value
|
||||
expression tree (for efficiency and code clarity).
|
||||
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.
|
||||
|
||||
> valueExpr :: P ValueExpr
|
||||
> valueExpr = fixFixities sqlFixities <$> valueExpr'
|
||||
> valueExpr = E.buildExpressionParser (opTable False) term
|
||||
|
||||
> term :: P 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
|
||||
|
||||
> valueExprB :: P ValueExpr
|
||||
> valueExprB = fixFixities sqlFixities <$> valueExpr'' True
|
||||
> valueExprB = E.buildExpressionParser (opTable True) term
|
||||
|
||||
|
||||
-------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -27,13 +27,11 @@ 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
|
||||
|
|
|
|||
|
|
@ -132,7 +132,8 @@ Tests for parsing value expressions
|
|||
> unaryOperators :: TestItem
|
||||
> unaryOperators = Group "unaryOperators" $ map (uncurry TestValueExpr)
|
||||
> [("not a", PrefixOp "not" $ Iden "a")
|
||||
> ,("not not a", PrefixOp "not" $ 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")
|
||||
> ]
|
||||
|
|
@ -247,6 +248,8 @@ keyword special operators
|
|||
> ,("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")])
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue