typedquery 0.1.0.2 → 0.1.0.3
raw patch · 4 files changed
+227/−59 lines, 4 files
Files
- src/Database/TypedQuery/SQL.hs +21/−4
- src/Database/TypedQuery/SQLParser.hs +189/−49
- src/Database/TypedQuery/Types.hs +15/−5
- typedquery.cabal +2/−1
src/Database/TypedQuery/SQL.hs view
@@ -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"+ }
src/Database/TypedQuery/SQLParser.hs view
@@ -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) +-- <derived column> ::= <value expression> [ <as clause> ]+derivedColumn :: WParser ()+derivedColumn = do+ try valueExpressionWithAsClause+ <|> valueExpression+ valueType++{-+<value expression> ::=+ <common value expression>+ | <boolean value expression>+ | <row value expression>++<common value expression> ::=+ <numeric value expression>+ | <string value expression>+ | <datetime value expression>+ | <interval value expression>+ | <user-defined type value expression>+ | <reference value expression>+ | <collection value expression>+-}++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 {--
src/Database/TypedQuery/Types.hs view
@@ -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
typedquery.cabal view
@@ -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