diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Marcin Tolysz + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Marcin Tolysz nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,65 @@ +typedquery +========== + +Parser for SQL augmented with types + +This package provides base parsing facilities for possibly all *-simple database packages converting them into *-simpel-typed + + * https://github.com/tolysz/mysql-simple-typed + * https://github.com/tolysz/sqlite-simple-typed + * https://github.com/tolysz/postgresql-simple-typed + +example: https://github.com/tolysz/sqlite-simple-typed/blob/master/example/src/Main.hs + +The basic idea is to start using SQL again, but use comemnts (`--`) to hide haskell annotation. + +This started as `QuasiQuotes` excercise with the TH inpired `printf`. + + * `genJsonQuery` produces `[Value]` + * `genTypedQuery` produces `[(T1,...,Tn)]` tuples, `[T]` or `()` all depending on the `SQL` query + +If you do not provide value (or a mean to get on inside query you need to give it outside. + + +They do the same: + + $(genJsonQuery "SET SESSION group_concat_max_len = ? ") conn (10000 :: Int) + $(genJsonQuery "SET SESSION group_concat_max_len = ? -- Int ") conn 10000 + $(genJsonQuery "SET SESSION group_concat_max_len = ? -- Int -- < 1000 ") conn + $(genJsonQuery "SET SESSION group_concat_max_len = ? -- < (1000 :: Int) ") conn + + +There is a basic syntax, and the base idea is to have a nice easy for eye syntax. +It fires the correct `execute` or `query` with or without `_` depending on the actual `SQL` syntax + +The parser is not complete, I will try to add as many issues there are and try to fix it. + +Adnotations start with `-- ` as otherwise `HeidiSQL` was complaining, then `>` `<` `~` or just text. + + +| syntax | equivalent | +------------------------- | ------------------------------ +| `bal -- Type` | `(\v -> v :: Bla)` | +| `bla -- > f` | `(\v -> f bla )` | +| `bla -- Type -- > f` | `(\v -> (f bla):: Type )` | +| `? -- Type -- < var` | `??` | +| `? -- < var` | `??` | +| `? -- < var` | `??` | +| `? -- ~ verbatim` | `??` | + + + +Eg. + + $(genJsonQuery [qq| insert into some_table + ( timeAsSQLfunction -- ~ now () + , someInputfromAesonViaLens -- Int -- < v ^? (key "coolValue" . _Integral) ^. non 3 + , someUserName -- Text -- < someNameFromContext + ) |]) conn + +Translates to + + execute conn [qq| insert into some_table + ( timeAsSQLfunction, someInputfromAesonViaLens, someUserName ) + values ( now (), ?, ?) |] + [( (v ^? (key "coolValue" . _Integral) ^. non 3 ) :: Int, someNameFromContext Text)] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Database/TypedQuery/SQL.hs b/src/Database/TypedQuery/SQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/TypedQuery/SQL.hs @@ -0,0 +1,62 @@ + +module Database.TypedQuery.SQL where + +import Text.Parsec +import Text.Parsec.Token +import Text.Parsec.Language +import Prelude + +sql :: TokenParser st +sql = makeTokenParser sqlDef + +sqlExpr :: TokenParser st +sqlExpr = makeTokenParser sqlDefExpr + +sqlExpr2 :: TokenParser st +sqlExpr2 = makeTokenParser sqlDefExpr2 + +sqlStyle :: LanguageDef st +sqlStyle = emptyDef + { commentStart = "/*" + , commentEnd = "*/" + , commentLine = "-- #" + , nestedComments = True + , identStart = letter + , identLetter = alphaNum <|> oneOf "_.[]" + , opStart = opLetter sqlStyle + , opLetter = oneOf "$%&*+./<=>?@\\^|-~()" + , reservedOpNames= [] + , reservedNames = [] + , caseSensitive = False + } + +sqlStyleCS :: LanguageDef st +sqlStyleCS = sqlStyle { + caseSensitive = True + } + +sqlDefExpr :: LanguageDef st +sqlDefExpr = sqlStyleCS + { identLetter = alphaNum <|> oneOf "_.[]" + , reservedNames = [ "as", "AS", "As", "aS" + , "from", "FROM", "fROM", "From" + ] +} + +sqlDefExpr2 :: LanguageDef st +sqlDefExpr2 = sqlStyleCS + { identLetter = alphaNum <|> oneOf "_.[]" + , reservedNames = [ "as", "AS", "As", "aS" + , "from", "FROM", "fROM", "From" + ] + } + +sqlDef :: LanguageDef st +sqlDef = sqlStyle + { 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"] + } diff --git a/src/Database/TypedQuery/SQLParser.hs b/src/Database/TypedQuery/SQLParser.hs new file mode 100644 --- /dev/null +++ b/src/Database/TypedQuery/SQLParser.hs @@ -0,0 +1,500 @@ + +{-# 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]] +--} diff --git a/src/Database/TypedQuery/Types.hs b/src/Database/TypedQuery/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/TypedQuery/Types.hs @@ -0,0 +1,256 @@ +{-# Language DeriveDataTypeable + , RankNTypes + , CPP + , TemplateHaskell + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.TypedQuery.Types +( TypedQuery (..) +, TypeAction (..) +, RunDB (..) +, jsonPair +, convAction +, typeTuple +, typeTupleIn +, vanilaQuery +, genUncurry +, genJsonQuery +, genTypedQuery +) +where + +import Control.Arrow (first) +import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) +import Data.Typeable (Typeable) + +import Data.Aeson (object) +import Data.Aeson.Types (ToJSON(..),Value) + +import Database.TypedQuery.SQLParser +import Data.Text (Text,unpack) +import Prelude +import Control.Monad +import Control.Applicative +import Data.Either +import Data.Maybe + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH + +import Language.Haskell.Meta.Parse (parseType, parseExp) + + +#if DEVELOPMENT +import Language.Haskell.Exts (parseStmtWithMode, 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]} + where + reformat = prettyPrint + check r = case r of + ParseOk a -> a + ParseFailed loc err -> error $ show (loc,err) + +#endif + +class RunDB q where + rdquery :: q -> TH.Name + rdquery_ :: q -> TH.Name + rdexecute :: q -> TH.Name + rdexecute_ :: q -> TH.Name + rdin :: q -> TH.Name + rdonly :: q -> TH.Name + rdconn :: q -> TH.Name + +data RunDB q => TypedQuery q +-- ^ `TypedQuery` is a represent SQL query + all fields we could parse from it +-- the idea is to use the original SQL and use comments `--` to annotate it with some extra information + = TypedQuery + { fromTypedQuery :: q -- SQL text of the query + , namesTypedQuery :: [Text] -- names from fields + , typesTypedQuery :: [TypeAction] -- types of fields + , typesTypedInput :: [TypeAction] -- types of "?" inputs + , typesTypedInputSource :: [TypeAction] -- functions feeding data + } + deriving (Eq, Ord, Typeable) + +flat :: RunDB q => TypedQuery q -> (q, [Text], [TypeAction], [TypeAction], [TypeAction]) +flat (TypedQuery a b c d e) = (a, b, c, d, e) + +instance (RunDB q, TH.Lift q) => TH.Lift (TypedQuery q) where + lift = TH.lift . flat + +instance TH.Lift Text where + lift = TH.lift . unpack + +instance (Show q,RunDB q) => Show (TypedQuery q) where + show = show . fromTypedQuery + +instance (RunDB q, IsString q, Monoid q) => Read (TypedQuery q) where + readsPrec i = fmap (first conv) . readsPrec i + where + conv x = case typedSQLtoSQL x of + Nothing -> mempty + Just (a, b, c, d, e) -> TypedQuery (fromString a) b c d e + +instance (RunDB q, IsString q, Monoid q) => IsString (TypedQuery q) where + fromString x = + case typedSQLtoSQL x of + Nothing -> mempty + Just (a, b, c, d, e) -> TypedQuery (fromString a) b c d e + +instance (RunDB q, Monoid q) => Monoid (TypedQuery q) where + mempty = TypedQuery mempty mempty mempty mempty mempty + TypedQuery a1 a2 a3 a4 a5 `mappend` TypedQuery b1 b2 b3 b4 b5 + = TypedQuery + (mappend a1 b1) + (mappend a2 b2) + (mappend a3 b3) + (mappend a4 b4) + (mappend a5 b5) + {-# INLINE mappend #-} + +convAction :: RunDB q => q -> TypeAction -> TH.Exp -> TH.Exp +convAction _ (TAUnknown) = id +convAction _ (TAConv s) = case parseExp s of + Right e -> TH.AppE e + Left er -> error $ "Could not find `convExp` type: " ++ er + +convAction _ (TACast s) = case parseType s of + Right t1 -> (`TH.SigE` t1) + Left er -> error $ "Could not find `typeExp` type: " ++ er + +convAction q (TAInUnknown) = TH.AppE (TH.ConE (rdonly q)) +convAction q (TAInConv s) = case parseExp s of + Right ex -> TH.AppE (TH.ConE (rdin q)) . TH.AppE ex + Left er -> error $ "Could not find `convExp` type: " ++ er +convAction q (TAInCast s) = case parseType s of + Right t1 -> \ e -> TH.ConE (rdin q) `TH.AppE` (e `TH.SigE` t1) + Left er -> error $ "Could not find `typeExp` type: " ++ er + + +jsonPair :: RunDB q => TypedQuery q -> TH.Q TH.Exp +jsonPair (TypedQuery q li lq _ _) = do + let k = length li + nam <- mapM TH.lift li + nsa <- replicateM k (TH.newName "a") + let typ = zipWith (\a b -> convAction q a (TH.VarE b)) lq nsa + case k of + 1 -> do + let n1 = head nam + let t1 = head typ + return $ TH.LamE + [TH.BangP $ TH.ConP (rdonly q) [ TH.VarP $ head nsa] ] + ( TH.AppE (TH.VarE 'object) (TH.ListE [TH.TupE [n1, TH.AppE (TH.VarE 'toJSON) t1]])) + _ -> return $ TH.LamE + [TH.TupP $ map (TH.BangP . TH.VarP) nsa] + ( TH.AppE (TH.VarE 'object) (TH.ListE $ zipWith (\a b-> TH.TupE [ a, TH.AppE (TH.VarE 'toJSON) b `TH.SigE` TH.ConT ''Value]) nam typ ) ) + +typeTuple :: RunDB q => TypedQuery q -> TH.Q TH.Exp +typeTuple (TypedQuery q _ lq _ _) = do + let k = length lq + nsa <- replicateM k (TH.newName "a") + let typ = zipWith (\a b -> convAction q a (TH.VarE b)) lq nsa + case k of + 1 -> return $ TH.LamE [TH.BangP $ TH.ConP (rdonly q) [ TH.VarP $ head nsa] ] (head typ) + _ -> return $ TH.LamE [TH.TupP $ map (TH.BangP . TH.VarP) nsa ] (TH.TupE typ) + +genVal :: RunDB q => q -> TypeAction -> Either a (Maybe TH.Exp) +genVal _ (TAInsIS a) = Right $ either (error "parse failed") Just (parseExp a) +genVal _ (TAInsISU a) = Right $ either (error "parse failed") Just (parseExp a) +genVal q (TAInSupply a) = Right $ either (error "parse failed") (Just . TH.AppE (TH.ConE (rdin q)) ) (parseExp a) +genVal _ _ = Right Nothing + + +handleOnly :: RunDB q => q -> [TH.Exp] -> TH.Exp +handleOnly q [a] = TH.ConE (rdonly q) `TH.AppE` a +handleOnly _ a = TH.TupE a + +typeTupleIn :: RunDB q => TypedQuery q -> TH.Q(Bool,Bool,TH.Exp) +typeTupleIn (TypedQuery q _ _ lq lextra) = do + nsa <- replicateM (length lq) (TH.newName "i") + + let initTyp = zipWith (\a b -> if b == TAInsQM || b == TAInsQMU then Left a else genVal q b ) nsa lextra + typ = zipWith (\a c -> case c of + Left v -> Just $ convAction q a (TH.VarE v) + Right v -> convAction q a <$> v + ) lq initTyp + pat1 = lefts initTyp + reduce_params b = if b then id else TH.LamE [TH.TupP $ map (TH.BangP . TH.VarP) pat1] + + return (null pat1, null typ , reduce_params (null pat1) (handleOnly q $ catMaybes typ)) + + +genUncurry :: RunDB q => q -> Int -> TH.Q TH.Exp +genUncurry _ 0 = do + f <- TH.newName "f" + return (TH.VarE f) +genUncurry q 1 = do + 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 +genUncurry _ n + | n < 0 = fail "There are no negative count tuples" + | otherwise = do + f <- TH.newName "f" + xs <- replicateM n (TH.newName "x") + return $ + TH.LamE [TH.VarP f, TH.TupP $ map (TH.BangP . TH.VarP) xs] $ + foldl1 TH.AppE (map TH.VarE (f : xs)) + + +vanilaQuery :: (RunDB q, TH.Lift q) => (TypedQuery q -> TH.Q TH.Exp) -> TypedQuery q -> TH.Q TH.Exp +-- ^ general query which can be parametrized depending on the needs +-- it takes a transformation function and some typed Query +vanilaQuery tran tq@(TypedQuery q _ lq _ _) = do + conn <- TH.newName "conn" + qp <- TH.newName "qp" + tmp1 <- TH.newName "res1" + q1 <- [| q |] + pa <- tran tq + (null_out, null_int, initial) <- typeTupleIn tq + let final_type_cast b = if b then id else TH.AppE (TH.AppE (TH.VarE 'fmap) (TH.VarE 'map `TH.AppE` pa)) + type_connection x = TH.VarE x `TH.AppE` (TH.VarE conn `TH.SigE` TH.ConT (rdconn q)) `TH.AppE` q1 + has_no_output = null lq + (qqqq, pat) = + case (has_no_output, null_int , null_out) of + (True , True , _ ) -> ( type_connection (rdexecute_ q), []) + (True , False, False) -> ( type_connection (rdexecute q) `TH.AppE` TH.AppE initial (TH.VarE qp) , [TH.VarP qp] ) + (True , False, True ) -> ( type_connection (rdexecute q) `TH.AppE` initial , [] ) + (False , True , _ ) -> ( type_connection (rdquery_ q), []) + (False , False, False) -> ( type_connection (rdquery q) `TH.AppE` TH.AppE initial (TH.VarE qp) , [TH.VarP qp] ) + (False , False, True ) -> ( type_connection (rdquery q) `TH.AppE` initial , [] ) + exp = TH.LamE (TH.VarP conn : pat) $ final_type_cast has_no_output qqqq +#if DEVELOPMENT + unsafePerformIO $ do + putStrLn $ codeFormat $ TH.pprint exp + liftIO $ return $ return $ exp +#else + return exp +#endif + +genJsonQuery :: (RunDB q, TH.Lift q) => TypedQuery q -> TH.Q TH.Exp +genJsonQuery = vanilaQuery jsonPair + +genTypedQuery :: (RunDB q, TH.Lift q) => TypedQuery q -> TH.Q TH.Exp +genTypedQuery = vanilaQuery typeTuple + + +{-- +class SimpleQuery q where + query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] + query_ :: FromRow r => Connection -> Query -> IO [r] + -- queryNamed :: FromRow r => Connection -> Query -> [NamedParam] -> IO [r]queryNamed :: FromRow r => Connection -> Query -> [NamedParam] -> IO [r] + execute :: ToRow q => Connection -> Query -> q -> IO () + execute_ :: Connection -> Query -> IO () + +--} + + + diff --git a/typedquery.cabal b/typedquery.cabal new file mode 100644 --- /dev/null +++ b/typedquery.cabal @@ -0,0 +1,34 @@ +-- Initial typedquery.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: typedquery +version: 0.1.0.0 +synopsis: Parser for SQL augmented with types +description: Base package for parsing queries +homepage: https://github.com/tolysz/typedquery +license: BSD3 +license-file: LICENSE +author: Marcin Tolysz +maintainer: tolysz@gmail.com +-- copyright: +category: Database +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: Database.TypedQuery.SQL + Database.TypedQuery.SQLParser + Database.TypedQuery.Types + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <4.8 + , template-haskell + , haskell-src-meta + , parsec + , aeson + , bytestring + , text + , transformers + hs-source-dirs: src + default-language: Haskell2010