diff --git a/src/Database/TypedQuery/SQL.hs b/src/Database/TypedQuery/SQL.hs --- a/src/Database/TypedQuery/SQL.hs +++ b/src/Database/TypedQuery/SQL.hs @@ -8,7 +8,24 @@ sql :: TokenParser st sql = makeTokenParser sqlDef +-- { stringLiteral = stringLiteral +-- } +-- where +-- stringChar = do{ c <- stringLetter; return (Just c) } +-- <|> stringEscape +-- "string character" +-- +-- stringLiteral = lexeme ( +-- do{ str <- between (char '\'') +-- (char '\'' "end of string") +-- (many stringChar) +-- ; return (foldr (maybe id (:)) "" str) +-- } +-- "literal string") +-- stringLetter = satisfy (/= '\'') +-- stringEscape = char '\\' >> char '\'' >> return (Just '\'') + sqlExpr :: TokenParser st sqlExpr = makeTokenParser sqlDefExpr @@ -24,7 +41,7 @@ , identStart = letter , identLetter = alphaNum <|> oneOf "_.[]" , opStart = opLetter sqlStyle - , opLetter = oneOf "$%&*+./<=>?@\\^|-~()" + , opLetter = oneOf "$%&*+./<=>?@\\^|#-~():!" , reservedOpNames= [] , reservedNames = [] , caseSensitive = False @@ -53,10 +70,10 @@ sqlDef :: LanguageDef st sqlDef = sqlStyle - { reservedOpNames= ["=","\\","|","<",">","+","-","*","@",">=","<="] + { reservedOpNames= ["=", "\\", "||", "|", "<", ">", "+", "--", "->>", "#>>", "->", "#>", "-", "*", "@", ">=", "<=", "::"] , reservedNames = ["AS", "LEFT", "FROM", "SELECT", "INSERT", "DISTINCT", "UNIQUE" , "CONCAT", "CONCAT_WS", "NOW", "COUNT", "CASE", "WHEN", "THEN", "IF", "ELSE", "NULL" , "CONVERT_TZ","GROUP_CONCAT", "SUM", "JOIN", "END", "DATE", "TIME_TO_SEC", "TIMEDIFF" , "AVG", "MIN", "MAX", "GROUP", "BY", "LIMIT", "ORDER" - , "IFNULL", "IN"] - } + , "IFNULL", "IN"] -- , "JSON_EXTRACT_PATH" + } diff --git a/src/Database/TypedQuery/SQLParser.hs b/src/Database/TypedQuery/SQLParser.hs --- a/src/Database/TypedQuery/SQLParser.hs +++ b/src/Database/TypedQuery/SQLParser.hs @@ -13,9 +13,10 @@ import Data.Typeable (Typeable) import Text.Parsec hiding ((<|>)) +import Text.Parsec.Token import Text.Parsec.Language +import Text.Parsec.Char import Database.TypedQuery.SQL -import Text.Parsec.Token import Control.Applicative hiding (many, optional) --import Control.Arrow (first) @@ -78,6 +79,7 @@ , inTypeW :: [TypeAction] -- ^ stores '?' types , inTypeV :: [TypeAction] +-- ^ stores output } deriving (Show) instance TH.Lift TypeAction where lift = TH.lift @@ -85,8 +87,8 @@ toValu :: TypeAction -> Maybe String -toValu TAInsQM = Just "?" -toValu (TAInsIS _) = Just "?" +toValu TAInsQM = Just "?" +toValu (TAInsIS _) = Just "?" toValu (TAInsLit s) = Just s toValu _ = Nothing @@ -101,12 +103,12 @@ fromSQLWriter :: SQLWriter -> (String, [Text], [TypeAction], [TypeAction], [TypeAction]) -fromSQLWriter (SQLWriter a b c d zz) = (a ++ addValues((catMaybes $ map toValu zz) ), map T.pack b, c, d, filter filTAInsLit zz) +fromSQLWriter (SQLWriter a b c d zz) = (a ++ addValues (mapMaybe toValu zz), map T.pack b, c, d, filter filTAInsLit zz) type WParser a = ParsecT String SQLWriter Identity a addW :: SQLWriter -> WParser () -addW a = updateState $ (`mappend` a) +addW a = updateState (`mappend` a) addU, addIU, addJU :: WParser () addU = addW $ mempty { typeW = [TAUnknown] } @@ -115,11 +117,11 @@ addKU, addKQM, addKQMU :: WParser () addKU = addW $ mempty { inTypeV = [TAInsNop] } -addKQM = addW $ mempty { inTypeV = [TAInsQM] } -addKQMU = addW $ mempty { inTypeV = [TAInsQMU] } +addKQM = addW $ mempty { inTypeV = [TAInsQM] } +addKQMU = addW $ mempty { inTypeV = [TAInsQMU] } addKLit, addKIS, addKISU :: String -> WParser () -addKLit s = addW $ mempty { inTypeV = [TAInsLit s] } +addKLit s = addW $ mempty { inTypeV = [TAInsLit s] } addKIS s = addW $ mempty { inTypeV = [TAInsIS s] } addKISU s = addW $ mempty { inTypeV = [TAInsISU s] } @@ -128,12 +130,14 @@ -- addQ1c1 s = addW $ mempty { queryW = ' ':s:" " } -addQ, addQQ, addQ1, addQR, addQN, addT, addC, addIT, addIC, addJT, addJC :: String -> WParser () -addQ s = addW $ mempty { queryW = (' ':s) } +addQ, addN, addQQ, addQ1, addQR, addQN, addT, addC, addIT, addIC, addJT, addJC :: String -> WParser () +addQ s = addW $ mempty { queryW = ' ':s } +addN s = addW $ mempty { nameW = [s] } +addQN s = addW $ mempty { queryW = ' ':s , nameW = [s] } + addQ1 s = addW $ mempty { queryW = s } addQR s = addW $ mempty { queryW = ' ':s++" " } addQQ s = addW $ mempty { queryW = " \""++s++"\" " } -addQN s = addW $ mempty { queryW = (' ':s) , nameW = [s] } addT s = addW $ mempty { typeW = [TACast s] } addC s = addW $ mempty { typeW = [TAConv s] } addIT s = addW $ mempty { inTypeW = [TACast s] } @@ -152,23 +156,23 @@ typedSQLtoSQL :: String -> Maybe (String, [Text], [TypeAction], [TypeAction], [TypeAction]) -- ^ takes some annotates string and gives its parsed representation -typedSQLtoSQL a = do +typedSQLtoSQL a = case runParser (mksql >> getState) mempty "nope" a of Right r -> let rr = fromSQLWriter r in #if DEVELOPMENT - unsafePerformIO $ do + unsafePerformIO $ do putStrLn $ (\(a1,_,_,_,_) -> '\n':a1) rr - pprint $ r + pprint r liftIO $ return $ Just rr #else - Just rr + Just rr #endif Left l -> error $ show l -- * mksql :: WParser () -mksql = (try parseSelect) <|> (try parseInsert) <|> (do optional (try typeParams);addQ =<< getInput) +mksql = try parseSelect <|> try parseInsert <|> (do optional (try typeParams);addQ =<< getInput) -- eol :: WParser () -- * @@ -185,7 +189,7 @@ -- * stringSQL :: String -> WParser String -stringSQL cs = lexeme sql (((mapM_ caseChar cs) >> return cs) cs) +stringSQL cs = lexeme sql ((mapM_ caseChar cs >> return cs) cs) -- * wsKill :: WParser a -> WParser a @@ -201,7 +205,7 @@ -- * rawHaskellT :: WParser String -rawHaskellT = wsKill $ manyTill anyChar (eol <|> (void $ lookAhead $ try $ string "-- <")) +rawHaskellT = wsKill $ manyTill anyChar (eol <|> void (lookAhead $ try $ string "-- <")) -- * stringLiteralQ :: WParser String @@ -209,10 +213,46 @@ lit <- stringLiteral haskell return $ show lit +stringLiteralSQL = lexeme sql ( + do{ str <- between (char '\'') + (char '\'' "end of string") + (many stringChar) + ; return (foldr (maybe id (:)) "" str) + } + "literal string") + +stringChar = do{ c <- stringLetter; return (Just c) } + <|> stringEscape + "string character" +stringLetter = satisfy (/= '\'') +stringEscape = string "\\'" *> return (Just '\'') + identifier1,identifier2 :: WParser String -identifier1 = try (stringLiteralQ ) <|> try(greservedQ "NULL") <|> try (show <$> (lexeme sql $ integer sql)) <|> try (lexeme sql $ identifier sqlExpr) -- <|> ( manyTill anyChar (lexeme haskell $ lookAhead $ try $ reserved sql "as")) -identifier2 = try (stringLiteral sql ) <|> try (lexeme sql $ identifier sqlExpr) -- <|> expandQ (reservedNames sqlDef) +identifier1 = try stringLiteralQ + <|> try(greservedQ "NULL") + <|> try (show <$> lexeme sql (integer sql)) + <|> lexeme sql (identifier sqlExpr) -- <|> ( manyTill anyChar (lexeme haskell $ lookAhead $ try $ reserved sql "as")) +singleQ :: WParser () +singleQ = void $ char '\'' + + +showSQ :: String -> String +showSQ = DL.intercalate "\\''" . go + where + go :: String -> [String] + go "" = [] + go s = cons (case DL.break (== '\'') s of + (l, s') -> (l, case s' of + [] -> [] + _:s'' -> go s'')) + cons ~(h, t) = h : t + +identifier2 = try (quoteS . showSQ <$> stringLiteralSQL) +-- <|> try (lexeme sql $ identifier sqlExpr) + <|> identifier1 + -- <|> expandQ (reservedNames sqlDef) + -- * arithm :: WParser String arithm = do @@ -235,20 +275,21 @@ -- * greserved :: String -> WParser () -greserved s = (lexeme sql $ reserved sql s) *> addQ s +greserved s = lexeme sql (reserved sql s) *> addQ s greservedQ :: String -> WParser String -greservedQ s = (lexeme sql $ reserved sql s) >> return s +greservedQ s = lexeme sql (reserved sql s) >> return s -- * expand :: [String] -> WParser () -expand (a:as) = try (greserved a) <|> (expand as) -expand [] = empty +expand = foldr ( (<|>) . try . greserved ) empty +-- expand [] = empty -- * expandQ :: [String] -> WParser String -expandQ (a:as) = try (greservedQ a) <|> (expandQ as) -expandQ [] = fail "not a reserved" +expandQ = foldr ( (<|>) . try . greservedQ ) (fail "not a reserved") +-- try (greservedQ a) <|> expandQ as +-- expandQ [] = fail "not a reserved" -- * typeParams :: WParser () @@ -256,7 +297,7 @@ try typeParamsSimple <|> try typeParamsIn <|> expand (reservedNames sqlDef) - <|> try (addQ =<< (lexeme sql $ identifier sql)) + <|> try (addQ =<< lexeme sql (identifier sql)) <|> try (addQ . show =<< integer sql) <|> try (addQQ =<< stringLiteral sql) <|> (addQ1c =<< anyChar) @@ -314,39 +355,135 @@ addQ1 "\n " ) <|> (addIU >> addKQMU) +-- numericValueExpression :: WParser String +-- numericValueExpression = do -selectExpr :: WParser () -selectExpr = do - optional $ (try $ do - computable - greserved "AS" - ) - addQN =<< identifier2 - try ( +ls = lexeme sql + +functionExpr :: WParser String +functionExpr = do + fn <- lexeme sql identifierExpr + body <- parens sql (commaSep sql commonValueExpression ) + return $ unwords ((fn ++ "(") : DL.intersperse ", " body) ++ ")" + +identifierExpr :: WParser String +identifierExpr = lexeme sql identifier2 + +-- todo: fix +commonValueExpression :: WParser String +commonValueExpression = do + idt1 <- try ((++) <$> lexeme sql prefOps + <*> ((:) ' ' <$> commonValueExpression)) + <|> try (braketS <$> parens sql commonValueExpression) + <|> try functionExpr + <|> identifierExpr + + maybe idt1 ((idt1 ++ " ") ++) <$> optionMaybe ( + (++) <$> lexeme sql joinOps + <*> ((:) ' ' <$> commonValueExpression) + ) + + +prefOps = ts "||/" + <|> ts "|/" + <|> ts "!!" + <|> ts "@" + <|> string "~" + where + ts = try . symbol sql + + +joinOps = do + notFollowedBy (symbol sql "--") + ts "::" + <|> ts "||" + <|> ts "->>" + <|> ts "#>>" + <|> ts "#>" + <|> ts "->" + <|> ts "+" + <|> ts "-" + <|> ts "*" + <|> ts "/" + <|> ts "%" + <|> ts "^" + <|> ts "|" + <|> ts "&" + <|> ts "#" + <|> ts "<<" + <|> string ">>" + where + ts = try . symbol sql + +valueExpression :: WParser () +valueExpression = do + qve <- commonValueExpression +-- whiteSpace sql +-- addQ "\n--VE\n" + addQ qve + addN $ show qve + +valueExpressionWithAsClause :: WParser () +valueExpressionWithAsClause = do + addQ =<< commonValueExpression + addQ =<< greservedQ "AS" + addQN =<< identifierExpr + +valueType :: WParser () +valueType = try ( do void $ string "-- >" addC =<< rawHaskell addQ1 "\n " ) <|> try ( do - void $ string "--" + void $ string "-- " addT =<< rawHaskell addQ1 "\n " ) <|> addU - optional ((comma sql >>= addQ1) >> selectExpr) +-- ::= [ ] +derivedColumn :: WParser () +derivedColumn = do + try valueExpressionWithAsClause + <|> valueExpression + valueType + +{- + ::= + + | + | + + ::= + + | + | + | + | + | + | +-} + +selectList :: WParser () +selectList = do + derivedColumn + optional ((comma sql >>= addQ1) >> selectList) + -- TODO: check and simplify -- ****************************** + +setQuantifier :: WParser () +setQuantifier = try (greserved "DISTINCT") <|> try (greserved "UNIQUE") <|> greserved "ALL" + parseSelect :: WParser () parseSelect = do whiteSpace sql - -- void $ many (lexeme haskell (try eol)) greserved "SELECT" - optional $ try (greserved "DISTINCT") <|> try (greserved "UNIQUE") - selectExpr + optional setQuantifier + selectList optional $ try typeParams - --huntQM - --addQ =<< getInput + -- * optInputSource :: WParser () optInputSource = try ( do @@ -378,7 +515,7 @@ fields :: WParser String fields = do void . lexeme sql . string $ "(" - ret <- sepBy1 (do (whiteSpace sql); try (fieldsDeep 1) <|> typedIdentifier3) (string ",") + ret <- sepBy1 (do whiteSpace sql; try (fieldsDeep 1) <|> typedIdentifier3) (string ",") void . lexeme sql . string $ ")" return $ DL.intercalate ", " ret @@ -387,15 +524,17 @@ fieldsDeep depth = do deepId <- identifier3 void . lexeme sql . string $ "(" - ret <- sepBy (do (whiteSpace sql); try identifier3 <|> fieldsDeep depth ) (string ",") + ret <- sepBy (do whiteSpace sql; try identifier3 <|> fieldsDeep depth ) (string ",") void . lexeme sql . string $ ")" when (depth == 1) addKU return $ deepId ++ braketS (DL.intercalate "," ret) -- * braketS :: String -> String -braketS = (\x-> "(" ++ x ++ ")") +braketS x = "(" ++ x ++ ")" +quoteS :: String -> String +quoteS x = "'" ++ x ++ "'" {- | This is a simple library which acts as a wrapper for mysql-simple allowing adding Haskell types/functions inside sql queries @@ -460,20 +599,21 @@ try caseComp <|> try ( do optional $ addQ =<< expandQ (reservedNames sqlDef) - addQ1 =<< (lexeme sql $ string "(") + addQ1 =<< lexeme sql (string "(") optional computableC -- with comma - addQ1 =<< (lexeme sql $ string ")") - ) <|> try (addQ =<< identifier1) + addQ1 =<< lexeme sql (string ")") + ) <|> try (addQ =<< identifier1) optional $ try (do addQ1 =<< ((' ':) <$> arithm) computable ) + computableC :: WParser () computableC = do computable optional $ try $ do - addQ1 =<< (lexeme sql $ string ",") + addQ1 =<< lexeme sql (string ",") computableC {-- diff --git a/src/Database/TypedQuery/Types.hs b/src/Database/TypedQuery/Types.hs --- a/src/Database/TypedQuery/Types.hs +++ b/src/Database/TypedQuery/Types.hs @@ -2,6 +2,7 @@ , RankNTypes , CPP , TemplateHaskell + , LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -44,17 +45,26 @@ #if DEVELOPMENT import Language.Haskell.Exts (parseStmtWithMode, prettyPrint, ParseResult(..), defaultParseMode, Extension(..),KnownExtension(..), ParseMode(..)) +-- import Language.Haskell.Exts (parseStmt, prettyPrint, ParseResult(..), defaultParseMode, Extension(..),KnownExtension(..), ParseMode(..)) import Control.Monad.IO.Class (liftIO) import System.IO.Unsafe (unsafePerformIO) import Data.String.QM -codeFormat = check . fmap reformat . parseStmtWithMode defaultParseMode {extensions=[EnableExtension BangPatterns, EnableExtension HereDocuments,EnableExtension OverloadedStrings]} +codeFormat = id +codeFormat' = check . fmap reformat . parseStmtWithMode defaultParseMode { + extensions + = [ EnableExtension BangPatterns + , EnableExtension HereDocuments + , EnableExtension OverloadedStrings + , EnableExtension NewQualifiedOperators + , EnableExtension TypeOperators + ]} where reformat = prettyPrint - check r = case r of - ParseOk a -> a - ParseFailed loc err -> error $ show (loc,err) + check = \case + ParseOk a -> a + ParseFailed loc err -> error $ show (loc,err) #endif @@ -194,7 +204,7 @@ f <- TH.newName "f" x <- TH.newName "x" return $ - TH.LamE [TH.VarP f, (rdonly q) `TH.ConP` [TH.VarP x]] $ TH.VarE f `TH.AppE` TH.VarE x + TH.LamE [TH.VarP f, rdonly q `TH.ConP` [TH.VarP x]] $ TH.VarE f `TH.AppE` TH.VarE x genUncurry _ n | n < 0 = fail "There are no negative count tuples" | otherwise = do diff --git a/typedquery.cabal b/typedquery.cabal --- a/typedquery.cabal +++ b/typedquery.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: typedquery -version: 0.1.0.2 +version: 0.1.0.3 synopsis: Parser for SQL augmented with types description: Base package for parsing queries homepage: https://github.com/tolysz/typedquery @@ -40,3 +40,4 @@ , transformers hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall -fno-warn-type-defaults