From 730b8a7f0a5ca6aaead5683112bc2a598611eba8 Mon Sep 17 00:00:00 2001 From: Jake Wheat Date: Sat, 14 Dec 2013 16:34:57 +0200 Subject: [PATCH] get fixity adjustment working, fix bug in between parsing --- Language/SQL/SimpleSQL/Fixity.lhs | 131 ++++++++++++++++++++---------- Language/SQL/SimpleSQL/Parser.lhs | 8 +- Language/SQL/SimpleSQL/Syntax.lhs | 24 +++--- Tests.lhs | 11 ++- 4 files changed, 110 insertions(+), 64 deletions(-) diff --git a/Language/SQL/SimpleSQL/Fixity.lhs b/Language/SQL/SimpleSQL/Fixity.lhs index ad3ef4d..2d47201 100644 --- a/Language/SQL/SimpleSQL/Fixity.lhs +++ b/Language/SQL/SimpleSQL/Fixity.lhs @@ -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 diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs index 0faf329..cd5a72d 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/Language/SQL/SimpleSQL/Parser.lhs @@ -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 diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs index cb4a3b5..21c9686 100644 --- a/Language/SQL/SimpleSQL/Syntax.lhs +++ b/Language/SQL/SimpleSQL/Syntax.lhs @@ -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) diff --git a/Tests.lhs b/Tests.lhs index c6f8e5f..ea48b80 100644 --- a/Tests.lhs +++ b/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