get fixity adjustment working, fix bug in between parsing

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 $
+> fixFixities fs se =
->      toSql <$> HSE.applyFixities (toHSEFixity fs) (toHaskell 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
+>     Iden {} -> str ('v':show e)
->     StringLit l -> HSE.Lit $ HSE.String ('s':l)
+>     StringLit {} -> str ('v':show e)
->     NumLit n -> HSE.Lit $ HSE.String ('n':n)
+>     NumLit {} -> str ('v':show e)
->     App n es -> HSE.App (toHaskell $ Iden n) $ ltoh es
+>     App n es -> HSE.App (var ('f':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
+>     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.App (HSE.Var (HSE.UnQual (HSE.Ident ('a':i))))
-
+>             (HSE.List [HSE.Lit (HSE.String vs)
->     {-HSE.Var (HSE.UnQual (HSE.Ident "*")) -> Star
+>                       ,HSE.List es
->     HSE.Var (HSE.Qual (HSE.ModuleName q) (HSE.Ident "*")) -> Star2 q
+>                       ,HSE.List od]) ->
->     HSE.Var (HSE.Qual (HSE.ModuleName a) (HSE.Ident b)) -> Identifier2 a b
+>         let (d,dir) = read vs
->     HSE.App (HSE.Var (HSE.UnQual (HSE.Ident "$case"))) (HSE.List [v,ts,el]) ->
+>         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.App (HSE.Lit (HSE.String ('c':nm))) e0 ->
->             (HSE.List [ea]) -> Op "not" [toSql ea]
+>         Cast (toSql e0) (read nm)
->     HSE.App (HSE.Var (HSE.UnQual (HSE.Ident i)))
+>     HSE.App (HSE.Lit (HSE.String ('i':nm)))
->             (HSE.List es) -> App i $ map toSql es
+>             (HSE.List [e0, HSE.List es]) ->
->     HSE.InfixApp e0 (HSE.QVarOp (HSE.UnQual (HSE.Symbol n))) e1 ->
+>         In (read nm) (toSql e0) (InList $ map toSql es)
->         Op n [toSql e0, toSql e1]
+>     HSE.App (HSE.Lit (HSE.String ('j':nm))) e0 ->
->     HSE.Paren e0 -> Parens $ toSql e0 -}
+>         let (b,sq) = read nm
->     _ -> error $ "unsupported haskell " ++ show e
+>         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

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

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)

Tests.lhs

@@ -95,13 +95,12 @@
 >     [("a + b", BinOp (Iden "a") "+" (Iden "b"))
 >      -- sanity check fixities
 >      -- todo: add more fixity checking
->     {-,("a + b * c"
+>     ,("a + b * c"
->      ,Op "+" [Iden "a"
+>      ,BinOp  (Iden "a") "+"
->              ,Op "*" [Iden "b"
+>              (BinOp (Iden "b") "*" (Iden "c")))
->                      ,Iden "c"]])
 >     ,("a * b + c"
->      ,Op "+" [Op "*" [Iden "a", Iden "b"]
+>      ,BinOp (BinOp (Iden "a") "*" (Iden "b"))
->              ,Iden "c"])-}
+>             "+" (Iden "c"))
 >     ]
 
 > unaryOperators :: TestItem