typedquery (empty) → 0.1.0.0
raw patch · 7 files changed
+949/−0 lines, 7 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, haskell-src-meta, parsec, template-haskell, text, transformers
Files
- LICENSE +30/−0
- README.md +65/−0
- Setup.hs +2/−0
- src/Database/TypedQuery/SQL.hs +62/−0
- src/Database/TypedQuery/SQLParser.hs +500/−0
- src/Database/TypedQuery/Types.hs +256/−0
- typedquery.cabal +34/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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)]
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Database/TypedQuery/SQL.hs view
@@ -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"]+ }
+ src/Database/TypedQuery/SQLParser.hs view
@@ -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]]+--}
+ src/Database/TypedQuery/Types.hs view
@@ -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 ()++--}+++
+ typedquery.cabal view
@@ -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