get proof of concept fixity handling working

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

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
+> sqlFixities :: [[Fixity]]
-with precedence and associativity and adjust a scalar expr tree to
+> sqlFixities = highPrec ++ defaultPrec ++ lowPrec
-match these. It shouldn't attempt to descend into scalar expressions
+>   where
-inside nested query exprs in subqueries. This way we separate out
+>     allOps = binOpSymbolNames ++ binOpKeywordNames
-parsing from handling the precedence and associativity. Is it a good
+>              ++ (map unwords binOpMultiKeywordNames)
-idea to separate these? I'm not sure. I think it makes some error
+>              ++ prefixUnOpKeywordNames ++ prefixUnOpSymbolNames
-messages potentially a little less helpful without some extra work,
+>              ++ postfixOpKeywords
-but apart from that, I think it is a win in terms of code clarity. The
+>     highPrec = [infixl_ ["*","/"]
-errors which are harder to produce nicely I think are limited to
+>                ,infixl_ ["+", "-"]
-chained binary operators with no parens which have no associativity
+>                ,infixl_ ["<=",">=","!=","<>","||","like"]
-which should be a parse error.
+>                ]
+>     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']
 
 -------------------------------------------------
 

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