typedquery-0.1.0.0: src/Database/TypedQuery/SQLParser.hs
{-# Language OverloadedStrings #-}
{-# Language DeriveDataTypeable #-}
{-# LANGUAGE CPP #-}
module Database.TypedQuery.SQLParser
(typedSQLtoSQL, TypeAction(..))
where
import Data.Char ( toUpper)
import Data.Functor.Identity (Identity)
import qualified Data.Text as T
import Data.Text (Text)
import Data.Typeable (Typeable)
import Text.Parsec hiding ((<|>))
import Text.Parsec.Language
import Database.TypedQuery.SQL
import Text.Parsec.Token
import Control.Applicative hiding (many, optional)
--import Control.Arrow (first)
import Control.Monad -- (void, foldM_)
import Data.Monoid (Monoid (..))
import qualified Language.Haskell.TH.Syntax as TH
import Data.Maybe
import qualified Data.List as DL
import Prelude
#if DEVELOPMENT
import Control.Monad.IO.Class (liftIO)
import System.IO.Unsafe (unsafePerformIO)
pprint :: SQLWriter -> IO ()
pprint (SQLWriter a b c d zz) = {- putStrLn a >> -} print zz >> print (zip b c) >> print d
#endif
data TypeAction
-- | SELECT
= TAUnknown
-- ^ column of unknown type
| TACast String
-- ^ column type
| TAConv String
-- ^ column conversion function
| TAInUnknown
-- ^ `?` input of unknown type
| TAInCast String
-- ^ `?` input of known type
| TAInConv String
-- ^ `?` conversion function
| TAInSupply String
-- ^ `?` supply SQL literal string
-- | INSERT
| TAInsNop
-- ^ do nothing
| TAInsQM
-- ^ insery QuestionMark
| TAInsQMU
-- ^
| TAInsLit String
| TAInsIS String
| TAInsISU String
deriving (Eq, Show, Ord, Typeable)
data SQLWriter
-- ^ type to store data while we parse the query
= SQLWriter
{ queryW :: String
-- ^ represents output sql
, nameW :: [String]
-- ^ stores column names
, typeW :: [TypeAction]
-- ^ stores column types
, inTypeW :: [TypeAction]
-- ^ stores '?' types
, inTypeV :: [TypeAction]
} deriving (Show)
instance TH.Lift TypeAction where
lift = TH.lift
toValu :: TypeAction -> Maybe String
toValu TAInsQM = Just "?"
toValu (TAInsIS _) = Just "?"
toValu (TAInsLit s) = Just s
toValu _ = Nothing
filTAInsLit :: TypeAction -> Bool
filTAInsLit (TAInsLit _) = False
filTAInsLit _ = True
-- (catMaybes $ map toValu z)
addValues :: [String] -> String
addValues [] = ""
addValues a = " VALUES ( "++ DL.intercalate " , " a ++" );"
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)
type WParser a = ParsecT String SQLWriter Identity a
addW :: SQLWriter -> WParser ()
addW a = updateState $ (`mappend` a)
addU, addIU, addJU :: WParser ()
addU = addW $ mempty { typeW = [TAUnknown] }
addIU = addW $ mempty { inTypeW = [TAUnknown] }
addJU = addW $ mempty { inTypeW = [TAInUnknown] }
addKU, addKQM, addKQMU :: WParser ()
addKU = addW $ mempty { inTypeV = [TAInsNop] }
addKQM = addW $ mempty { inTypeV = [TAInsQM] }
addKQMU = addW $ mempty { inTypeV = [TAInsQMU] }
addKLit, addKIS, addKISU :: String -> WParser ()
addKLit s = addW $ mempty { inTypeV = [TAInsLit s] }
addKIS s = addW $ mempty { inTypeV = [TAInsIS s] }
addKISU s = addW $ mempty { inTypeV = [TAInsISU s] }
addQ1c :: Char -> WParser ()
addQ1c s = addW $ mempty { queryW = [s] }
-- 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) }
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] }
addIC s = addW $ mempty { inTypeW = [TAConv s] }
addJT s = addW $ mempty { inTypeW = [TAInCast s] }
addJC s = addW $ mempty { inTypeW = [TAInConv s] }
addJISU :: String -> WParser ()
addJISU s = addW $ mempty { inTypeV = [TAInSupply s]}
instance Monoid SQLWriter where
mempty = SQLWriter mempty mempty mempty mempty mempty
SQLWriter a1 a2 a3 a4 a5 `mappend` SQLWriter b1 b2 b3 b4 b5
= SQLWriter (mappend a1 b1) (mappend a2 b2) (mappend a3 b3) (mappend a4 b4) (mappend a5 b5)
typedSQLtoSQL :: String -> Maybe (String, [Text], [TypeAction], [TypeAction], [TypeAction])
-- ^ takes some annotates string and gives its parsed representation
typedSQLtoSQL a = do
case runParser (mksql >> getState) mempty "nope" a of
Right r -> let
rr = fromSQLWriter r
in
#if DEVELOPMENT
unsafePerformIO $ do
putStrLn $ (\(a1,_,_,_,_) -> '\n':a1) rr
pprint $ r
liftIO $ return $ Just rr
#else
Just rr
#endif
Left l -> error $ show l
-- *
mksql :: WParser ()
mksql = (try parseSelect) <|> (try parseInsert) <|> (do optional (try typeParams);addQ =<< getInput)
-- eol :: WParser ()
-- *
eol :: WParser ()
eol = try (void $ string "\r\n")
<|> try (void $ string "\n\r")
<|> try (void $ char '\r')
<|> try (void $ char '\n')
<|> notFollowedBy anyToken
-- *
caseChar :: Char -> WParser Char
caseChar c = satisfy (\x -> toUpper x == toUpper c)
-- *
stringSQL :: String -> WParser String
stringSQL cs = lexeme sql (((mapM_ caseChar cs) >> return cs) <?> cs)
-- *
wsKill :: WParser a -> WParser a
wsKill p = do
whiteSpace haskell
r <- p
whiteSpace sql
return r
-- *
rawHaskell :: WParser String
rawHaskell = wsKill $ manyTill anyChar eol
-- *
rawHaskellT :: WParser String
rawHaskellT = wsKill $ manyTill anyChar (eol <|> (void $ lookAhead $ try $ string "-- <"))
-- *
stringLiteralQ :: WParser String
stringLiteralQ = do
lit <- stringLiteral haskell
return $ show lit
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)
-- *
arithm :: WParser String
arithm = do
whiteSpace sql
r <- oneOf "%&*+/<=>-~"
whiteSpace sql
return [r]
-- *
identifier3 :: WParser String
identifier3 =
try (stringLiteral sql )
<|> try ( do
void . lexeme sql . string $ "("
ret <- identifier3
void . lexeme sql . string $ ")"
return $ braketS ret
) <|> try (lexeme sql $ identifier sqlExpr2)
-- <|> expandQ (reservedNames sqlDef)
-- *
greserved :: String -> WParser ()
greserved s = (lexeme sql $ reserved sql s) *> addQ s
greservedQ :: String -> WParser String
greservedQ s = (lexeme sql $ reserved sql s) >> return s
-- *
expand :: [String] -> WParser ()
expand (a:as) = try (greserved a) <|> (expand as)
expand [] = empty
-- *
expandQ :: [String] -> WParser String
expandQ (a:as) = try (greservedQ a) <|> (expandQ as)
expandQ [] = fail "not a reserved"
-- *
typeParams :: WParser ()
typeParams = do
try typeParamsSimple
<|> try typeParamsIn
<|> expand (reservedNames sqlDef)
<|> try (addQ =<< (lexeme sql $ identifier sql))
<|> try (addQ . show =<< integer sql)
<|> try (addQQ =<< stringLiteral sql)
<|> (addQ1c =<< anyChar)
optional (try typeParams)
-- *
typeParamsIn :: WParser ()
typeParamsIn = do
greserved "IN"
addQR =<< stringSQL "?"
try (
do
addKQMU
void $ string "-- >"
addJC =<< rawHaskell
addQ1 "\n "
) <|> try ( do
void $ string "-- <"
addJISU =<< rawHaskell
addIU
) <|> try (
do
addKQMU
void $ string "--"
addJT =<< rawHaskell
addQ1 "\n "
) <|> addJU
-- *
optInputSourceU :: WParser ()
optInputSourceU = try ( do
void $ string "-- <"
addKISU =<< rawHaskell
) <|> addKQMU
-- *
typeParamsSimple :: WParser ()
typeParamsSimple = do
addQR =<< stringSQL "?"
try (
do
void $ string "-- >"
addIC =<< rawHaskellT
optInputSourceU
addQ1 "\n "
) <|> try ( do
void $ string "-- <"
addKISU =<< rawHaskell
addIU
) <|> try (
do
void $ string "--"
addIT =<< rawHaskellT
optInputSourceU
addQ1 "\n "
) <|> (addIU >> addKQMU)
selectExpr :: WParser ()
selectExpr = do
optional $ (try $ do
computable
greserved "AS"
)
addQN =<< identifier2
try (
do
void $ string "-- >"
addC =<< rawHaskell
addQ1 "\n "
) <|> try (
do
void $ string "--"
addT =<< rawHaskell
addQ1 "\n "
) <|> addU
optional ((comma sql >>= addQ1) >> selectExpr)
-- TODO: check and simplify
-- ******************************
parseSelect :: WParser ()
parseSelect = do
whiteSpace sql
-- void $ many (lexeme haskell (try eol))
greserved "SELECT"
optional $ try (greserved "DISTINCT") <|> try (greserved "UNIQUE")
selectExpr
optional $ try typeParams
--huntQM
--addQ =<< getInput
-- *
optInputSource :: WParser ()
optInputSource = try ( do
void $ string "-- <"
addKIS =<< rawHaskell
) <|> addKQM
-- *
typedIdentifier3 :: WParser String
typedIdentifier3 = do
r <- identifier3
optional $ try ( do
void $ string "-- ~"
addKLit =<< rawHaskell
)<|> try ( do
void $ string "-- >"
addIC =<< rawHaskellT
optInputSource
) <|> try ( do
void $ string "-- <"
addKIS =<< rawHaskell
) <|> try ( do
void $ string "--"
addIT =<< rawHaskellT
optInputSource
) <|> (addJU >> addKQM)
return r
-- *
fields :: WParser String
fields = do
void . lexeme sql . string $ "("
ret <- sepBy1 (do (whiteSpace sql); try (fieldsDeep 1) <|> typedIdentifier3) (string ",")
void . lexeme sql . string $ ")"
return $ DL.intercalate ", " ret
-- *
fieldsDeep :: Int -> WParser String
fieldsDeep depth = do
deepId <- identifier3
void . lexeme sql . 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 ++ ")")
{- |
This is a simple library which acts as a wrapper for mysql-simple allowing adding Haskell types/functions inside sql queries
TH is heavily in use to generate simple lambda expressions so typechecker can infer types.
Whenever we do not say anything it will have to be infered using some other ways.
If we specify types, the singleton results/inputs does not need to wrapped into Only, the machinery converts it into a parameter
as if 1-tuple == value
All operations happens on the compile time, the generated code is the same as if we have written some (possibly sloppy queries for m-s)
SQL Insert is a bit simplified, we do not specify the VALUES section as it will be generated for us
there are special operatrs:
we can set fields to
-- ~ Exactly the text we put after (the exact text is placed in the palace of ? like : VaLues( ...,Exactly,...)
-- > function fun which will generate ? and the parameter at this location will get the sql( ...?...) (fun input)
-- Type -> sql( ...?...) (input :: Type)
-- < someCalculations -> sql( ...?...) (someCalculations)
Currently there are two main functions: genJsonQuery,genTypedQuery
which depending on the number of parameters and the type of query will return
a list or (); they will make decision and call one of query, query_, execute or execute_
genJsonQuery will capture the names from AS part of Q and use it to generate Aeson object property of this name and value from the result
genTypedQuery the result of it will be just a list [(r1,..,rn)]
There was some effort made to have IN queries to generate IN param for you; thus in your Q yu put just a list and it should be magically
wrapped to make m-s
The original m-s allows only a very short ( ;) 10) of query results, there is a TH generator but which has to be run beforehand... I was wondering
if it could be somehow automatised ?
-}
-- TODO: check and simplify
parseInsert :: WParser ()
parseInsert = do
whiteSpace sql
greserved "INSERT"
greserved "INTO"
addQ =<< identifier3
addQ =<< braketS <$> fields
addQ =<< getInput
caseComp :: WParser ()
caseComp = do
greserved "CASE"
greserved "WHEN"
computable
greserved "THEN"
computable
greserved "ELSE"
computable
greserved "END"
computable :: WParser ()
computable = do
try caseComp
<|> try ( do
optional $ addQ =<< expandQ (reservedNames sqlDef)
addQ1 =<< (lexeme sql $ string "(")
optional computableC -- with comma
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 ",")
computableC
{--
SELECT
[ALL | DISTINCT | DISTINCTROW ]
[HIGH_PRIORITY]
[STRAIGHT_JOIN]
[SQL_SMALL_RESULT] [SQL_BIG_RESULT] [SQL_BUFFER_RESULT]
[SQL_CACHE | SQL_NO_CACHE] [SQL_CALC_FOUND_ROWS]
select_expr [, select_expr ...]
[FROM table_references
[WHERE where_condition]
[GROUP BY {col_name | expr | position}
[ASC | DESC], ... [WITH ROLLUP]]
[HAVING where_condition]
[ORDER BY {col_name | expr | position}
[ASC | DESC], ...]
[LIMIT {[offset,] row_count | row_count OFFSET offset}]
[PROCEDURE procedure_name(argument_list)]
[INTO OUTFILE 'file_name' export_options
| INTO DUMPFILE 'file_name'
| INTO var_name [, var_name]]
[FOR UPDATE | LOCK IN SHARE MODE]]
--}