yeshql (empty) → 0.1.0.0
raw patch · 6 files changed
+584/−0 lines, 6 filesdep +HDBCdep +basedep +containerssetup-changed
Dependencies added: HDBC, base, containers, parsec, stm, tasty, tasty-hunit, tasty-quickcheck, template-haskell, yeshql
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- src/Database/YeshQL.hs +287/−0
- src/Database/YeshQL/Parser.hs +227/−0
- tests/tests.hs +12/−0
- yeshql.cabal +36/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015-2016 Tobias Dammers++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Database/YeshQL.hs view
@@ -0,0 +1,287 @@+{-#LANGUAGE TemplateHaskell #-}+{-|+Module: Database.YeshQL+Description: Turn SQL queries into type-safe functions.+Copyright: (c) 2015 Tobias Dammers+Maintainer: Tobias Dammers <tdammers@gmail.com>+Stability: experimental+License: MIT++Unlike existing libraries such as Esqueleto or Persistent, YeshQL does not try+to provide full SQL abstraction with added type safety; instead, it gives you+some simple tools to write the SQL queries yourself and bind them to (typed)+functions.++= Usage++The main workhorses are the 'yesh1' (to define one query) and 'yesh' (to define+multiple queries) quasi-quoters.++Both 'yesh' and 'yesh1' can produce either declarations or expressions,+depending on the context in which they are used.++== Creating Declarations++When used at the top level, or inside a @where@ block, the 'yesh' and 'yesh1'+quasi-quoters will declare one or more functions, according to the query names+given in the query definition. Example:++@+[yesh1|+ -- name:insertUser :: (Integer)+ -- :name :: String+ INSERT INTO users (name) VALUES (:name) RETURNING id |]+@++...will create a top-level function of type:++@+ insertUser :: IConnection conn => conn -> String -> IO [Integer]+@++= Syntax++Because SQL itself does not *quite* provide enough information to generate a+fully typed Haskell function, we extend SQL syntax a bit.++Here's what a typical YeshQL definition looks like:++@+[yesh|+ -- name:insertUser :: (Integer)+ -- :name :: String+ INSERT INTO users (name) VALUES (:name) RETURNING id;+ -- name:deleteUser :: Integer+ -- :id :: Integer+ DELETE FROM users WHERE id = :id;+ -- name:getUser :: (Integer, String)+ -- :id :: Integer+ 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;+ |]+@++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+YeshQL definition is also valid SQL by itself (with the exception of+parameters, which follow the pattern @:paramName@).++Let's break it down:++@+ -- name:insertUser :: (Integer)+@++This line tells YeshQL to generate an object called @insertUser@, which should+be a function of type @IConnection conn => conn -> {...} -> IO (Integer)@+(where the @{...}@ part depends on query parameters, see below).++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+ return a row count from @INSERT@ / @UPDATE@ / ... statements, or 0 from+ @SELECT@ statements.+- A tuple, where all elements implement 'FromSql'; the function will return+ the result set from a @SELECT@ query as a list of tuples, or an empty list+ for other query types.+- A "one-tuple", i.e., a type in parentheses. The return value will be a list+ of scalars, containing the values from the first (or only) column in+ the result set. Note that, unlike Haskell, YeshQL does distinguish between+ @Type@ and @(Type)@: the former is a scalar type, while the latter is a+ one-tuple whose only element is of type @Type@.++@+ -- :paramName :: Type+@++Declares a Haskell type for a parameter. The parameter @:paramName@ can then+be referenced zero or more times in the query itself, and will appear in the+generated function signature in the order of declaration. So in the above+example, the last query definition:++@+ -- name:getUserEx :: (Integer, String)+ -- :id :: Integer+ -- :filename :: String+ SELECT id, name FROM users WHERE name = :filename OR id = :id;+@++...will produce the function:++@+getUserEx :: IConnection conn => conn -> Integer -> String -> IO [(Integer, String)]+getUserEx conn id filename =+ -- ... generated implementation left out+@++ -}+module Database.YeshQL+( yesh, yesh1+, mkQueryDecs+, mkQueryExp+, parseQuery+, ParsedQuery (..)+)+where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Data.List (isPrefixOf, foldl')+import Data.Maybe (catMaybes, fromMaybe)+import Database.HDBC (fromSql, toSql, run, ConnWrapper, IConnection, quickQuery')+import qualified Text.Parsec as P+import Data.Char (chr, ord, toUpper, toLower)+import Control.Applicative ( (<$>), (<*>) )++import Database.YeshQL.Parser++nthIdent :: Int -> String+nthIdent i+ | i < 26 = [chr (ord 'a' + i)]+ | 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.+yesh1 :: QuasiQuoter+yesh1 = QuasiQuoter+ { quoteDec = withParsedQuery mkQueryDecs+ , quoteExp = withParsedQuery mkQueryExp+ , quoteType = error "yesh1 does not generate types"+ , quotePat = error "yesh1 does not generate patterns"+ }++-- | Generate top-level declarations or expressions for several SQL queries.+yesh :: QuasiQuoter+yesh = QuasiQuoter+ { quoteDec = withParsedQueries mkQueryDecsMulti+ , quoteExp = withParsedQueries mkQueryExpMulti+ , quoteType = error "yesh does not generate types"+ , quotePat = error "yesh does not generate patterns"+ }++queryName :: String -> String -> Name+queryName prefix basename =+ mkName $ prefix ++ ucfirst basename++ucfirst :: String -> String+ucfirst "" = ""+ucfirst (x:xs) = toUpper x:xs++lcfirst :: String -> String+lcfirst "" = ""+lcfirst (x:xs) = toLower x:xs++withParsedQuery :: (ParsedQuery -> Q a) -> String -> Q a+withParsedQuery = withParsed parseQuery++withParsedQueries :: ([ParsedQuery] -> Q a) -> String -> Q a+withParsedQueries = withParsed parseQueries++withParsed :: (Monad m, Show e) => (s -> Either e a) -> (a -> m b) -> s -> m b+withParsed p a src = do+ let parseResult = p src+ arg <- case parseResult of+ Left e -> fail . show $ e+ Right x -> return x+ a arg+++pgQueryType :: ParsedQuery -> TypeQ+pgQueryType query =+ [t|IConnection conn =>+ $(foldr+ (\a b -> [t| $a -> $b |])+ [t| conn -> IO $(returnType) |]+ $ argTypes)+ |]+ where+ argTypes = map (mkType . fromMaybe AutoType . pqTypeFor query) (pqParamNames query)+ returnType = case pqReturnType query of+ Left tn -> mkType tn+ Right [] -> tupleT 0+ Right (x:[]) -> appT listT $ mkType x+ Right xs -> appT listT $ foldl' appT (tupleT $ length xs) (map mkType xs)++mkType :: ParsedType -> Q Type+mkType (MaybeType n) = [t|Maybe $(conT . mkName $ n)|]+mkType (PlainType n) = conT . mkName $ n+mkType AutoType = [t|String|]++mkQueryDecsMulti :: [ParsedQuery] -> Q [Dec]+mkQueryDecsMulti queries = concat <$> mapM mkQueryDecs queries++mkQueryExpMulti :: [ParsedQuery] -> Q Exp+mkQueryExpMulti queries =+ foldl1 (\a b -> VarE '(>>) `AppE` a `AppE` b) <$> mapM mkQueryExp queries++pqNames :: ParsedQuery -> ([Name], [PatQ], String, TypeQ)+pqNames query =+ let argNamesStr = pqParamNames query ++ ["conn"]+ argNames = map mkName argNamesStr+ patterns = map varP argNames+ funName = pqQueryName query+ queryType = pgQueryType query+ in (argNames, patterns, funName, queryType)++mkQueryDecs :: ParsedQuery -> Q [Dec]+mkQueryDecs query = do+ let (argNames, patterns, funName, queryType) = pqNames query+ sRun <- sigD (mkName . lcfirst $ funName) queryType+ fRun <- funD (mkName . lcfirst $ funName)+ [ clause+ (map varP argNames)+ (normalB . mkQueryBody $ query)+ []+ ]+ sDescribe <- sigD (queryName "describe" funName) [t|String|]+ fDescribe <- funD (queryName "describe" funName)+ [ clause+ []+ (normalB . litE . stringL . pqQueryString $ query)+ []+ ]+ sDocument <- sigD (queryName "doc" funName) [t|String|]+ fDocument <- funD (queryName "doc" funName)+ [ clause+ []+ (normalB . litE . stringL . pqDocComment $ query)+ []+ ]+ return [sRun, fRun, sDescribe, fDescribe, sDocument, fDocument]++mkQueryExp :: ParsedQuery -> Q Exp+mkQueryExp query = do+ let (argNames, patterns, funName, queryType) = pqNames query+ sigE+ (lamE patterns (mkQueryBody query))+ queryType++mkQueryBody :: ParsedQuery -> Q Exp+mkQueryBody query = do+ let (argNames, patterns, funName, queryType) = pqNames query++ convert :: ExpQ+ convert = case pqReturnType query of+ Left tn -> varE 'fromInteger+ Right [] -> [|\_ -> ()|]+ Right (x:[]) -> [|map (fromSql . head)|]+ Right xs ->+ let varNames = map nthIdent [0..pred (length xs)]+ in [|map $(lamE+ -- \[a,b,c,...] ->+ [(listP (map (varP . mkName) varNames))]+ -- (fromSql a, fromSql b, fromSql c, ...)+ (tupE $ (map (\n -> appE (varE 'fromSql) (varE . mkName $ n)) varNames)))|]+ 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")
+ src/Database/YeshQL/Parser.hs view
@@ -0,0 +1,227 @@+module Database.YeshQL.Parser+( parseQuery+, parseQueries+, ParsedQuery (..)+, ParsedType (..)+, pqTypeFor+)+where++import Text.Parsec+import Control.Applicative ( (<$>), (<*>) )++import qualified Data.Map.Strict as Map+import Data.Map (Map)++import Data.List (foldl', nub)+import Data.Maybe (catMaybes, fromMaybe)++data ParsedType = PlainType String | MaybeType String | AutoType+ deriving Show++data ParsedQuery =+ ParsedQuery+ { pqQueryName :: String+ , pqQueryString :: String+ , pqParamsRaw :: [(String, ParsedType)]+ , pqParamNames :: [String]+ , pqParamTypes :: Map String ParsedType+ , pqReturnType :: Either ParsedType [ParsedType]+ , pqDocComment :: String+ }+ 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+ queryName+ queryString+ paramsRaw+ (extractParamNames (paramsExtra ++ paramsRaw))+ (extractParamTypeMap (paramsExtra ++ paramsRaw))+ returnType+ docComment++extractParamNames :: [(String, ParsedType)] -> [String]+extractParamNames xs = + nub . map fst $ xs++extractParamTypeMap :: [(String, ParsedType)] -> Map String ParsedType+extractParamTypeMap = foldl' applyItem Map.empty+ where+ applyItem :: Map String ParsedType -> (String, ParsedType) -> Map String ParsedType+ applyItem m (n, t) =+ let tc = Map.lookup n m+ in case (tc, t) of+ (Nothing, AutoType) -> m+ (Nothing, t) -> Map.insert n t m+ (Just AutoType, AutoType) -> m+ (Just AutoType, t) -> Map.insert n t m+ (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++extractParsedQuery :: [ParsedItem] -> String+extractParsedQuery = concat . map extractItem+ where+ extractItem :: ParsedItem -> String+ extractItem (ParsedLiteral str) = str+ extractItem (ParsedComment _) = ""+ extractItem (ParsedParam _ _) = "?"++extractParsedParams :: [ParsedItem] -> [(String, ParsedType)]+extractParsedParams = catMaybes . map extractItem+ where+ extractItem :: ParsedItem -> Maybe (String, ParsedType)+ extractItem (ParsedParam n t) = Just (n, t)+ extractItem _ = Nothing++extractDocComment :: [ParsedItem] -> String+extractDocComment = unlines . catMaybes . map extractItem+ where+ extractItem :: ParsedItem -> Maybe String+ extractItem (ParsedComment str) = Just str+ extractItem _ = Nothing++parseQuery :: String -> Either ParseError ParsedQuery+parseQuery src = runParser mainP () "query" src++parseQueries :: String -> Either ParseError [ParsedQuery]+parseQueries src = runParser multiP () "queries" src++mainP :: Parsec String () ParsedQuery+mainP = do+ q <- queryP+ eof+ return q++multiP :: Parsec String () [ParsedQuery]+multiP = do+ fmap catMaybes $+ sepBy queryMayP sepP+ where+ sepP :: Parsec String () ()+ sepP = try (spaces >> char ';' >> notFollowedBy (char ';') >> spaces)+ queryMayP :: Parsec String () (Maybe ParsedQuery)+ queryMayP = do+ spaces+ fmap Just queryP <|> (eof >> return Nothing) <?> "SQL query"++queryP :: Parsec String () ParsedQuery+queryP = do+ spaces+ (qn, retType) <- option ("query", Left (PlainType "Integer")) $ nameDeclP <|> namelessDeclP+ extraItems <- many (paramDeclP <|> commentP)+ items <- many (try commentP <|> try itemP)+ return $ parsedQuery+ qn+ (extractParsedQuery items)+ (extractParsedParams items)+ (extractParsedParams extraItems)+ retType+ (extractDocComment (extraItems ++ items))++nameDeclP :: Parsec String () (String, Either ParsedType [ParsedType])+nameDeclP = do+ try (whitespaceP >> string "--" >> whitespaceP >> string "name" >> whitespaceP >> char ':')+ whitespaceP+ qn <- identifierP+ whitespaceP+ retType <- option (Left (PlainType "Integer")) (try (string "::" >> whitespaceP >> returnTypeP))+ whitespaceP+ newlineP+ return (qn, retType)++namelessDeclP :: Parsec String () (String, Either ParsedType [ParsedType])+namelessDeclP = do+ try (whitespaceP >> string "--" >> whitespaceP >> string "::" >> whitespaceP)+ retType <- returnTypeP+ whitespaceP+ newlineP+ return ("query", retType)++identifierP :: Parsec String () String+identifierP =+ (:) <$> leadCharP <*> many tailCharP+ where+ leadCharP = oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ "_"+ tailCharP = oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"++returnTypeP :: Parsec String () (Either ParsedType [ParsedType])+returnTypeP = returnTypeMultiP <|> returnTypeSingleP++returnTypeSingleP :: Parsec String () (Either ParsedType [ParsedType])+returnTypeSingleP = Left <$> typeP++returnTypeMultiP :: Parsec String () (Either ParsedType [ParsedType])+returnTypeMultiP =+ Right <$> between+ (char '(' >> whitespaceP)+ (char ')' >> whitespaceP)+ (sepBy (between whitespaceP whitespaceP typeP) (char ','))++typeP :: Parsec String () ParsedType+typeP = do+ name <- identifierP+ option (PlainType name) $ do+ char '?'+ return $ MaybeType name++itemP :: Parsec String () ParsedItem+itemP = paramP <|> quotedP <|> literalP++paramDeclP :: Parsec String () ParsedItem+paramDeclP = do+ try $ (whitespaceP >> string "--" >> whitespaceP >> char ':')+ name <- identifierP+ whitespaceP+ t <- option AutoType $ do+ string "::"+ whitespaceP+ t <- typeP+ whitespaceP+ return t+ newlineP+ return $ ParsedParam name t++commentP :: Parsec String () ParsedItem+commentP = do+ try (whitespaceP >> string "--")+ whitespaceP+ ParsedComment <$> manyTill (noneOf " \t\n;") (newlineP <|> ignore (char ';'))++paramP :: Parsec String () ParsedItem+paramP = do+ char ':'+ pname <- identifierP+ ptype <- option AutoType $ do+ string "::"+ typeP+ return $ ParsedParam pname ptype++quotedP :: Parsec String () ParsedItem+quotedP = do+ char '\''+ contents <- many (noneOf "'")+ char '\''+ return . ParsedLiteral . ('\'':) . (++ "'") $ contents++literalP :: Parsec String () ParsedItem+literalP = ParsedLiteral <$> many1 (noneOf ":';")++whitespaceP :: Parsec String () ()+whitespaceP = do+ many (oneOf " \t\r")+ return ()++ignore :: Parsec s u a -> Parsec s u ()+ignore x = x >> return ()++newlineP :: Parsec String () ()+newlineP = do+ (ignore $ char '\n') <|> (ignore . try . string $ ";;")+ return ()
+ tests/tests.hs view
@@ -0,0 +1,12 @@+{-#LANGUAGE TemplateHaskell #-}+{-#LANGUAGE QuasiQuotes #-}+module Main where++import Test.Tasty+import qualified Database.YeshQL.SimulationTests as SimulationTests++main = defaultMain allTests+ where+ allTests = testGroup "All Tests"+ [ testGroup "Simulation Tests" SimulationTests.tests+ ]
+ yeshql.cabal view
@@ -0,0 +1,36 @@+name: yeshql+version: 0.1.0.0+synopsis: YesQL-style SQL database abstraction+description:+license: MIT+license-file: LICENSE+author: Tobias Dammers+maintainer: tdammers@gmail.com+copyright: 2015-2016 Tobias Dammers+category: Database+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules: Database.YeshQL+ other-modules: Database.YeshQL.Parser+ -- other-extensions:+ build-depends: base >=4.6 && <5.0+ , template-haskell+ , HDBC >= 2.4 && <3.0+ , parsec >= 3.0 && <4.0+ , containers >= 0.5 && < 1.0+ hs-source-dirs: src+ default-language: Haskell2010+test-suite tests+ type: exitcode-stdio-1.0+ build-depends: base >=4.6 && <5.0+ , yeshql+ , stm+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , HDBC+ hs-source-dirs: tests+ main-is: tests.hs