yeshql 2.2.0.0 → 3.0.0.0
raw patch · 5 files changed
+269/−92 lines, 5 files
Files
- src/Database/YeshQL.hs +116/−82
- src/Database/YeshQL/SqlRow/Class.hs +47/−2
- src/Database/YeshQL/SqlRow/TH.hs +10/−4
- tests/Database/YeshQL/SimulationTests.hs +93/−1
- yeshql.cabal +3/−3
src/Database/YeshQL.hs view
@@ -1,6 +1,7 @@ {-#LANGUAGE TemplateHaskell #-} {-#LANGUAGE CPP #-} {-#LANGUAGE RankNTypes #-}+{-#LANGUAGE FlexibleInstances #-} {-| Module: Database.YeshQL Description: Turn SQL queries into type-safe functions.@@ -16,11 +17,12 @@ = Usage -The main workhorses are the 'yesh1' (to define one query) and 'yesh' (to define-multiple queries) quasi-quoters.+The main workhorses are 'yesh1' (to define one query) and 'yesh' (to define+multiple queries). -Both 'yesh' and 'yesh1' can produce either declarations or expressions,-depending on the context in which they are used.+Both 'yesh' and 'yesh1' can be used as TemplateHaskell functions directly, or+as quasi-quoters, and they can generate declarations or expressions depending+on the context in which they are used. == Creating Declarations @@ -41,6 +43,16 @@ insertUser :: IConnection conn => conn -> String -> IO (Maybe Integer) @ +Using plain TH, it can also be written as:++@+yesh1 $ unlines+ [ "-- name:insertUser :: (Integer)"+ , "-- :name :: String"+ , "INSERT INTO users (name) VALUES (:name) RETURNING id"+ ]+@+ == Syntax Because SQL itself does not *quite* provide enough information to generate a@@ -271,88 +283,110 @@ | otherwise = let (j, k) = divMod i 26 in nthIdent j ++ nthIdent k --- | Generate a top-level declaration or an expression for a single SQL query.--- If used at the top level (i.e., generating a declaration), the query--- definition must specify a query name.-yesh1 :: QuasiQuoter-yesh1 = QuasiQuoter- { quoteDec = withParsedQuery mkQueryDecs- , quoteExp = withParsedQuery mkQueryExp- , quoteType = error "yesh1 does not generate types"- , quotePat = error "yesh1 does not generate patterns"- }+class Yesh a where+ -- | Generate a top-level declaration or an expression for a single SQL query.+ -- If used at the top level (i.e., generating a declaration), the query+ -- definition must specify a query name.+ yesh1 :: a --- | Generate top-level declarations or expressions for several SQL queries.--- If used at the top level (i.e., generating declarations), all queries in the--- definitions must be named, and 'yesh' will generate a separate set of--- functions for each.--- If used in an expression context, the current behavior is somewhat--- undesirable, namely sequencing the queries using '>>'.------ Future versions will most likely change this to create a tuple of query--- expressions instead, such that you can write something like:------ @--- let (createUser, getUser, updateUser, deleteUser) = [yesh|--- -- name:createUser :: (Integer)--- -- :username :: String--- INSERT INTO users (username) VALUES (:username) RETURNING id;--- -- name:getUser :: (Integer, String)--- -- :userID :: Integer--- SELECT id, username FROM users WHERE id = :userID;--- -- name:updateUser :: Integer--- -- :userID :: Integer--- -- :username :: String--- UPDATE users SET username = :username WHERE id = :userID;--- -- name:deleteUser :: Integer--- -- :userID :: Integer--- DELETE FROM users WHERE id = :userID LIMIT 1;--- |]--- @-yesh :: QuasiQuoter-yesh = QuasiQuoter- { quoteDec = withParsedQueries mkQueryDecsMulti- , quoteExp = withParsedQueries mkQueryExpMulti- , quoteType = error "yesh does not generate types"- , quotePat = error "yesh does not generate patterns"- }+ -- | Generate top-level declarations or expressions for several SQL queries.+ -- If used at the top level (i.e., generating declarations), all queries in the+ -- definitions must be named, and 'yesh' will generate a separate set of+ -- functions for each.+ -- If used in an expression context, the current behavior is somewhat+ -- undesirable, namely sequencing the queries using '>>'.+ --+ -- Future versions will most likely change this to create a tuple of query+ -- expressions instead, such that you can write something like:+ --+ -- @+ -- let (createUser, getUser, updateUser, deleteUser) = [yesh|+ -- -- name:createUser :: (Integer)+ -- -- :username :: String+ -- INSERT INTO users (username) VALUES (:username) RETURNING id;+ -- -- name:getUser :: (Integer, String)+ -- -- :userID :: Integer+ -- SELECT id, username FROM users WHERE id = :userID;+ -- -- name:updateUser :: Integer+ -- -- :userID :: Integer+ -- -- :username :: String+ -- UPDATE users SET username = :username WHERE id = :userID;+ -- -- name:deleteUser :: Integer+ -- -- :userID :: Integer+ -- DELETE FROM users WHERE id = :userID LIMIT 1;+ -- |]+ -- @+ yesh :: a --- | Generate one query definition or expression from an external file.--- In a declaration context, the query name will be derived from the filename--- unless the query contains an explicit name. Query name derivation works as--- follows:------ - Take only the basename (stripping off the directories and extension)--- - Remove all non-alphabetic characters from the beginning of the name--- - Remove all non-alphanumeric characters from the name--- - Lower-case the first character.------ Note that since there is always a filename to derive the query name from,--- explicitly defining a query name is only necessary when you want it to--- differ from the filename; however, making it explicit anyway is probably a--- good idea.-yesh1File :: QuasiQuoter-yesh1File = QuasiQuoter- { quoteDec = withParsedQueryFile mkQueryDecs- , quoteExp = withParsedQueryFile mkQueryExp- , quoteType = error "yesh1File does not generate types"- , quotePat = error "yesh1File does not generate patterns"+class YeshFile a where+ -- | Generate one query definition or expression from an external file.+ -- In a declaration context, the query name will be derived from the filename+ -- unless the query contains an explicit name. Query name derivation works as+ -- follows:+ --+ -- - Take only the basename (stripping off the directories and extension)+ -- - Remove all non-alphabetic characters from the beginning of the name+ -- - Remove all non-alphanumeric characters from the name+ -- - Lower-case the first character.+ --+ -- Note that since there is always a filename to derive the query name from,+ -- explicitly defining a query name is only necessary when you want it to+ -- differ from the filename; however, making it explicit anyway is probably a+ -- good idea.+ yesh1File :: a++ -- | Generate multiple query definitions or expressions from an external file.+ -- Query name derivation works exactly like for 'yesh1File', except that an+ -- underscore and a 0-based query index are appended to disambiguate queries+ -- from the same file.+ --+ -- In an expression context, the same caveats apply as for 'yesh', i.e., to+ -- generate expressions, you will almost certainly want 'yesh1File', not+ -- 'yeshFile'.+ yeshFile :: a++instance Yesh (String -> Q [Dec]) where+ yesh1 = withParsedQuery mkQueryDecs+ yesh = withParsedQueries mkQueryDecsMulti++instance YeshFile (FilePath -> Q [Dec]) where+ yesh1File = withParsedQueryFile mkQueryDecs+ yeshFile = withParsedQueriesFile mkQueryDecsMulti++instance Yesh (String -> Q Exp) where+ yesh1 = withParsedQuery mkQueryExp+ yesh = withParsedQueries mkQueryExpMulti++instance YeshFile (FilePath -> Q Exp) where+ yesh1File = withParsedQueryFile mkQueryExp+ yeshFile = withParsedQueriesFile mkQueryExpMulti++instance Yesh QuasiQuoter where+ yesh = QuasiQuoter+ { quoteDec = yesh+ , quoteExp = yesh+ , quoteType = error "YeshQL does not generate types"+ , quotePat = error "YeshQL does not generate patterns" }+ yesh1 = QuasiQuoter+ { quoteDec = yesh1+ , quoteExp = yesh1+ , quoteType = error "YeshQL does not generate types"+ , quotePat = error "YeshQL does not generate patterns"+ } --- | Generate multiple query definitions or expressions from an external file.--- Query name derivation works exactly like for 'yesh1File', except that an--- underscore and a 0-based query index are appended to disambiguate queries--- from the same file.------ In an expression context, the same caveats apply as for 'yesh', i.e., to--- generate expressions, you will almost certainly want 'yesh1File', not--- 'yeshFile'.-yeshFile :: QuasiQuoter-yeshFile = QuasiQuoter- { quoteDec = withParsedQueriesFile mkQueryDecsMulti- , quoteExp = withParsedQueriesFile mkQueryExpMulti- , quoteType = error "yeshFile does not generate types"- , quotePat = error "yeshFile does not generate patterns"+instance YeshFile QuasiQuoter where+ yeshFile = QuasiQuoter+ { quoteDec = yeshFile+ , quoteExp = yeshFile+ , quoteType = error "YeshFileQL does not generate types"+ , quotePat = error "YeshFileQL does not generate patterns"+ }+ yesh1File = QuasiQuoter+ { quoteDec = yesh1File+ , quoteExp = yesh1File+ , quoteType = error "YeshFileQL does not generate types"+ , quotePat = error "YeshFileQL does not generate patterns" } queryName :: String -> String -> Name
src/Database/YeshQL/SqlRow/Class.hs view
@@ -1,5 +1,7 @@ {-#LANGUAGE OverloadedStrings #-} {-#LANGUAGE DeriveGeneric #-}+{-#LANGUAGE DeriveFunctor #-}+{-#LANGUAGE GeneralizedNewtypeDeriving #-} {-#LANGUAGE LambdaCase #-} {-#LANGUAGE TemplateHaskell #-} {-#LANGUAGE MultiParamTypeClasses #-}@@ -8,12 +10,55 @@ where import Database.HDBC-import Data.Convertible (Convertible)+import Data.Convertible (Convertible, prettyConvertError) class ToSqlRow a where toSqlRow :: a -> [SqlValue] +newtype Parser a =+ Parser { runParser :: [SqlValue] -> Either String (a, [SqlValue]) }+ deriving (Functor)++instance Applicative Parser where+ pure x = Parser $ \values -> Right (x, values)+ (<*>) = parserApply++parserApply :: Parser (a -> b) -> Parser a -> Parser b+parserApply (Parser rpf) (Parser rpa) =+ Parser $ \values ->+ case rpf values of+ Left err -> Left err+ Right (f, values') ->+ case rpa values' of+ Left err -> Left err+ Right (a, values'') ->+ Right (f a, values'')++instance Monad Parser where+ (>>=) = parserBind+ fail err = Parser . const . Left $ err++parserBind :: Parser a -> (a -> Parser b) -> Parser b+parserBind p f =+ let g = runParser p+ in Parser $ \values -> case g values of+ Left err -> Left err+ Right (x, values') -> runParser (f x) values'+ class FromSqlRow a where- fromSqlRow :: Monad m => [SqlValue] -> m a+ parseSqlRow :: Parser a +fromSqlRow :: (FromSqlRow a, Monad m) => [SqlValue] -> m a+fromSqlRow sqlValues =+ case runParser parseSqlRow sqlValues of+ Left err -> fail err+ Right (value, _) -> return value+ class (ToSqlRow a, FromSqlRow a) => SqlRow a where++parseField :: Convertible SqlValue a => Parser a+parseField = Parser $ \case+ [] -> Left "Not enough columns in result set"+ (x:xs) -> case safeFromSql x of+ Left cerr -> Left . prettyConvertError $ cerr+ Right a -> Right (a, xs)
src/Database/YeshQL/SqlRow/TH.hs view
@@ -29,11 +29,17 @@ $(listE $ map (toSqlRowField 'entity) fieldNames) instance FromSqlRow $(conT typeName) where- fromSqlRow = \case- $(listP $ map fromSqlPatternItem fieldNames) ->- return $- $(foldl1 appE $+ parseSqlRow = Parser $ \case+ $(foldr+ (\x xs -> infixP x '(:) xs)+ (varP $ mkName "remaining")+ (map fromSqlPatternItem fieldNames)+ ) ->+ return+ ( $(foldl1 appE $ conE constructorName : map fromSqlPatternArg fieldNames)+ , remaining+ ) _ -> fail $ "Invalid SQL for " ++ $(litE . stringL . nameBase $ typeName) |] where toSqlRowField :: Name -> Name -> ExpQ
tests/Database/YeshQL/SimulationTests.hs view
@@ -24,14 +24,37 @@ , userName :: String } deriving (Show, Eq)- makeSqlRow ''User +data Person =+ Person+ { personName :: String+ , personEmail :: String+ }+ deriving (Show, Eq)+makeSqlRow ''Person++data UserData =+ UserData+ { user :: User+ , person :: Person+ }+ deriving (Show, Eq)++instance ToSqlRow UserData where+ toSqlRow d = (toSqlRow . user $ d) ++ (toSqlRow . person $ d)++instance FromSqlRow UserData where+ parseSqlRow = UserData <$> parseSqlRow <*> parseSqlRow+ tests = [ testSimpleSelect+ , testSimpleSelectStr , testParametrizedSelect , testSingleInsert , testRecordReturn+ , testRecordReturnComplex+ , testRecordReturnExcessive , testRecordParams , testUpdateReturnRowCount , testMultiQuery@@ -58,6 +81,24 @@ } ] +testSimpleSelectStr :: TestTree+testSimpleSelectStr = testCase "Simple SELECT (expr by string)" $ chatTest chatScript $ \conn -> do+ results <- $(yesh $ unlines+ [ "-- name:getUserByName :: (String)"+ , "SELECT username FROM users"+ ]) conn+ return ()+ where+ chatScript =+ [ ChatStep+ { chatQuery = sameThrough trim "SELECT username FROM users"+ , chatParams = []+ , chatResultSet = []+ , chatColumnNames = ["username"]+ , chatRowsAffected = 0+ }+ ]+ testParametrizedSelect :: TestTree testParametrizedSelect = testCase "Parametrized SELECT" $ chatTest chatScript $ \conn -> do actual <- [yesh|@@ -95,6 +136,57 @@ { chatQuery = sameThrough trim "SELECT id, username FROM users WHERE username = ? LIMIT 1" , chatParams = [exactly (toSql "billy")] , chatResultSet = [[toSql (1 :: Int), toSql "billy"]]+ , chatColumnNames = ["username"]+ , chatRowsAffected = 0+ }+ ]++testRecordReturnComplex :: TestTree+testRecordReturnComplex = testCase "Return record from SELECT" $ chatTest chatScript $ \conn -> do+ actual <- [yesh|+ -- name:getUserByName :: UserData+ -- :username :: String+ SELECT id, username, person_name, email FROM users WHERE username = :username LIMIT 1|]+ "billy"+ conn+ let expected :: Maybe UserData+ expected = Just $ UserData (User 1 "billy") (Person "Billy" "billy@example.org")+ assertEqual "" expected actual+ where+ chatScript =+ [ ChatStep+ { chatQuery = sameThrough trim "SELECT id, username, person_name, email FROM users WHERE username = ? LIMIT 1"+ , chatParams = [exactly (toSql "billy")]+ , chatResultSet =+ [+ [ toSql (1 :: Int)+ , toSql "billy"+ , toSql "Billy"+ , toSql "billy@example.org"+ ]+ ]+ , chatColumnNames = ["username", "person_name", "email"]+ , chatRowsAffected = 0+ }+ ]++testRecordReturnExcessive :: TestTree+testRecordReturnExcessive = testCase "Return record from SELECT (extra values ignored)" $ chatTest chatScript $ \conn -> do+ actual <- [yesh|+ -- name:getUserByName :: User+ -- :username :: String+ SELECT id, username FROM users WHERE username = :username LIMIT 1|]+ "billy"+ conn+ let expected :: Maybe User+ expected = Just $ User 1 "billy"+ assertEqual "" expected actual+ where+ chatScript =+ [ ChatStep+ { chatQuery = sameThrough trim "SELECT id, username FROM users WHERE username = ? LIMIT 1"+ , chatParams = [exactly (toSql "billy")]+ , chatResultSet = [[toSql (1 :: Int), toSql "billy", toSql "willie"]] , chatColumnNames = ["username"] , chatRowsAffected = 0 }
yeshql.cabal view
@@ -1,8 +1,8 @@ name: yeshql-version: 2.2.0.0+version: 3.0.0.0 synopsis: YesQL-style SQL database abstraction-description: Use quasi-quotations to write SQL in SQL, while at the same time- adding type annotations to turn them into well-typed Haskell+description: Use quasi-quotations or TemplateHaskell to write SQL in SQL, while+ adding type annotations to turn SQL into well-typed Haskell functions. license: MIT license-file: LICENSE