From 9092721ebb704466ecd4242d087391df5aa1952d Mon Sep 17 00:00:00 2001
From: Jake Wheat <jakewheatmail@gmail.com>
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