yeshql 0.2.0.1 → 0.3.0.0
raw patch · 3 files changed
+119/−25 lines, 3 files
Files
- src/Database/YeshQL.hs +67/−16
- src/Database/YeshQL/Parser.hs +51/−8
- yeshql.cabal +1/−1
src/Database/YeshQL.hs view
@@ -40,7 +40,7 @@ insertUser :: IConnection conn => conn -> String -> IO [Integer] @ -= Syntax+== Syntax Because SQL itself does not *quite* provide enough information to generate a fully typed Haskell function, we extend SQL syntax a bit.@@ -51,20 +51,26 @@ [yesh| -- name:insertUser :: (Integer) -- :name :: String- INSERT INTO users (name) VALUES (:name) RETURNING id;+ INSERT INTO users (name) VALUES (:name) RETURNING id+ ;;; -- name:deleteUser :: Integer -- :id :: Integer- DELETE FROM users WHERE id = :id;+ DELETE FROM users WHERE id = :id+ ;;; -- name:getUser :: (Integer, String) -- :id :: Integer- SELECT id, name FROM users WHERE id = :id;+ SELECT id, name FROM users WHERE id = :id+ ;;; -- name:getUserEx :: (Integer, String) -- :id :: Integer -- :filename :: String- SELECT id, name FROM users WHERE name = :filename OR id = :id;+ SELECT id, name FROM users WHERE name = :filename OR id = :id |] @ +Note that queries are separated by _triple_ semicolons; this is done in order+to allow semicolons to appear inside queries.+ On top of standard SQL syntax, YeshQL query definitions are preceded by some extra information in order to generate well-typed HDBC queries. All that information is written in SQL line comments (@-- ...@), such that a valid@@ -83,9 +89,9 @@ The declared return type can be one of the following: -- '()'; the generated function will ignore any and all results from the query- and always return '()'.-- An integer scalar, e.g. @Integer@ or @Int@; the generated function will+- (); the generated function will ignore any and all results from the query+ and always return ().+- An integer scalar, e.g. 'Integer' or 'Int'; the generated function will return a row count from @INSERT@ / @UPDATE@ / ... statements, or 0 from @SELECT@ statements. - A tuple, where all elements implement 'FromSql'; the function will return@@ -121,14 +127,47 @@ -- ... generated implementation left out @ -= Loading Queries From External Files+== Loading Queries From External Files The 'yeshFile' and 'yesh1File' flavors take a file name instead of SQL definition strings. Using these, you can put your SQL in external files rather than clutter your code with long quasi-quotation blocks. -= Other Functions That YeshQL Generates+== DDL Queries +Normally, you will have one query per function, and that query takes some+parameters, and returns a result set or a row count. For DDL queries, however,+we aren't interested in the results, and we often want to execute multiple+queries with just one function call, e.g. to set up an entire database schema+using multiple @CREATE TABLE@ statements.++By adding the @\@ddl@ annotation to a query definition, YeshQL will change the+following things:++- The return type of that query, regardless of what you declare, will be '()'.+ It is recommended to never declare an explicit return type other than '()'+ for DDL queries, as future versions may report this as an error.+- The query cannot accept any parameters.+- The query may consist of multiple individual SQL queries,+ semicolon-separated. The combined query is sent to the HDBC backend as-is.+- Instead of 'run', YeshQL will use 'runRaw' in the code it generates.++In practice, this means that the type of a DDL function thus generated will+always be @'IConnection' conn => conn -> 'IO' ()@.++=== Example:++@+[yesh1|+ -- name:makeDatabaseSchema+ -- @ddl+ CREATE TABLE users (id INTEGER, username TEXT);+ CREATE TABLE pages (id INTEGER, title TEXT, slug TEXT, body TEXT);+ |]+@++== Other Functions That YeshQL Generates+ On top of the obvious query functions, a top-level YeshQL quasiquotation introduces two more definitions per query: a 'String' variable prefixed @describe-@, which contains the SQL query as passed to HDBC (similar to the@@ -184,7 +223,7 @@ #endif import Data.List (isPrefixOf, foldl') import Data.Maybe (catMaybes, fromMaybe)-import Database.HDBC (fromSql, toSql, run, ConnWrapper, IConnection, quickQuery')+import Database.HDBC (fromSql, toSql, run, runRaw, ConnWrapper, IConnection, quickQuery') import qualified Text.Parsec as P import Data.Char (chr, ord, toUpper, toLower) import Control.Applicative ( (<$>), (<*>) )@@ -383,7 +422,12 @@ |] where argTypes = map (mkType . fromMaybe AutoType . pqTypeFor query) (pqParamNames query)- returnType = case pqReturnType query of+ returnType =+ if pqDDL query+ then+ tupleT 0+ else+ case pqReturnType query of Left tn -> mkType tn Right [] -> tupleT 0 Right (x:[]) -> appT listT $ mkType x@@ -463,7 +507,14 @@ queryFunc = case pqReturnType query of Left _ -> [| \qstr params conn -> $convert <$> run conn qstr params |] Right _ -> [| \qstr params conn -> $convert <$> quickQuery' conn qstr params |]- queryFunc- `appE` (litE . stringL . pqQueryString $ query)- `appE` (listE [ appE (varE 'toSql) (varE . mkName $ n) | (n, t) <- (pqParamsRaw query) ])- `appE` (varE . mkName $ "conn")+ rawQueryFunc = [| \qstr conn -> runRaw conn qstr |]+ if pqDDL query+ then+ rawQueryFunc+ `appE` (litE . stringL . pqQueryString $ query)+ `appE` (varE . mkName $ "conn")+ else+ queryFunc+ `appE` (litE . stringL . pqQueryString $ query)+ `appE` (listE [ appE (varE 'toSql) (varE . mkName $ n) | (n, t) <- (pqParamsRaw query) ])+ `appE` (varE . mkName $ "conn")
src/Database/YeshQL/Parser.hs view
@@ -17,6 +17,7 @@ import Data.List (foldl', nub) import Data.Maybe (catMaybes, fromMaybe)+import Debug.Trace (trace) data ParsedType = PlainType String | MaybeType String | AutoType deriving Show@@ -30,14 +31,22 @@ , pqParamTypes :: Map String ParsedType , pqReturnType :: Either ParsedType [ParsedType] , pqDocComment :: String+ , pqDDL :: Bool } deriving (Show) pqTypeFor :: ParsedQuery -> String -> Maybe ParsedType pqTypeFor q pname = Map.lookup pname (pqParamTypes q) -parsedQuery :: String -> String -> [(String, ParsedType)] -> [(String, ParsedType)] -> Either ParsedType [ParsedType] -> String -> ParsedQuery-parsedQuery queryName queryString paramsRaw paramsExtra returnType docComment =+parsedQuery :: String+ -> String+ -> [(String, ParsedType)]+ -> [(String, ParsedType)]+ -> Either ParsedType [ParsedType]+ -> String+ -> Bool+ -> ParsedQuery+parsedQuery queryName queryString paramsRaw paramsExtra returnType docComment isDDL = ParsedQuery queryName queryString@@ -46,6 +55,7 @@ (extractParamTypeMap (paramsExtra ++ paramsRaw)) returnType docComment+ isDDL extractParamNames :: [(String, ParsedType)] -> [String] extractParamNames xs = @@ -65,8 +75,16 @@ (Just t', AutoType) -> m (Just t', t) -> error $ "Inconsistent types found for parameter '" ++ n ++ "': '" ++ show t' ++ "' vs. '" ++ show t ++ "'" -data ParsedItem = ParsedLiteral String | ParsedParam String ParsedType | ParsedComment String+data ParsedItem = ParsedLiteral String+ | ParsedParam String ParsedType+ | ParsedComment String+ | ParsedAnnotation Annotation+ deriving (Show) +data Annotation =+ DDLAnnotation+ deriving (Show)+ extractParsedQuery :: [ParsedItem] -> String extractParsedQuery = concat . map extractItem where@@ -89,6 +107,11 @@ extractItem (ParsedComment str) = Just str extractItem _ = Nothing +extractIsDDL :: [ParsedItem] -> Bool+extractIsDDL items =+ trace (show items) $+ not . null $ [ undefined | ParsedAnnotation DDLAnnotation <- items ]+ parseQueryN :: String -> String -> Either ParseError ParsedQuery parseQueryN fn src = runParser mainP () fn src@@ -106,6 +129,7 @@ mainP :: Parsec String () ParsedQuery mainP = do q <- queryP+ trace (show q) $ return () eof return q @@ -115,7 +139,7 @@ sepBy queryMayP sepP where sepP :: Parsec String () ()- sepP = try (spaces >> char ';' >> notFollowedBy (char ';') >> spaces)+ sepP = try (spaces >> string ";;;" >> spaces) queryMayP :: Parsec String () (Maybe ParsedQuery) queryMayP = do spaces@@ -125,8 +149,8 @@ queryP = do spaces (qn, retType) <- option ("", Left (PlainType "Integer")) $ nameDeclP <|> namelessDeclP- extraItems <- many (paramDeclP <|> commentP)- items <- many (try commentP <|> try itemP)+ extraItems <- many (try annotationP <|> paramDeclP <|> commentP)+ items <- many (try itemP <|> try commentP) return $ parsedQuery qn (extractParsedQuery items)@@ -134,6 +158,7 @@ (extractParsedParams extraItems) retType (extractDocComment (extraItems ++ items))+ (extractIsDDL (extraItems ++ items)) nameDeclP :: Parsec String () (String, Either ParsedType [ParsedType]) nameDeclP = do@@ -182,8 +207,26 @@ return $ MaybeType name itemP :: Parsec String () ParsedItem-itemP = paramP <|> quotedP <|> literalP+itemP = paramP <|> quotedP <|> literalP <|> semicolonP +semicolonP :: Parsec String () ParsedItem+semicolonP = try $ do+ char ';'+ notFollowedBy $ char ';'+ return $ ParsedLiteral ";"++annotationP :: Parsec String () ParsedItem+annotationP = do+ try $ (whitespaceP >> string "--" >> whitespaceP >> char '@')+ ParsedAnnotation <$> ddlAnnotationP++ddlAnnotationP :: Parsec String () Annotation+ddlAnnotationP = do+ string "ddl"+ whitespaceP+ newlineP+ return DDLAnnotation+ paramDeclP :: Parsec String () ParsedItem paramDeclP = do try $ (whitespaceP >> string "--" >> whitespaceP >> char ':')@@ -202,7 +245,7 @@ commentP = do try (whitespaceP >> string "--") whitespaceP- ParsedComment <$> manyTill (noneOf " \t\n;") (newlineP <|> ignore (char ';'))+ ParsedComment <$> manyTill (noneOf " \t\n;") newlineP paramP :: Parsec String () ParsedItem paramP = do
yeshql.cabal view
@@ -1,5 +1,5 @@ name: yeshql-version: 0.2.0.1+version: 0.3.0.0 synopsis: YesQL-style SQL database abstraction description: license: MIT