put the modules in a better path
This commit is contained in:
parent
e3be820dfb
commit
afc6933f64
5 changed files with 25 additions and 18 deletions
Language/SQL/SimpleSQL
309
Language/SQL/SimpleSQL/Parser.lhs
Normal file
309
Language/SQL/SimpleSQL/Parser.lhs
Normal file
|
@ -0,0 +1,309 @@
|
|||
|
||||
|
||||
> module Language.SQL.SimpleSQL.Parser
|
||||
> (parseQueryExpr
|
||||
> ,parseScalarExpr
|
||||
> ,ParseError) where
|
||||
|
||||
> import Text.Groom
|
||||
> import Text.Parsec
|
||||
> import Control.Monad.Identity
|
||||
> import Control.Applicative hiding (many, (<|>), optional)
|
||||
> import qualified Language.Haskell.Exts.Syntax as HSE
|
||||
> import qualified Language.Haskell.Exts.Fixity as HSE
|
||||
> import Data.Maybe
|
||||
|
||||
> import Language.SQL.SimpleSQL.Syntax
|
||||
|
||||
|
||||
> parseQueryExpr :: FilePath -> Maybe (Int,Int) -> String -> Either ParseError QueryExpr
|
||||
> parseQueryExpr _ _ = parse (whiteSpace *> queryExpr <* eof) ""
|
||||
|
||||
> parseScalarExpr :: FilePath -> Maybe (Int,Int) -> String -> Either ParseError ScalarExpr
|
||||
> parseScalarExpr _ _ = parse (whiteSpace *> scalarExpr <* eof) ""
|
||||
|
||||
|
||||
> type P a = ParsecT String () Identity a
|
||||
|
||||
|
||||
------------------------------------------------
|
||||
|
||||
= scalar expressions
|
||||
|
||||
> estring :: P ScalarExpr
|
||||
> estring = Literal <$> (symbol_ "'" *> manyTill anyChar (symbol_ "'"))
|
||||
|
||||
> integer :: P ScalarExpr
|
||||
> integer = Literal <$> (many1 digit <* whiteSpace)
|
||||
|
||||
> literal :: P ScalarExpr
|
||||
> literal = integer <|> estring
|
||||
|
||||
> identifierString :: P String
|
||||
> identifierString = do
|
||||
> s <- (:) <$> letterOrUnderscore
|
||||
> <*> many letterDigitOrUnderscore <* whiteSpace
|
||||
> guard (s `notElem` blacklist)
|
||||
> return s
|
||||
> where
|
||||
> letterOrUnderscore = char '_' <|> letter
|
||||
> letterDigitOrUnderscore = char '_' <|> alphaNum
|
||||
> blacklist :: [String]
|
||||
> blacklist = ["as", "from", "where", "having", "group", "order"
|
||||
> ,"inner", "left", "right", "full", "natural", "join"
|
||||
> ,"on", "using", "when", "then", "case", "end", "order"]
|
||||
|
||||
TODO: talk about what must be in the blacklist, and what doesn't need
|
||||
to be.
|
||||
|
||||
> identifier :: P ScalarExpr
|
||||
> identifier = Identifier <$> identifierString
|
||||
|
||||
> dottedIdentifier :: P ScalarExpr
|
||||
> dottedIdentifier = Identifier2 <$> identifierString
|
||||
> <*> (symbol "." *> identifierString)
|
||||
|
||||
> star :: P ScalarExpr
|
||||
> star = choice [Star <$ symbol "*"
|
||||
> ,Star2 <$> (identifierString <* symbol "." <* symbol "*")]
|
||||
|
||||
|
||||
> app :: P ScalarExpr
|
||||
> app = App <$> identifierString
|
||||
> -- support for count(*)
|
||||
> <*> parens (choice[(:[]) <$> try star
|
||||
> ,commaSep scalarExpr'])
|
||||
|
||||
> scase :: P ScalarExpr
|
||||
> scase =
|
||||
> Case <$> (try (keyword_ "case") *> optionMaybe (try scalarExpr'))
|
||||
> <*> many1 swhen
|
||||
> <*> optionMaybe (try (keyword_ "else") *> scalarExpr')
|
||||
> <* keyword_ "end"
|
||||
> where
|
||||
> swhen = keyword_ "when" *>
|
||||
> ((,) <$> scalarExpr' <*> (keyword_ "then" *> scalarExpr'))
|
||||
|
||||
> binOpSymbolNames :: [String]
|
||||
> binOpSymbolNames = ["=", "<=", ">="
|
||||
> ,"!=", "<>", "<", ">"
|
||||
> ,"*", "/", "+", "-"
|
||||
> ,"||"]
|
||||
|
||||
> binOpKeywordNames :: [String]
|
||||
> binOpKeywordNames = ["and", "or", "like"]
|
||||
|
||||
> unaryOp :: P ScalarExpr
|
||||
> unaryOp = makeOp <$> (try (keyword_ "not") *> scalarExpr)
|
||||
> where makeOp e = Op "not" [e]
|
||||
|
||||
> scalarExpr' :: P ScalarExpr
|
||||
> scalarExpr' = factor >>= trysuffix
|
||||
> where
|
||||
> factor = choice [literal
|
||||
> ,scase
|
||||
> ,unaryOp
|
||||
> ,try app
|
||||
> ,try dottedIdentifier
|
||||
> ,identifier
|
||||
> ,sparens]
|
||||
> trysuffix e = try (suffix e) <|> return e
|
||||
> suffix e0 = (makeOp e0 <$> opSymbol <*> factor) >>= trysuffix
|
||||
> opSymbol = choice (map (try . symbol) binOpSymbolNames
|
||||
> ++ map (try . keyword) binOpKeywordNames)
|
||||
> makeOp e0 op e1 = Op op [e0,e1]
|
||||
|
||||
> sparens :: P ScalarExpr
|
||||
> sparens = Parens <$> parens scalarExpr'
|
||||
|
||||
> toHaskell :: ScalarExpr -> HSE.Exp
|
||||
> toHaskell e = case e of
|
||||
> 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.Ident 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 "*")) -> 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.Var (HSE.UnQual (HSE.Ident i)) -> Identifier i
|
||||
> HSE.Lit (HSE.String l) -> Literal l
|
||||
> 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.Ident n))) e1 ->
|
||||
> Op n [toSql e0, toSql e1]
|
||||
> HSE.Paren e0 -> Parens $ toSql e0
|
||||
> _ -> error $ "unsupported haskell " ++ groom e
|
||||
> where
|
||||
> ltom (HSE.List []) = Nothing
|
||||
> ltom (HSE.List [ex]) = Just $ toSql ex
|
||||
> ltom ex = error $ "unsupported haskell " ++ groom ex
|
||||
> pairs (HSE.List l) = map (\(HSE.List [a,b]) -> (toSql a, toSql b)) l
|
||||
> pairs ex = error $ "unsupported haskell " ++ groom ex
|
||||
|
||||
> 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"]
|
||||
|
||||
> fixFixity :: ScalarExpr -> ScalarExpr
|
||||
> fixFixity se = runIdentity $
|
||||
> toSql <$> HSE.applyFixities sqlFixities (toHaskell se)
|
||||
|
||||
> scalarExpr :: P ScalarExpr
|
||||
> scalarExpr =
|
||||
> choice [try star
|
||||
> ,fixFixity <$> scalarExpr']
|
||||
|
||||
-------------------------------------------------
|
||||
|
||||
= query expressions
|
||||
|
||||
> selectItem :: P (Maybe String, ScalarExpr)
|
||||
> selectItem = flip (,) <$> scalarExpr <*> optionMaybe (try alias)
|
||||
> where alias = optional (try (keyword_ "as")) *> identifierString
|
||||
|
||||
> selectList :: P [(Maybe String,ScalarExpr)]
|
||||
> selectList = try (keyword_ "select") *> commaSep1 selectItem
|
||||
|
||||
> from :: P [TableRef]
|
||||
> from = option [] (try (keyword_ "from") *> commaSep1 tref)
|
||||
> where
|
||||
> tref = choice [try (JoinQueryExpr <$> parens queryExpr)
|
||||
> ,JoinParens <$> parens tref
|
||||
> ,SimpleTableRef <$> identifierString]
|
||||
> >>= optionSuffix pjoin
|
||||
> >>= optionSuffix alias
|
||||
> pjoin tref0 =
|
||||
> choice
|
||||
> [try (keyword_ "natural") *> keyword_ "inner"
|
||||
> *> conditionlessSuffix tref0 Inner (Just JoinNatural)
|
||||
> ,try (keyword_ "join")
|
||||
> *> (JoinTableRef Inner tref0 <$> tref <*> joinExpr)
|
||||
> ,try (keyword_ "inner")
|
||||
> *> conditionSuffix tref0 Inner
|
||||
> ,try (choice [JLeft <$ keyword_ "left"
|
||||
> ,JRight <$ keyword_ "right"
|
||||
> ,Full <$ keyword_ "full"])
|
||||
> >>= outerJoinSuffix tref0
|
||||
> ,try (keyword_ "cross")
|
||||
> *> conditionlessSuffix tref0 Cross Nothing
|
||||
> ]
|
||||
> >>= optionSuffix pjoin
|
||||
> outerJoinSuffix tref0 jt =
|
||||
> optional (keyword_ "outer") *> conditionSuffix tref0 jt
|
||||
> conditionSuffix tref0 jt =
|
||||
> keyword_ "join" *> (JoinTableRef jt tref0 <$> tref <*> joinExpr)
|
||||
> conditionlessSuffix tref0 jt jc =
|
||||
> keyword_ "join" *> (JoinTableRef jt tref0 <$> tref <*> return jc)
|
||||
> joinExpr = choice
|
||||
> [(Just . JoinUsing)
|
||||
> <$> (try (keyword_ "using")
|
||||
> *> parens (commaSep1 identifierString))
|
||||
> ,(Just . JoinOn) <$> (try (keyword_ "on") *> scalarExpr)
|
||||
> ,return Nothing
|
||||
> ]
|
||||
> alias j = let a1 = optional (try (keyword_ "as")) *> identifierString
|
||||
> in option j (JoinAlias j <$> try a1)
|
||||
|
||||
> swhere :: P (Maybe ScalarExpr)
|
||||
> swhere = optionMaybe (try (keyword_ "where") *> scalarExpr)
|
||||
|
||||
> sgroupBy :: P [ScalarExpr]
|
||||
> sgroupBy = option [] (try (keyword_ "group")
|
||||
> *> keyword_ "by"
|
||||
> *> commaSep1 scalarExpr)
|
||||
|
||||
> having :: P (Maybe ScalarExpr)
|
||||
> having = optionMaybe (try (keyword_ "having") *> scalarExpr)
|
||||
|
||||
> orderBy :: P [ScalarExpr]
|
||||
> orderBy = option [] (try (keyword_ "order")
|
||||
> *> keyword_ "by"
|
||||
> *> commaSep1 scalarExpr)
|
||||
|
||||
> queryExpr :: P QueryExpr
|
||||
> queryExpr =
|
||||
> Select
|
||||
> <$> selectList
|
||||
> <*> from
|
||||
> <*> swhere
|
||||
> <*> sgroupBy
|
||||
> <*> having
|
||||
> <*> orderBy
|
||||
|
||||
|
||||
------------------------------------------------
|
||||
|
||||
= helper functions
|
||||
|
||||
> whiteSpace :: P ()
|
||||
> whiteSpace =
|
||||
> choice [simpleWhiteSpace *> whiteSpace
|
||||
> ,lineComment *> whiteSpace
|
||||
> ,blockComment *> whiteSpace
|
||||
> ,return ()]
|
||||
> where
|
||||
> lineComment = try (string "--")
|
||||
> *> manyTill anyChar (void (char '\n') <|> eof)
|
||||
> blockComment = -- no nesting of block comments in SQL
|
||||
> try (string "/*")
|
||||
> -- TODO: why is try used herex
|
||||
> *> manyTill anyChar (try $ string "*/")
|
||||
> -- use many1 so we can more easily avoid non terminating loops
|
||||
> simpleWhiteSpace = void $ many1 (oneOf " \t\n")
|
||||
|
||||
> optionSuffix :: (a -> P a) -> a -> P a
|
||||
> optionSuffix p a = option a (p a)
|
||||
|
||||
> parens :: P a -> P a
|
||||
> parens = between (symbol_ "(") (symbol_ ")")
|
||||
|
||||
> commaSep :: P a -> P [a]
|
||||
> commaSep = (`sepBy` symbol_ ",")
|
||||
|
||||
|
||||
> symbol :: String -> P String
|
||||
> symbol s = string s
|
||||
> -- <* notFollowedBy (oneOf "+-/*<>=!|")
|
||||
> <* whiteSpace
|
||||
|
||||
> symbol_ :: String -> P ()
|
||||
> symbol_ s = symbol s *> return ()
|
||||
|
||||
> keyword :: String -> P String
|
||||
> keyword s = string s
|
||||
> <* notFollowedBy (char '_' <|> alphaNum)
|
||||
> <* whiteSpace
|
||||
|
||||
> keyword_ :: String -> P ()
|
||||
> keyword_ s = keyword s *> return ()
|
||||
|
||||
> commaSep1 :: P a -> P [a]
|
||||
> commaSep1 = (`sepBy1` symbol_ ",")
|
122
Language/SQL/SimpleSQL/Pretty.lhs
Normal file
122
Language/SQL/SimpleSQL/Pretty.lhs
Normal file
|
@ -0,0 +1,122 @@
|
|||
|
||||
This is the pretty printer code which takes AST values and turns them
|
||||
back into SQL source text. It attempts to format the output nicely.
|
||||
|
||||
> module Language.SQL.SimpleSQL.Pretty
|
||||
> (prettyQueryExpr
|
||||
> ,prettyScalarExpr
|
||||
> ) where
|
||||
|
||||
> import Language.SQL.SimpleSQL.Syntax
|
||||
> import Text.PrettyPrint
|
||||
> import Data.Maybe
|
||||
|
||||
> prettyQueryExpr :: QueryExpr -> String
|
||||
> prettyQueryExpr = render . queryExpr
|
||||
|
||||
> prettyScalarExpr :: ScalarExpr -> String
|
||||
> prettyScalarExpr = render . scalarExpr
|
||||
|
||||
|
||||
= scalar expressions
|
||||
|
||||
> scalarExpr :: ScalarExpr -> Doc
|
||||
> scalarExpr (Literal s) = quotes $ text s
|
||||
> scalarExpr (Identifier i) = text i
|
||||
> scalarExpr (Identifier2 q i) = text q <> text "." <> text i
|
||||
> scalarExpr Star = text "*"
|
||||
> scalarExpr (Star2 q) = text q <> text "." <> text "*"
|
||||
|
||||
> scalarExpr (App f es) = text f <> parens (commaSep (map scalarExpr es))
|
||||
> scalarExpr (Op f [e]) = text f <+> scalarExpr e
|
||||
> scalarExpr (Op f [e0,e1]) =
|
||||
> sep [scalarExpr e0, text f, scalarExpr e1]
|
||||
|
||||
> scalarExpr (Op f es) =
|
||||
> -- TODO: how to handle this? error or either seems poor
|
||||
> text f <> parens (commaSep (map scalarExpr es))
|
||||
|
||||
> scalarExpr (Case t ws els) =
|
||||
> sep [text "case" <+> (maybe empty scalarExpr t)
|
||||
> ,nest 4 (sep ((map w ws)
|
||||
> ++ maybeToList (fmap e els)))
|
||||
> ,text "end"]
|
||||
> where
|
||||
> w (t0,t1) = sep [text "when" <+> scalarExpr t0
|
||||
> ,text "then" <+> scalarExpr t1]
|
||||
> e el = text "else" <+> scalarExpr el
|
||||
> scalarExpr (Parens e) = parens $ scalarExpr e
|
||||
|
||||
= query expressions
|
||||
|
||||
> queryExpr :: QueryExpr -> Doc
|
||||
> queryExpr (Select sl fr wh gb hv od) =
|
||||
> sep [text "select"
|
||||
> ,nest 4 $ sep [selectList sl]
|
||||
> ,from fr
|
||||
> ,whr wh
|
||||
> ,grpBy gb
|
||||
> ,having hv
|
||||
> ,orderBy od]
|
||||
|
||||
> selectList :: [(Maybe String, ScalarExpr)] -> Doc
|
||||
> selectList is = commaSep $ map si is
|
||||
> where
|
||||
> si (al,e) = scalarExpr e <+> maybe empty alias al
|
||||
> alias al = text "as" <+> text al
|
||||
|
||||
> from :: [TableRef] -> Doc
|
||||
> from [] = empty
|
||||
> from ts =
|
||||
> sep [text "from"
|
||||
> ,nest 4 $ commaSep $ map tr ts]
|
||||
> where
|
||||
> tr (SimpleTableRef t) = text t
|
||||
> tr (JoinAlias t a) = tr t <+> text "as" <+> text a
|
||||
> tr (JoinParens t) = parens $ tr t
|
||||
> tr (JoinQueryExpr q) = parens $ queryExpr q
|
||||
> tr (JoinTableRef jt t0 t1 jc) =
|
||||
> sep [tr t0
|
||||
> ,joinText jt jc
|
||||
> ,tr t1
|
||||
> ,joinCond jc]
|
||||
> joinText jt jc =
|
||||
> sep [case jc of
|
||||
> Just JoinNatural -> text "natural"
|
||||
> _ -> empty
|
||||
> ,case jt of
|
||||
> Inner -> text "inner"
|
||||
> JLeft -> text "left"
|
||||
> JRight -> text "right"
|
||||
> Full -> text "full"
|
||||
> Cross -> text "cross"
|
||||
> ,text "join"]
|
||||
> joinCond (Just (JoinOn e)) = text "on" <+> scalarExpr e
|
||||
> joinCond (Just (JoinUsing es)) = text "using" <+> parens (commaSep $ map text es)
|
||||
> joinCond Nothing = empty
|
||||
> joinCond (Just JoinNatural) = empty
|
||||
|
||||
> whr :: Maybe ScalarExpr -> Doc
|
||||
> whr = maybe empty
|
||||
> (\w -> sep [text "where"
|
||||
> ,nest 4 $ scalarExpr w])
|
||||
|
||||
> grpBy :: [ScalarExpr] -> Doc
|
||||
> grpBy [] = empty
|
||||
> grpBy gs = sep [text "group by"
|
||||
> ,nest 4 $ commaSep $ map scalarExpr gs]
|
||||
|
||||
> having :: Maybe ScalarExpr -> Doc
|
||||
> having = maybe empty
|
||||
> (\w -> sep [text "having"
|
||||
> ,nest 4 $ scalarExpr w])
|
||||
> orderBy :: [ScalarExpr] -> Doc
|
||||
> orderBy [] = empty
|
||||
> orderBy os = sep [text "order by"
|
||||
> ,nest 4 $ commaSep $ map scalarExpr os]
|
||||
|
||||
|
||||
= utils
|
||||
|
||||
> commaSep :: [Doc] -> Doc
|
||||
> commaSep ds = sep $ punctuate comma ds
|
57
Language/SQL/SimpleSQL/Syntax.lhs
Normal file
57
Language/SQL/SimpleSQL/Syntax.lhs
Normal file
|
@ -0,0 +1,57 @@
|
|||
|
||||
> module Language.SQL.SimpleSQL.Syntax
|
||||
> (QueryExpr(..)
|
||||
> ,makeSelect
|
||||
> ,ScalarExpr(..)
|
||||
> ,TableRef(..)
|
||||
> ,JoinType(..)
|
||||
> ,JoinCondition(..)
|
||||
> ) where
|
||||
|
||||
|
||||
> data ScalarExpr = Literal String
|
||||
> | Identifier String
|
||||
> | Identifier2 String String
|
||||
> | Star
|
||||
> | Star2 String
|
||||
> | App String [ScalarExpr]
|
||||
> | Op String [ScalarExpr]
|
||||
> | Case (Maybe ScalarExpr) -- test value
|
||||
> [(ScalarExpr,ScalarExpr)] -- when branches
|
||||
> (Maybe ScalarExpr) -- else value
|
||||
> | Parens ScalarExpr
|
||||
> deriving (Eq,Show)
|
||||
|
||||
> data QueryExpr
|
||||
> = Select
|
||||
> {qeSelectList :: [(Maybe String,ScalarExpr)]
|
||||
> ,qeFrom :: [TableRef]
|
||||
> ,qeWhere :: Maybe ScalarExpr
|
||||
> ,qeGroupBy :: [ScalarExpr]
|
||||
> ,qeHaving :: Maybe ScalarExpr
|
||||
> ,qeOrderBy :: [ScalarExpr]
|
||||
> } deriving (Eq,Show)
|
||||
|
||||
> makeSelect :: QueryExpr
|
||||
> makeSelect = Select {qeSelectList = []
|
||||
> ,qeFrom = []
|
||||
> ,qeWhere = Nothing
|
||||
> ,qeGroupBy = []
|
||||
> ,qeHaving = Nothing
|
||||
> ,qeOrderBy = []}
|
||||
|
||||
|
||||
> data TableRef = SimpleTableRef String
|
||||
> | JoinTableRef JoinType TableRef TableRef (Maybe JoinCondition)
|
||||
> | JoinParens TableRef
|
||||
> | JoinAlias TableRef String
|
||||
> | JoinQueryExpr QueryExpr
|
||||
> deriving (Eq,Show)
|
||||
|
||||
> data JoinType = Inner | JLeft | JRight | Full | Cross
|
||||
> deriving (Eq,Show)
|
||||
|
||||
> data JoinCondition = JoinOn ScalarExpr
|
||||
> | JoinUsing [String]
|
||||
> | JoinNatural
|
||||
> deriving (Eq,Show)
|
Loading…
Add table
Add a link
Reference in a new issue