From 9092721ebb704466ecd4242d087391df5aa1952d Mon Sep 17 00:00:00 2001 From: Jake Wheat Date: Sat, 14 Dec 2013 15:05:52 +0200 Subject: [PATCH] get proof of concept fixity handling working --- Language/SQL/SimpleSQL/Fixity.lhs | 131 ++++++++++++++++++++++++++++++ Language/SQL/SimpleSQL/Parser.lhs | 49 +++++------ simple-sql-parser.cabal | 5 +- 3 files changed, 159 insertions(+), 26 deletions(-) create mode 100644 Language/SQL/SimpleSQL/Fixity.lhs diff --git a/Language/SQL/SimpleSQL/Fixity.lhs b/Language/SQL/SimpleSQL/Fixity.lhs new file mode 100644 index 0000000..ad3ef4d --- /dev/null +++ b/Language/SQL/SimpleSQL/Fixity.lhs @@ -0,0 +1,131 @@ + +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? + +> 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 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. + +> toHaskell :: ScalarExpr -> HSE.Exp +> toHaskell e = case e of +> BinOp e0 op e1 -> HSE.InfixApp +> (toHaskell e0) +> (HSE.QVarOp $ HSE.UnQual $ HSE.Symbol 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 "*") +> Parens e0 -> HSE.Paren $ toHaskell e0 +> -- map the two maybes to lists with either 0 or 1 element +> Case v ts el -> HSE.App (toHaskell $ Identifier "$case") +> (HSE.List [ltoh $ maybeToList v +> ,HSE.List $ map (ltoh . (\(a,b) -> [a,b])) ts +> ,ltoh $ maybeToList el])-} +> where +> ltoh = HSE.List . map toHaskell + +> 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.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]) -> +> 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 +> where +> ltom (HSE.List []) = Nothing +> ltom (HSE.List [ex]) = Just $ toSql ex +> ltom ex = error $ "unsupported haskell " ++ show ex +> pairs (HSE.List l) = map (\(HSE.List [a,b]) -> (toSql a, toSql b)) l +> pairs ex = error $ "unsupported haskell " ++ show ex diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs index 7bdc0cd..0faf329 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/Language/SQL/SimpleSQL/Parser.lhs @@ -14,6 +14,7 @@ > import qualified Text.Parsec as P > import Language.SQL.SimpleSQL.Syntax +> import Language.SQL.SimpleSQL.Fixity The public api functions. @@ -375,30 +376,30 @@ associativity. > else binOpKeywordNames)) > keywords ks = unwords <$> mapM keyword ks -TODO: create the fixity adjuster. This should take a list of operators -with precedence and associativity and adjust a scalar expr tree to -match these. It shouldn't attempt to descend into scalar expressions -inside nested query exprs in subqueries. This way we separate out -parsing from handling the precedence and associativity. Is it a good -idea to separate these? I'm not sure. I think it makes some error -messages potentially a little less helpful without some extra work, -but apart from that, I think it is a win in terms of code clarity. The -errors which are harder to produce nicely I think are limited to -chained binary operators with no parens which have no associativity -which should be a parse error. +> sqlFixities :: [[Fixity]] +> sqlFixities = highPrec ++ defaultPrec ++ lowPrec +> where +> allOps = binOpSymbolNames ++ binOpKeywordNames +> ++ (map unwords binOpMultiKeywordNames) +> ++ prefixUnOpKeywordNames ++ prefixUnOpSymbolNames +> ++ postfixOpKeywords +> highPrec = [infixl_ ["*","/"] +> ,infixl_ ["+", "-"] +> ,infixl_ ["<=",">=","!=","<>","||","like"] +> ] +> lowPrec = [infix_ ["<",">"] +> ,infixr_ ["="] +> ,infixr_ ["not"] +> ,infixl_ ["and"] +> ,infixl_ ["or"]] +> already = concatMap (map fName) highPrec +> ++ concatMap (map fName) lowPrec +> 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 -> {-sqlFixities :: [HSE.Fixity] -> sqlFixities = HSE.infixl_ 9 ["*", "/"] -> ++ HSE.infixl_ 8 ["+", "-"] -> ++ HSE.infixl_ 6 ["<=",">=","!=","<>","||", "like"] -> ++ HSE.infix_ 4 ["<", ">"] -> ++ HSE.infixr_ 3 ["="] -> ++ HSE.infixr_ 2 ["or"] -> ++ HSE.infixl_ 1 ["and"] -> ++ HSE.infixl_ 0 ["or"]-} - -> fixFixities :: ScalarExpr -> ScalarExpr -> fixFixities = id == scalar expressions @@ -451,7 +452,7 @@ expression tree (for efficiency and code clarity). > scalarExpr :: P ScalarExpr > scalarExpr = > choice [try star -> ,fixFixities <$> scalarExpr'] +> ,fixFixities sqlFixities <$> scalarExpr'] ------------------------------------------------- diff --git a/simple-sql-parser.cabal b/simple-sql-parser.cabal index ff17b69..e01eb00 100644 --- a/simple-sql-parser.cabal +++ b/simple-sql-parser.cabal @@ -24,12 +24,13 @@ library exposed-modules: Language.SQL.SimpleSQL.Pretty, Language.SQL.SimpleSQL.Parser, Language.SQL.SimpleSQL.Syntax - -- other-modules: + other-modules: Language.SQL.SimpleSQL.Fixity -- other-extensions: build-depends: base >=4.6 && <4.7, parsec >=3.1 && <3.2, mtl >=2.1 && <2.2, - pretty >= 1.1 && < 1.2 + pretty >= 1.1 && < 1.2, + haskell-src-exts >= 1.14 && < 1.15 -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall \ No newline at end of file