diff --git a/Language/SQL/SimpleSQL/Fixity.lhs b/Language/SQL/SimpleSQL/Fixity.lhs deleted file mode 100644 --- a/Language/SQL/SimpleSQL/Fixity.lhs +++ /dev/null @@ -1,181 +0,0 @@ - -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 to use in places other than the scalar expr parser? - -> {-# LANGUAGE TupleSections #-} -> 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 Data.Maybe - -> 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. 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 $ sym $ name op) -> (toHaskell e1) -> Iden {} -> str ('v':show e) -> StringLit {} -> str ('v':show e) -> NumLit {} -> str ('v':show e) -> App n es -> HSE.App (var ('f':name n)) $ ltoh es -> Parens e0 -> HSE.Paren $ toHaskell e0 -> IntervalLit {} -> str ('v':show e) -> Star -> str ('v':show e) -> AggregateApp nm d es od -> -> HSE.App (var ('a':name nm)) -> $ HSE.List [str $ show (d,orderInf od) -> ,HSE.List $ map toHaskell es -> ,HSE.List $ orderExps od] -> WindowApp nm es pb od r -> -> HSE.App (var ('w':name nm)) -> $ HSE.List [str $ show (orderInf od, r) -> ,HSE.List $ map toHaskell es -> ,HSE.List $ map toHaskell pb -> ,HSE.List $ orderExps od] -> PrefixOp nm e0 -> -> HSE.App (HSE.Var $ sym $ name nm) (toHaskell e0) -> PostfixOp nm e0 -> -> HSE.App (HSE.Var $ sym ('p':name nm)) (toHaskell e0) -> SpecialOp nm es -> -> HSE.App (var ('s':name nm)) $ HSE.List $ map toHaskell es -> -- map the two maybes to lists with either 0 or 1 element -> Case v ts el -> HSE.App (var "$case") -> (HSE.List [ltoh $ maybeToList v -> ,HSE.List $ map (ltoh . (\(a,b) -> b:a)) ts -> ,ltoh $ maybeToList el]) -> Cast e0 tn -> HSE.App (str ('c':show tn)) $ toHaskell e0 -> TypedLit {} -> 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 -> name n = case n of -> QName q -> '"' : q -> Name m -> m -> orderExps = map (toHaskell . (\(OrderField a _ _) -> a)) -> orderInf = map (\(OrderField _ b c) -> (b,c)) - - - - -> toSql :: HSE.Exp -> ScalarExpr -> toSql e = case e of - - -> HSE.InfixApp e0 (HSE.QVarOp (HSE.UnQual (HSE.Symbol n))) e1 -> -> BinOp (toSql e0) (unname n) (toSql e1) -> HSE.Lit (HSE.String ('v':l)) -> read l -> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('f':i)))) -> (HSE.List es) -> App (unname 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.List es -> ,HSE.List od]) -> -> let (d,oinf) = read vs -> in AggregateApp (unname i) d (map toSql es) -> $ sord oinf od -> 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 (oinf,r) = read vs -> in WindowApp (unname i) (map toSql es) (map toSql pb) -> (sord oinf od) r -> HSE.App (HSE.Var (HSE.UnQual (HSE.Symbol ('p':nm)))) e0 -> -> PostfixOp (unname nm) $ toSql e0 -> HSE.App (HSE.Var (HSE.UnQual (HSE.Symbol nm))) e0 -> -> PrefixOp (unname nm) $ toSql e0 -> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident ('s':nm)))) (HSE.List es) -> -> SpecialOp (unname nm) $ map toSql es -> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident "$case"))) -> (HSE.List [v,ts,el]) -> -> Case (ltom v) (whens ts) (ltom el) -> HSE.App (HSE.Lit (HSE.String ('c':nm))) e0 -> -> Cast (toSql e0) (read nm) -> HSE.App (HSE.Lit (HSE.String ('i':nm))) -> (HSE.List [e0, HSE.List es]) -> -> In (read nm) (toSql e0) (InList $ map toSql es) -> HSE.App (HSE.Lit (HSE.String ('j':nm))) e0 -> -> let (b,sq) = read nm -> in In b (toSql e0) sq -> _ -> err e -> where -> sord = zipWith (\(i0,i1) ce -> OrderField (toSql ce) i0 i1) -> ltom (HSE.List []) = Nothing -> ltom (HSE.List [ex]) = Just $ toSql ex -> ltom ex = err ex -> whens (HSE.List l) = map (\(HSE.List (t:ws)) -> (map toSql ws, toSql t)) l -> whens ex = err ex -> err :: Show a => a -> e -> err a = error $ "simple-sql-parser: internal fixity error " ++ show a -> unname ('"':nm) = QName nm -> unname n = Name n diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/Language/SQL/SimpleSQL/Parser.lhs @@ -1,21 +1,28 @@ +> {-# LANGUAGE TupleSections #-} > -- | This is the module with the parser functions. > module Language.SQL.SimpleSQL.Parser > (parseQueryExpr -> ,parseScalarExpr +> ,parseValueExpr > ,parseQueryExprs > ,ParseError(..)) where -> import Control.Monad.Identity -> import Control.Applicative hiding (many, (<|>), optional) -> import Data.Maybe -> import Data.Char -> import Text.Parsec hiding (ParseError) -> import qualified Text.Parsec as P -> import Text.Parsec.Perm +> import Control.Monad.Identity (Identity) +> import Control.Monad (guard, void) +> import Control.Applicative ((<$), (<$>), (<*>) ,(<*), (*>)) +> import Data.Maybe (fromMaybe,catMaybes) +> import Data.Char (toLower) +> import Text.Parsec (errorPos,sourceLine,sourceColumn,sourceName +> ,setPosition,setSourceColumn,setSourceLine,getPosition +> ,option,between,sepBy,sepBy1,string,manyTill,anyChar +> ,try,string,many1,oneOf,digit,(<|>),choice,char,eof +> ,optionMaybe,optional,many,letter,alphaNum,parse) +> import Text.Parsec.String (Parser) +> import qualified Text.Parsec as P (ParseError) +> import Text.Parsec.Perm (permute,(<$?>), (<|?>)) +> import qualified Text.Parsec.Expr as E > import Language.SQL.SimpleSQL.Syntax -> import Language.SQL.SimpleSQL.Fixity The public API functions. @@ -23,32 +30,35 @@ > parseQueryExpr :: FilePath > -- ^ filename to use in errors > -> Maybe (Int,Int) -> -- ^ line number and column number to use in errors +> -- ^ line number and column number of the first character +> -- in the source (to use in errors) > -> String > -- ^ the SQL source to parse > -> Either ParseError QueryExpr > parseQueryExpr = wrapParse topLevelQueryExpr -> -- | Parses a list of query exprs, with semi colons between +> -- | Parses a list of query expressions, with semi colons between > -- them. The final semicolon is optional. > parseQueryExprs :: FilePath > -- ^ filename to use in errors > -> Maybe (Int,Int) -> -- ^ line number and column number to use in errors +> -- ^ line number and column number of the first character +> -- in the source (to use in errors) > -> String > -- ^ the SQL source to parse > -> Either ParseError [QueryExpr] > parseQueryExprs = wrapParse queryExprs -> -- | Parses a scalar expression. -> parseScalarExpr :: FilePath +> -- | Parses a value expression. +> parseValueExpr :: FilePath > -- ^ filename to use in errors > -> Maybe (Int,Int) -> -- ^ line number and column number to use in errors +> -- ^ line number and column number of the first character +> -- in the source (to use in errors) > -> String > -- ^ the SQL source to parse -> -> Either ParseError ScalarExpr -> parseScalarExpr = wrapParse scalarExpr +> -> Either ParseError ValueExpr +> parseValueExpr = wrapParse valueExpr This helper function takes the parser given and: @@ -57,7 +67,7 @@ checks the parser parses all the input using eof converts the error return to the nice wrapper -> wrapParse :: P a +> wrapParse :: Parser a > -> FilePath > -> Maybe (Int,Int) > -> String @@ -81,18 +91,16 @@ ------------------------------------------------ -> type P a = ParsecT String () Identity a - -= scalar expressions += value expressions == literals See the stringLiteral lexer below for notes on string literal syntax. -> estring :: P ScalarExpr +> estring :: Parser ValueExpr > estring = StringLit <$> stringLiteral -> number :: P ScalarExpr +> number :: Parser ValueExpr > number = NumLit <$> numberLiteral parse SQL interval literals, something like @@ -104,14 +112,14 @@ interval '3 days' which parses as a typed literal -> interval :: P ScalarExpr +> interval :: Parser ValueExpr > interval = try (keyword_ "interval" >> > IntervalLit > <$> stringLiteral > <*> identifierString > <*> optionMaybe (try $ parens integerLiteral)) -> literal :: P ScalarExpr +> literal :: Parser ValueExpr > literal = number <|> estring <|> interval == identifiers @@ -119,11 +127,11 @@ Uses the identifierString 'lexer'. See this function for notes on identifiers. -> name :: P Name +> name :: Parser Name > name = choice [QName <$> quotedIdentifier > ,Name <$> identifierString] -> identifier :: P ScalarExpr +> identifier :: Parser ValueExpr > identifier = Iden <$> name == star @@ -131,33 +139,40 @@ used in select *, select x.*, and agg(*) variations, and some other places as well. Because it is quite general, the parser doesn't attempt to check that the star is in a valid context, it parses it OK -in any scalar expression context. +in any value expression context. -> star :: P ScalarExpr +> star :: Parser ValueExpr > star = Star <$ symbol "*" +== parameter + +use in e.g. select * from t where a = ? + +> parameter :: Parser ValueExpr +> parameter = Parameter <$ symbol "?" + == function application, aggregates and windows this represents anything which syntactically looks like regular C -function application: an identifier, parens with comma sep scalar +function application: an identifier, parens with comma sep value expression arguments. The parsing for the aggregate extensions is here as well: aggregate([all|distinct] args [order by orderitems]) -> aggOrApp :: P ScalarExpr +> aggOrApp :: Parser ValueExpr > aggOrApp = > makeApp > <$> name > <*> parens ((,,) <$> try duplicates -> <*> choice [commaSep scalarExpr'] +> <*> choice [commaSep valueExpr] > <*> try (optionMaybe orderBy)) > where > makeApp i (Nothing,es,Nothing) = App i es > makeApp i (d,es,od) = AggregateApp i d es (fromMaybe [] od) -> duplicates :: P (Maybe Duplicates) +> duplicates :: Parser (Maybe SetQuantifier) > duplicates = optionMaybe $ try $ > choice [All <$ keyword_ "all" > ,Distinct <$ keyword "distinct"] @@ -172,7 +187,7 @@ parser names means that they have been left factored. These are almost always used with the optionSuffix combinator. -> windowSuffix :: ScalarExpr -> P ScalarExpr +> windowSuffix :: ValueExpr -> Parser ValueExpr > windowSuffix (App f es) = > try (keyword_ "over") > *> parens (WindowApp f es @@ -181,7 +196,7 @@ > <*> optionMaybe frameClause) > where > partitionBy = try (keyword_ "partition") >> -> keyword_ "by" >> commaSep1 scalarExpr' +> keyword_ "by" >> commaSep1 valueExpr > frameClause = > mkFrame <$> choice [FrameRows <$ keyword_ "rows" > ,FrameRange <$ keyword_ "range"] @@ -200,7 +215,7 @@ > choice [UnboundedPreceding <$ keyword_ "preceding" > ,UnboundedFollowing <$ keyword_ "following"] > ,do -> e <- if useB then scalarExprB else scalarExpr +> e <- if useB then valueExprB else valueExpr > choice [Preceding e <$ keyword_ "preceding" > ,Following e <$ keyword_ "following"] > ] @@ -209,21 +224,21 @@ > mkFrame rs c = c rs > windowSuffix _ = fail "" -> app :: P ScalarExpr +> app :: Parser ValueExpr > app = aggOrApp >>= optionSuffix windowSuffix == case expression -> scase :: P ScalarExpr +> scase :: Parser ValueExpr > scase = -> Case <$> (try (keyword_ "case") *> optionMaybe (try scalarExpr')) +> Case <$> (try (keyword_ "case") *> optionMaybe (try valueExpr)) > <*> many1 swhen -> <*> optionMaybe (try (keyword_ "else") *> scalarExpr') +> <*> optionMaybe (try (keyword_ "else") *> valueExpr) > <* keyword_ "end" > where > swhen = keyword_ "when" *> -> ((,) <$> commaSep1 scalarExpr' -> <*> (keyword_ "then" *> scalarExpr')) +> ((,) <$> commaSep1 valueExpr +> <*> (keyword_ "then" *> valueExpr)) == miscellaneous keyword operators @@ -234,50 +249,141 @@ cast: cast(expr as type) -> cast :: P ScalarExpr +> cast :: Parser ValueExpr > cast = parensCast <|> prefixCast > where > parensCast = try (keyword_ "cast") >> -> parens (Cast <$> scalarExpr' +> parens (Cast <$> valueExpr > <*> (keyword_ "as" *> typeName)) > prefixCast = try (TypedLit <$> typeName > <*> stringLiteral) -extract(id from expr) +the special op keywords +parse an operator which is +operatorname(firstArg keyword0 arg0 keyword1 arg1 etc.) -> extract :: P ScalarExpr -> extract = try (keyword_ "extract") >> -> parens (makeOp <$> name -> <*> (keyword_ "from" *> scalarExpr')) -> where makeOp n e = SpecialOp (Name "extract") [Iden n, e] +> data SpecialOpKFirstArg = SOKNone +> | SOKOptional +> | SOKMandatory -substring(x from expr to expr) +> specialOpK :: String -- name of the operator +> -> SpecialOpKFirstArg -- has a first arg without a keyword +> -> [(String,Bool)] -- the other args with their keywords +> -- and whether they are optional +> -> Parser ValueExpr +> specialOpK opName firstArg kws = +> keyword_ opName >> do +> void $ symbol "(" +> let pfa = do +> e <- valueExpr +> -- check we haven't parsed the first +> -- keyword as an identifier +> guard (case (e,kws) of +> (Iden (Name i), (k,_):_) | map toLower i == k -> False +> _ -> True) +> return e +> fa <- case firstArg of +> SOKNone -> return Nothing +> SOKOptional -> optionMaybe (try pfa) +> SOKMandatory -> Just <$> pfa +> as <- mapM parseArg kws +> void $ symbol ")" +> return $ SpecialOpK (Name opName) fa $ catMaybes as +> where +> parseArg (nm,mand) = +> let p = keyword_ nm >> valueExpr +> in fmap (nm,) <$> if mand +> then Just <$> p +> else optionMaybe (try p) -todo: also support substring(x from expr) +The actual operators: -> substring :: P ScalarExpr -> substring = try (keyword_ "substring") >> -> parens (makeOp <$> scalarExpr' -> <*> (keyword_ "from" *> scalarExpr') -> <*> (keyword_ "for" *> scalarExpr') -> ) -> where makeOp a b c = SpecialOp (Name "substring") [a,b,c] +EXTRACT( date_part FROM expression ) +POSITION( string1 IN string2 ) + +SUBSTRING(extraction_string FROM starting_position [FOR length] +[COLLATE collation_name]) + +CONVERT(char_value USING conversion_char_name) + +TRANSLATE(char_value USING translation_name) + +OVERLAY(string PLACING embedded_string FROM start +[FOR length]) + +TRIM( [ [{LEADING | TRAILING | BOTH}] [removal_char] FROM ] +target_string +[COLLATE collation_name] ) + +> specialOpKs :: Parser ValueExpr +> specialOpKs = choice $ map try +> [extract, position, substring, convert, translate, overlay, trim] + +> extract :: Parser ValueExpr +> extract = specialOpK "extract" SOKMandatory [("from", True)] + +> position :: Parser ValueExpr +> position = specialOpK "position" SOKMandatory [("in", True)] + +strictly speaking, the substring must have at least one of from and +for, but the parser doens't enforce this + +> substring :: Parser ValueExpr +> substring = specialOpK "substring" SOKMandatory +> [("from", False),("for", False),("collate", False)] + +> convert :: Parser ValueExpr +> convert = specialOpK "convert" SOKMandatory [("using", True)] + + +> translate :: Parser ValueExpr +> translate = specialOpK "translate" SOKMandatory [("using", True)] + +> overlay :: Parser ValueExpr +> overlay = specialOpK "overlay" SOKMandatory +> [("placing", True),("from", True),("for", False)] + +trim is too different because of the optional char, so a custom parser +the both ' ' is filled in as the default if either parts are missing +in the source + +> trim :: Parser ValueExpr +> trim = +> keyword "trim" >> +> parens (mkTrim +> <$> option "both" sides +> <*> option " " stringLiteral +> <*> (keyword_ "from" *> valueExpr) +> <*> optionMaybe (keyword_ "collate" *> stringLiteral)) +> where +> sides = choice ["leading" <$ keyword_ "leading" +> ,"trailing" <$ keyword_ "trailing" +> ,"both" <$ keyword_ "both"] +> mkTrim fa ch fr cl = +> SpecialOpK (Name "trim") Nothing +> $ catMaybes [Just (fa,StringLit ch) +> ,Just ("from", fr) +> ,fmap (("collate",) . StringLit) cl] + in: two variations: a in (expr0, expr1, ...) a in (queryexpr) -> inSuffix :: ScalarExpr -> P ScalarExpr -> inSuffix e = -> In <$> inty -> <*> return e -> <*> parens (choice -> [InQueryExpr <$> queryExpr -> ,InList <$> commaSep1 scalarExpr']) +this is parsed as a postfix operator which is why it is in this form + +> inSuffix :: Parser (ValueExpr -> ValueExpr) +> inSuffix = +> mkIn <$> inty +> <*> parens (choice +> [InQueryExpr <$> queryExpr +> ,InList <$> commaSep1 valueExpr]) > where > inty = try $ choice [True <$ keyword_ "in" > ,False <$ keyword_ "not" <* keyword_ "in"] +> mkIn i v = \e -> In i e v + between: expr between expr and expr @@ -287,26 +393,25 @@ postgres does, which might be standard across SQL implementations, which is that you can't have a binary and operator in the middle expression in a between unless it is wrapped in parens. The 'bExpr -parsing' is used to create alternative scalar expression parser which +parsing' is used to create alternative value expression parser which is identical to the normal one expect it doesn't recognise the binary -and operator. This is the call to scalarExpr'' True. +and operator. This is the call to valueExprB. -> betweenSuffix :: ScalarExpr -> P ScalarExpr -> betweenSuffix e = +> betweenSuffix :: Parser (ValueExpr -> ValueExpr) +> betweenSuffix = > makeOp <$> (Name <$> opName) -> <*> return e -> <*> scalarExpr'' True -> <*> (keyword_ "and" *> scalarExpr'' True) +> <*> valueExprB +> <*> (keyword_ "and" *> valueExprB) > where > opName = try $ choice > ["between" <$ keyword_ "between" > ,"not between" <$ keyword_ "not" <* keyword_ "between"] -> makeOp n a b c = SpecialOp n [a,b,c] +> makeOp n b c = \a -> SpecialOp n [a,b,c] subquery expression: [exists|all|any|some] (queryexpr) -> subquery :: P ScalarExpr +> subquery :: Parser ValueExpr > subquery = > choice > [try $ SubQueryExpr SqSq <$> parens queryExpr @@ -321,25 +426,47 @@ typename: used in casts. Special cases for the multi keyword typenames that SQL supports. -> typeName :: P TypeName -> typeName = choice -> [TypeName "double precision" -> <$ try (keyword_ "double" <* keyword_ "precision") -> ,TypeName "character varying" -> <$ try (keyword_ "character" <* keyword_ "varying") -> ,TypeName <$> identifierString] >>= optionSuffix precision +> typeName :: Parser TypeName +> typeName = choice (multiWordParsers +> ++ [TypeName <$> identifierString]) +> >>= optionSuffix precision > where +> multiWordParsers = +> flip map multiWordTypeNames +> $ \ks -> (TypeName . unwords) <$> try (mapM keyword ks) +> multiWordTypeNames = map words +> ["double precision" +> ,"character varying" +> ,"char varying" +> ,"character large object" +> ,"char large object" +> ,"national character" +> ,"national char" +> ,"national character varying" +> ,"national char varying" +> ,"national character large object" +> ,"nchar large object" +> ,"nchar varying" +> ,"bit varying" +> ] + +todo: timestamp types: + + | TIME [