get fixity adjustment working, fix bug in between parsing
This commit is contained in:
Jake Wheat
parent
9092721ebb
commit
730b8a7f0a
|
|
@ -6,6 +6,7 @@ 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?
|
||||
|
||||
> {-# LANGUAGE TupleSections #-}
|
||||
> module Language.SQL.SimpleSQL.Fixity
|
||||
> (fixFixities
|
||||
> ,Fixity(..)
|
||||
|
|
@ -19,7 +20,7 @@ made generic?
|
|||
> import qualified Language.Haskell.Exts.Fixity as HSE
|
||||
> import Control.Monad.Identity
|
||||
> import Control.Applicative
|
||||
|
||||
> import Data.Maybe
|
||||
|
||||
> import Language.SQL.SimpleSQL.Syntax
|
||||
|
||||
|
|
@ -60,72 +61,114 @@ 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)
|
||||
> 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.
|
||||
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 $ HSE.UnQual $ HSE.Symbol op)
|
||||
> (HSE.QVarOp $ sym op)
|
||||
> (toHaskell e1)
|
||||
> Iden i -> HSE.Var $ HSE.UnQual $ HSE.Ident i
|
||||
> StringLit l -> HSE.Lit $ HSE.String ('s':l)
|
||||
> NumLit n -> HSE.Lit $ HSE.String ('n':n)
|
||||
> App n es -> HSE.App (toHaskell $ Iden n) $ ltoh es
|
||||
> Parens e0 -> HSE.Paren $ toHaskell e0
|
||||
> {-
|
||||
> Identifier i -> HSE.Var $ HSE.UnQual $ HSE.Ident i
|
||||
> Literal l -> HSE.Lit $ HSE.String l
|
||||
> App n es -> HSE.App (toHaskell $ Identifier n) $ ltoh es
|
||||
> Op n [e0,e1] -> HSE.InfixApp (toHaskell e0)
|
||||
> (HSE.QVarOp $ HSE.UnQual $ HSE.Symbol n)
|
||||
> (toHaskell e1)
|
||||
> Op "not" [e0] -> toHaskell $ App "not" [e0]
|
||||
> Op {} -> error $ "bad args to operator " ++ groom e
|
||||
> Star -> HSE.Var $ HSE.UnQual $ HSE.Ident "*"
|
||||
> Identifier2 a b -> HSE.Var $ HSE.Qual (HSE.ModuleName a) (HSE.Ident b)
|
||||
> Star2 q -> HSE.Var $ HSE.Qual (HSE.ModuleName q) (HSE.Ident "*")
|
||||
> Iden {} -> str ('v':show e)
|
||||
> StringLit {} -> str ('v':show e)
|
||||
> NumLit {} -> str ('v':show e)
|
||||
> App n es -> HSE.App (var ('f':n)) $ ltoh es
|
||||
> Parens e0 -> HSE.Paren $ toHaskell e0
|
||||
> IntervalLit {} -> str ('v':show e)
|
||||
> Iden2 {} -> str ('v':show e)
|
||||
> Star -> str ('v':show e)
|
||||
> Star2 {} -> str ('v':show e)
|
||||
> AggregateApp nm d es od ->
|
||||
> HSE.App (var ('a':nm))
|
||||
> $ HSE.List [str $ show (d,map snd od)
|
||||
> ,HSE.List $ map toHaskell es
|
||||
> ,HSE.List $ map toHaskell $ map fst od]
|
||||
> WindowApp nm es pb od ->
|
||||
> HSE.App (var ('w':nm))
|
||||
> $ HSE.List [str $ show (map snd od)
|
||||
> ,HSE.List $ map toHaskell es
|
||||
> ,HSE.List $ map toHaskell pb
|
||||
> ,HSE.List $ map toHaskell $ map fst od]
|
||||
> PrefixOp nm e0 ->
|
||||
> HSE.App (HSE.Var $ sym nm) (toHaskell e0)
|
||||
> PostfixOp nm e0 ->
|
||||
> HSE.App (HSE.Var $ sym ('p':nm)) (toHaskell e0)
|
||||
> SpecialOp nm es ->
|
||||
> HSE.App (var ('s':nm)) $ HSE.List $ map toHaskell es
|
||||
> -- map the two maybes to lists with either 0 or 1 element
|
||||
> Case v ts el -> HSE.App (toHaskell $ Identifier "$case")
|
||||
> Case v ts el -> HSE.App (var "$case")
|
||||
> (HSE.List [ltoh $ maybeToList v
|
||||
> ,HSE.List $ map (ltoh . (\(a,b) -> [a,b])) ts
|
||||
> ,ltoh $ maybeToList el])-}
|
||||
> ,ltoh $ maybeToList el])
|
||||
> Cast e0 tn -> HSE.App (str ('c':show tn)) $ toHaskell e0
|
||||
> CastOp {} -> 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
|
||||
|
||||
|
||||
> toSql :: HSE.Exp -> ScalarExpr
|
||||
> toSql e = case e of
|
||||
> HSE.Var (HSE.UnQual (HSE.Ident i)) -> Iden i
|
||||
> HSE.Lit (HSE.String ('s':l)) -> StringLit l
|
||||
> HSE.Lit (HSE.String ('n':l)) -> NumLit l
|
||||
|
||||
|
||||
> HSE.InfixApp e0 (HSE.QVarOp (HSE.UnQual (HSE.Symbol n))) e1 ->
|
||||
> BinOp (toSql e0) n (toSql e1)
|
||||
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident i)))
|
||||
> HSE.Lit (HSE.String ('v':l)) -> read l
|
||||
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('f':i))))
|
||||
> (HSE.List es) -> App i $ map toSql es
|
||||
> HSE.Paren e0 -> Parens $ toSql e0
|
||||
|
||||
|
||||
> {-HSE.Var (HSE.UnQual (HSE.Ident "*")) -> Star
|
||||
> HSE.Var (HSE.Qual (HSE.ModuleName q) (HSE.Ident "*")) -> Star2 q
|
||||
> HSE.Var (HSE.Qual (HSE.ModuleName a) (HSE.Ident b)) -> Identifier2 a b
|
||||
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident "$case"))) (HSE.List [v,ts,el]) ->
|
||||
> 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,dir) = read vs
|
||||
> in AggregateApp i d (map toSql es)
|
||||
> $ zip (map toSql od) dir
|
||||
> 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 dir = read vs
|
||||
> in WindowApp i (map toSql es)
|
||||
> (map toSql pb)
|
||||
> $ zip (map toSql od) dir
|
||||
> HSE.App (HSE.Var (HSE.UnQual (HSE.Symbol ('p':nm)))) e0 ->
|
||||
> PostfixOp nm $ toSql e0
|
||||
> HSE.App (HSE.Var (HSE.UnQual (HSE.Symbol nm))) e0 ->
|
||||
> PrefixOp nm $ toSql e0
|
||||
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('s':nm)))) (HSE.List es) ->
|
||||
> SpecialOp nm $ map toSql es
|
||||
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident "$case")))
|
||||
> (HSE.List [v,ts,el]) ->
|
||||
> Case (ltom v) (pairs ts) (ltom el)
|
||||
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident "not")))
|
||||
> (HSE.List [ea]) -> Op "not" [toSql ea]
|
||||
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident i)))
|
||||
> (HSE.List es) -> App i $ map toSql es
|
||||
> HSE.InfixApp e0 (HSE.QVarOp (HSE.UnQual (HSE.Symbol n))) e1 ->
|
||||
> Op n [toSql e0, toSql e1]
|
||||
> HSE.Paren e0 -> Parens $ toSql e0 -}
|
||||
> _ -> error $ "unsupported haskell " ++ show e
|
||||
> 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
|
||||
> ltom (HSE.List []) = Nothing
|
||||
> ltom (HSE.List [ex]) = Just $ toSql ex
|
||||
> ltom ex = error $ "unsupported haskell " ++ show ex
|
||||
> ltom ex = err ex
|
||||
> pairs (HSE.List l) = map (\(HSE.List [a,b]) -> (toSql a, toSql b)) l
|
||||
> pairs ex = error $ "unsupported haskell " ++ show ex
|
||||
> pairs ex = err ex
|
||||
> err :: Show a => a -> e
|
||||
> err a = error $ "simple-sql-parser: internal fixity error " ++ show a
|
||||
|
|
|
|||
|
|
@ -250,7 +250,7 @@ and operator. This is the call to scalarExpr'' True.
|
|||
> makeOp <$> opName
|
||||
> <*> return e
|
||||
> <*> scalarExpr'' True
|
||||
> <*> (keyword_ "and" *> scalarExpr')
|
||||
> <*> (keyword_ "and" *> scalarExpr'' True)
|
||||
> where
|
||||
> opName = try $ choice
|
||||
> ["between" <$ keyword_ "between"
|
||||
|
|
@ -361,7 +361,7 @@ The parsers:
|
|||
> keywords_ = try . mapM_ keyword_
|
||||
|
||||
All the binary operators are parsed as same precedence and left
|
||||
associativity.
|
||||
associativity. This is fixed with a separate pass over the ast.
|
||||
|
||||
> binaryOperatorSuffix :: Bool -> ScalarExpr -> P ScalarExpr
|
||||
> binaryOperatorSuffix bExpr e0 =
|
||||
|
|
@ -383,10 +383,12 @@ associativity.
|
|||
> ++ (map unwords binOpMultiKeywordNames)
|
||||
> ++ prefixUnOpKeywordNames ++ prefixUnOpSymbolNames
|
||||
> ++ postfixOpKeywords
|
||||
> -- these are the ops with the highest precedence in order
|
||||
> highPrec = [infixl_ ["*","/"]
|
||||
> ,infixl_ ["+", "-"]
|
||||
> ,infixl_ ["<=",">=","!=","<>","||","like"]
|
||||
> ]
|
||||
> -- these are the ops with the lowest precedence in order
|
||||
> lowPrec = [infix_ ["<",">"]
|
||||
> ,infixr_ ["="]
|
||||
> ,infixr_ ["not"]
|
||||
|
|
@ -394,6 +396,8 @@ associativity.
|
|||
> ,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
|
||||
|
|
|
|||
|
|
@ -105,17 +105,17 @@
|
|||
> -- (1,2)')
|
||||
> | In Bool -- true if in, false if not in
|
||||
> ScalarExpr InThing
|
||||
> deriving (Eq,Show)
|
||||
> deriving (Eq,Show,Read)
|
||||
|
||||
> -- | Represents a type name, used in casts.
|
||||
> data TypeName = TypeName String deriving (Eq,Show)
|
||||
> data TypeName = TypeName String deriving (Eq,Show,Read)
|
||||
|
||||
|
||||
> -- | Used for 'expr in (scalar expression list)', and 'expr in
|
||||
> -- | (subquery)' syntax
|
||||
> data InThing = InList [ScalarExpr]
|
||||
> | InQueryExpr QueryExpr
|
||||
> deriving (Eq,Show)
|
||||
> deriving (Eq,Show,Read)
|
||||
|
||||
> -- | A subquery in a scalar expression
|
||||
> data SubQueryExprType
|
||||
|
|
@ -129,7 +129,7 @@
|
|||
> | SqSome
|
||||
> -- | any (query expr)
|
||||
> | SqAny
|
||||
> deriving (Eq,Show)
|
||||
> deriving (Eq,Show,Read)
|
||||
|
||||
> -- | Represents a query expression, which can be:
|
||||
> --
|
||||
|
|
@ -163,7 +163,7 @@
|
|||
> ,qe2 :: QueryExpr
|
||||
> }
|
||||
> | With [(String,QueryExpr)] QueryExpr
|
||||
> deriving (Eq,Show)
|
||||
> deriving (Eq,Show,Read)
|
||||
|
||||
TODO: add queryexpr parens to deal with e.g.
|
||||
(select 1 union select 2) union select 3
|
||||
|
|
@ -173,14 +173,14 @@ I'm not sure if this is valid syntax or not
|
|||
> -- | 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)
|
||||
> data Duplicates = Distinct | All deriving (Eq,Show,Read)
|
||||
|
||||
> -- | The direction for a column in order by.
|
||||
> data Direction = Asc | Desc deriving (Eq,Show)
|
||||
> data Direction = Asc | Desc deriving (Eq,Show,Read)
|
||||
> -- | Query expression set operators
|
||||
> data CombineOp = Union | Except | Intersect deriving (Eq,Show)
|
||||
> data CombineOp = Union | Except | Intersect deriving (Eq,Show,Read)
|
||||
> -- | Corresponding, an option for the set operators
|
||||
> data Corresponding = Corresponding | Respectively deriving (Eq,Show)
|
||||
> data Corresponding = Corresponding | Respectively deriving (Eq,Show,Read)
|
||||
|
||||
> -- | helper/'default' value for query exprs to make creating query expr values a little easier
|
||||
> makeSelect :: QueryExpr
|
||||
|
|
@ -205,16 +205,16 @@ I'm not sure if this is valid syntax or not
|
|||
> | TRAlias TableRef String (Maybe [String])
|
||||
> -- | from (query expr)
|
||||
> | TRQueryExpr QueryExpr
|
||||
> deriving (Eq,Show)
|
||||
> deriving (Eq,Show,Read)
|
||||
|
||||
TODO: add function table ref
|
||||
|
||||
> -- | The type of a join
|
||||
> data JoinType = JInner | JLeft | JRight | JFull | JCross
|
||||
> deriving (Eq,Show)
|
||||
> deriving (Eq,Show,Read)
|
||||
|
||||
> -- | The join condition.
|
||||
> data JoinCondition = JoinOn ScalarExpr -- ^ on expr
|
||||
> | JoinUsing [String] -- ^ using (column list)
|
||||
> | JoinNatural -- ^ natural join was used
|
||||
> deriving (Eq,Show)
|
||||
> deriving (Eq,Show,Read)
|
||||
|
|
|
|||
11
Tests.lhs
11
Tests.lhs
|
|
@ -95,13 +95,12 @@
|
|||
> [("a + b", BinOp (Iden "a") "+" (Iden "b"))
|
||||
> -- sanity check fixities
|
||||
> -- todo: add more fixity checking
|
||||
> {-,("a + b * c"
|
||||
> ,Op "+" [Iden "a"
|
||||
> ,Op "*" [Iden "b"
|
||||
> ,Iden "c"]])
|
||||
> ,("a + b * c"
|
||||
> ,BinOp (Iden "a") "+"
|
||||
> (BinOp (Iden "b") "*" (Iden "c")))
|
||||
> ,("a * b + c"
|
||||
> ,Op "+" [Op "*" [Iden "a", Iden "b"]
|
||||
> ,Iden "c"])-}
|
||||
> ,BinOp (BinOp (Iden "a") "*" (Iden "b"))
|
||||
> "+" (Iden "c"))
|
||||
> ]
|
||||
|
||||
> unaryOperators :: TestItem
|
||||
|
|
|
|||
Loading…
Reference in a new issue