yeshql-core (empty) → 4.1.0.0

raw patch · 9 files changed

+1071/−0 lines, 9 filesdep +basedep +containersdep +convertible

Dependencies added: base, containers, convertible, filepath, parsec, stm, tasty, tasty-hunit, tasty-quickcheck, template-haskell, yeshql-core

Files

• LICENSE +20/−0
• README.md +58/−0
• src/Database/YeshQL/Backend.hs +169/−0
• src/Database/YeshQL/Core.hs +258/−0
• src/Database/YeshQL/Parser.hs +340/−0
• src/Database/YeshQL/Util.hs +121/−0
• tests/Database/YeshQL/ParserTests.hs +44/−0
• tests/tests.hs +12/−0
• yeshql-core.cabal +49/−0

@@ -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.

@@ -0,0 +1,58 @@+# YeshQL++[YesQL](https://github.com/krisajenkins/yesql)-style SQL database abstraction.++YeshQL implements quasiquoters that allow the programmer to write SQL queries+in SQL, and embed these into Haskell programs using quasi-quotation. YeshQL+takes care of generating suitable functions that will run the SQL queries+against a HDBC database driver, and marshal values between Haskell and SQL.++In order to do this properly, YeshQL extends SQL syntax with type annotations+and function names; other than that, it is perfectly ignorant about the SQL+syntax itself. See the [YesQL+Readme](https://github.com/krisajenkins/yesql/blob/master/README.md) for the+full rationale - Haskell and Clojure are sufficiently different languages, but+the reasoning behind YesQL applies to YeshQL almost unchanged.++## Installation++Use [stack](http://haskellstack.org/) or [cabal](http://haskell.org/cabal/) to+install. Nothing extraordinary here.++## Usage++In short:++    {-#LANGUAGE QuasiQuotes #-}+    import MyProject.DatabaseConnection (withDB)+    import Database.HDBC+    import Database.YeshQL++    [yesh|+      -- name:getUser :: (String)+      -- :userID :: Int+      SELECT username FROM users WHERE id = :userID+    |] ++    main = withDB $ \conn -> do+      username <- getUser 1 conn+      putStrLn username++Please refer to the Haddock documentation for further usage details.++## Bugs++Probably. The project is hosted at https://github.com/tdammers/yeshql, feel+free to comment there or send a message to tdammers@gmail.com if you find any.++## Something about the name++YeshQL is rather heavily inspired by YesQL, so it makes sense to blatantly+steal most of the name. Throwing in an "H" for good measure (this being Haskell+and all) makes it sound like Sean Connery, which automatically increases+aweshomenesh, so that'sh what we'll roll with.++## License / Copying++YeshQL is Free Software and provided as-is. Please see the enclosed LICENSE+file for details.

@@ -0,0 +1,169 @@+{-#LANGUAGE TemplateHaskell #-}+{-#LANGUAGE CPP #-}+{-#LANGUAGE RankNTypes #-}+{-#LANGUAGE FlexibleInstances #-}+{-|+Backend abstractions for YeshQL.+-}+module Database.YeshQL.Backend+where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+#if MIN_VERSION_template_haskell(2,7,0)+import Language.Haskell.TH.Syntax (Quasi(qAddDependentFile))+#endif+import Database.YeshQL.Util+import Database.YeshQL.Parser+import Data.List++-- | A backend provides just the information required to build query functions+-- from a parsed query.+data YeshBackend =+  YeshBackend+    { ybNames :: ParsedQuery+              -> ([Name], [PatQ], String, TypeQ)+                 -- ^ Argument names, argument patterns, query function name, query function type+    , ybMkQueryBody :: ParsedQuery+                    -> Q Exp+    }++-- | A YeshQL implementation. From this, we can build both TH splices and+-- quasiquoters.+data YeshImpl =+  YeshImpl+    { yiDecs :: Q [Dec]+    , yiExp :: Q Exp+    }++foldYeshImpls :: [YeshImpl] -> YeshImpl+foldYeshImpls [] =+  YeshImpl+    { yiDecs = return []+    , yiExp = return $ VarE 'return `AppE` TupE []+    }+foldYeshImpls xs =+  YeshImpl+    { yiDecs =+        foldl1' (++) <$>+          mapM yiDecs xs+    , yiExp = do+        foldl1 (\a b -> VarE '(>>) `AppE` a `AppE` b) <$>+          mapM yiExp xs+    }++-- | We want to be able to call the 'yesh' family of functions in both QQ and+-- TH contexts, so unfortunately we need some typeclass polymorphism.+class Yesh a where+  yeshWith :: YeshBackend -> a+  yesh1With :: YeshBackend -> a++class YeshFile a where+  yeshFileWith :: YeshBackend -> a+  yesh1FileWith :: YeshBackend -> a++instance Yesh (String -> Q Exp) where+  yeshWith backend =+    withParsedQueries $ \queries -> do+      yiExp $ yeshAllWith backend (Right queries)+  yesh1With backend =+    withParsedQuery $ \query -> do+      yiExp $ yeshAllWith backend (Left query)++instance Yesh (String -> Q [Dec]) where+  yeshWith backend =+    withParsedQueries $ \queries -> do+      yiDecs $ yeshAllWith backend (Right queries)+  yesh1With backend =+    withParsedQuery $ \query -> do+      yiDecs $ yeshAllWith backend (Left query)++instance Yesh QuasiQuoter where+  yeshWith backend =+    QuasiQuoter+      { quoteDec = yeshWith backend+      , quoteExp = yeshWith backend+      , quoteType = error "YeshQL does not generate types"+      , quotePat = error "YeshQL does not generate patterns"+      }+  yesh1With backend =+    QuasiQuoter+      { quoteDec = yesh1With backend+      , quoteExp = yesh1With backend+      , quoteType = error "YeshQL does not generate types"+      , quotePat = error "YeshQL does not generate patterns"+      }++instance YeshFile (String -> Q Exp) where+  yeshFileWith backend =+    withParsedQueriesFile $ \queries -> do+      yiExp $ yeshAllWith backend (Right queries)+  yesh1FileWith backend =+    withParsedQueryFile $ \query -> do+      yiExp $ yeshAllWith backend (Left query)++instance YeshFile (String -> Q [Dec]) where+  yeshFileWith backend =+    withParsedQueriesFile $ \queries -> do+      yiDecs $ yeshAllWith backend (Right queries)+  yesh1FileWith backend =+    withParsedQueryFile $ \query -> do+      yiDecs $ yeshAllWith backend (Left query)++instance YeshFile QuasiQuoter where+  yeshFileWith backend =+    QuasiQuoter+      { quoteDec = yeshFileWith backend+      , quoteExp = yeshFileWith backend+      , quoteType = error "YeshQL does not generate types"+      , quotePat = error "YeshQL does not generate patterns"+      }+  yesh1FileWith backend =+    QuasiQuoter+      { quoteDec = yesh1FileWith backend+      , quoteExp = yesh1FileWith backend+      , quoteType = error "YeshQL does not generate types"+      , quotePat = error "YeshQL does not generate patterns"+      }++-- | This is where much of the magic happens: this function asks the backend+-- for some building blocks, and assembles a 'YeshImpl' of the provided query+-- or queries.+yeshAllWith :: YeshBackend -> Either ParsedQuery [ParsedQuery] -> YeshImpl+yeshAllWith backend (Left query) =+  let (argNames, patterns, funName, queryType) = ybNames backend query+      bodyQ = ybMkQueryBody backend query+      expr = sigE+              (lamE patterns bodyQ)+              queryType+      decs = do+        sRun <- sigD (mkName . lcfirst $ funName)+                    queryType+        fRun <- funD (mkName . lcfirst $ funName)+                    [ clause+                        (map varP argNames)+                        (normalB bodyQ)+                        []+                    ]+        return [sRun, fRun]+  in+    YeshImpl+      { yiDecs = decs+      , yiExp = expr+      }+yeshAllWith backend (Right queries) =+  foldYeshImpls $ map (yeshAllWith backend . Left) queries++describeBackend :: YeshBackend+describeBackend =+  YeshBackend+    { ybNames = \q -> ([], [], queryIdentifier "describe" (pqQueryName q), [t|String|])+    , ybMkQueryBody = litE . stringL . pqQueryString+    }++docBackend :: YeshBackend+docBackend =+  YeshBackend+    { ybNames = \q -> ([], [], queryIdentifier "doc" (pqQueryName q), [t|String|])+    , ybMkQueryBody = litE . stringL . pqDocComment+    }

@@ -0,0 +1,258 @@+{-#LANGUAGE TemplateHaskell #-}+{-#LANGUAGE CPP #-}+{-#LANGUAGE RankNTypes #-}+{-#LANGUAGE FlexibleInstances #-}+{-|+Module: Database.YeshQL+Description: Turn SQL queries into type-safe functions.+Copyright: (c) 2015-2017 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.++= Note++The descriptions provided below outline general usage, and assume that one of+the backends (e.g. @yeshql-hdbc@) is being used, and its top-level module (e.g.+@Database.YeshQL.HDBC@) has been imported.++= Usage++The main workhorses are 'yesh1' (to define one query) and 'yesh' (to define+multiple queries).++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++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 => String -> conn -> 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+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 :: rowcount 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+    |]+@++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+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 (Maybe 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 ().+- The keyword 'rowcount', followed by 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 'Maybe' of such tuples, or always+  'Nothing' for other query types. For example, @:: (String, Int)@ produces+  a function whose type ends in @conn -> IO (Maybe (String, Int))@. Null-tuples+  are marshalled to '()', ignoring result sets; one-tuples (written as @(a)@)+  are marshalled to scalars.+- A naked type, i.e., just a type name, without parentheses. The type must+  implement 'FromSqlRow'; the return type will be a 'Maybe' of that type. E.g.,+  @(:: User)@ will produce a function signature ending in+  @conn -> IO (Maybe User)@.+- A list of tuples or naked types, written using square brackets (@[@ ... @]@),+  returning a list of mapped rows instead of a 'Maybe'.++Note that, unlike Haskell, YeshQL distinguishes @(Foo)@ from @Foo@: the former+takes the first column from a result row and maps it using 'FromSql', while the+latter takes the entire result row and maps it using 'FromSqlRow'.++@+    -- :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 => Integer -> String -> conn -> IO [(Integer, String)]+getUserEx id filename conn =+    -- ... generated implementation left out+@++On top of referencing parameters directly, you can also "drill down" with a+projection function, using @.@ syntax similar to property access in, say,+JavaScript. The intended use case is passing record types as arguments to+the query function, and then dereferencing them inside the query, like so:++@+    -- name:updateUser :: rowcount Int+    -- :user :: User+    UPDATE users+    SET username  = :user.name+    WHERE id = :user.userID+@++Note that the part after the @.@ is a plain Haskell function that must be in+scope wherever the query is spliced.++Also note that projection functions can be chained, and are not limited to+record field accessors.++== 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.++== 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+@DESCRIBE@ feature in some RDBMS systems), and another 'String' variable+prefixed @doc-@, which contains all the free-form comments that precede the SQL+query in the query definition.++So for example, this quasiquotation:++@+[yesh1|+    -- name:getUser :: User+    -- :userID :: Integer+    -- Gets one user by the "id" column.+    SELECT id, username FROM users WHERE id = :userID LIMIT 1 |]+@++...would produce the following three top-level definitions:++@+getUser :: IConnection conn => Integer -> conn -> IO (Maybe User)+getUser userID conn = ...++describeGetUser :: String+describeGetUser = \"SELECT id, username FROM users WHERE id = ? LIMIT 1\"++docGetUser :: String+docGetUser = \"Gets one user by the \\\"id\\\" column.\"+@++ -}+module Database.YeshQL.Core+(+-- * Query parsers+  parseQuery+, parseQueries+-- * AST+, ParsedQuery (..)+)+where++import Database.YeshQL.Parser

@@ -0,0 +1,340 @@+module Database.YeshQL.Parser+( parseQuery+, parseQueries+, parseQueryN+, parseQueriesN+, ParsedQuery (..)+, ParsedType (..)+, ParsedReturnType (..)+, ExtractedParam (..)+, OneOrMany (..)+, 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, Eq)++data OneOrMany = One | Many+    deriving (Show, Eq, Enum, Ord)++data ParsedReturnType = ReturnRowCount ParsedType+                      | ReturnTuple OneOrMany [ParsedType]+                      | ReturnRecord OneOrMany ParsedType+                      deriving (Show, Eq)++data ExtractedParam =+    ExtractedParam+        { paramName :: String+        , paramProjections :: [String]+        , paramType :: ParsedType+        }+        deriving (Show, Eq)++data ParsedQuery =+    ParsedQuery+        { pqQueryName :: String+        , pqQueryString :: String+        , pqParamsRaw :: [ExtractedParam]+        , pqParamNames :: [String]+        , pqParamTypes :: Map String ParsedType+        , pqReturnType :: ParsedReturnType+        , pqDocComment :: String+        , pqDDL :: Bool+        }+        deriving (Show, Eq)++pqTypeFor :: ParsedQuery -> String -> Maybe ParsedType+pqTypeFor q pname = Map.lookup pname (pqParamTypes q)++parsedQuery :: String+            -> String+            -> [ExtractedParam]+            -> [ExtractedParam]+            -> ParsedReturnType+            -> String+            -> Bool+            -> ParsedQuery+parsedQuery queryName+            queryString+            paramsRaw+            paramsExtra+            returnType+            docComment+            isDDL =+    ParsedQuery+        queryName+        queryString+        paramsRaw+        (extractParamNames (paramsExtra ++ paramsRaw))+        (extractParamTypeMap (paramsExtra ++ paramsRaw))+        returnType+        docComment+        isDDL++extractParamNames :: [ExtractedParam] -> [String]+extractParamNames xs =+    nub . map paramName $ xs++extractParamTypeMap :: [ExtractedParam] -> Map String ParsedType+extractParamTypeMap = foldl' applyItem Map.empty+    where+        applyItem :: Map String ParsedType -> ExtractedParam -> Map String ParsedType+        applyItem m (ExtractedParam 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+                | ParsedParamAttrib String [String] ParsedType+                | ParsedComment String+                | ParsedAnnotation Annotation+                deriving (Show)++data Annotation =+    DDLAnnotation+    deriving (Show)++extractParsedQuery :: [ParsedItem] -> String+extractParsedQuery = concat . map extractItem+    where+        extractItem :: ParsedItem -> String+        extractItem (ParsedLiteral str) = str+        extractItem (ParsedComment _) = ""+        extractItem (ParsedParam _ _) = "?"+        extractItem (ParsedParamAttrib _ _ _) = "?"++extractParsedParams :: [ParsedItem] -> [ExtractedParam]+extractParsedParams = catMaybes . map extractItem+    where+        extractItem :: ParsedItem -> Maybe ExtractedParam+        extractItem (ParsedParam n t) = Just $ ExtractedParam n [] t+        extractItem (ParsedParamAttrib n p t) = Just $ ExtractedParam n p t+        extractItem _ = Nothing++extractDocComment :: [ParsedItem] -> String+extractDocComment = unlines . catMaybes . map extractItem+    where+        extractItem :: ParsedItem -> Maybe String+        extractItem (ParsedComment str) = Just str+        extractItem _ = Nothing++extractIsDDL :: [ParsedItem] -> Bool+extractIsDDL items =+    not . null $ [ undefined | ParsedAnnotation DDLAnnotation <- items ]++parseQueryN :: String -> String -> Either ParseError ParsedQuery+parseQueryN fn src =+    runParser mainP () fn src++parseQuery :: String -> Either ParseError ParsedQuery+parseQuery = parseQueryN ""++parseQueriesN :: String -> String -> Either ParseError [ParsedQuery]+parseQueriesN fn src =+    runParser multiP () fn src++parseQueries :: String -> Either ParseError [ParsedQuery]+parseQueries = parseQueriesN ""++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 >> string ";;;" >> 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 ("", ReturnRowCount (PlainType "Integer")) $ nameDeclP <|> namelessDeclP+    extraItems <- many (try annotationP <|> paramDeclP <|> commentP)+    items <- many (try itemP <|> try commentP)+    return $ parsedQuery+                qn+                (extractParsedQuery items)+                (extractParsedParams items)+                (extractParsedParams extraItems)+                retType+                (extractDocComment (extraItems ++ items))+                (extractIsDDL (extraItems ++ items))++nameDeclP :: Parsec String () (String, ParsedReturnType)+nameDeclP = do+    try (whitespaceP >> string "--" >> whitespaceP >> string "name" >> whitespaceP >> char ':')+    whitespaceP+    qn <- identifierP+    whitespaceP+    retType <- option (ReturnRowCount (PlainType "Integer")) (try (string "::" >> whitespaceP >> returnTypeP))+    whitespaceP+    newlineP+    return (qn, retType)++namelessDeclP :: Parsec String () (String, ParsedReturnType)+namelessDeclP = do+    try (whitespaceP >> string "--" >> whitespaceP >> string "::" >> whitespaceP)+    retType <- returnTypeP+    whitespaceP+    newlineP+    return ("", 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 () ParsedReturnType+returnTypeP = returnTypeRowcountP <|> returnTypeMultiP <|> returnTypeSingleP++returnTypeRowcountP :: Parsec String () ParsedReturnType+returnTypeRowcountP = do+    try (string "rowcount")+    whitespaceP+    ReturnRowCount <$> typeP++setNumerus :: OneOrMany -> ParsedReturnType -> ParsedReturnType+setNumerus _ (ReturnRowCount t) = ReturnRowCount t+setNumerus numerus (ReturnTuple _ x) = ReturnTuple numerus x+setNumerus numerus (ReturnRecord _ x) = ReturnRecord numerus x++returnTypeMultiP :: Parsec String () ParsedReturnType+returnTypeMultiP =+    setNumerus Many <$> between+        (char '[' >> whitespaceP)+        (char ']' >> whitespaceP)+        returnTypeRowP++returnTypeSingleP :: Parsec String () ParsedReturnType+returnTypeSingleP =+    setNumerus One <$> returnTypeRowP++returnTypeRowP :: Parsec String () ParsedReturnType+returnTypeRowP =+    fmap (ReturnTuple One) returnTypeTupleP <|> +    fmap (ReturnRecord One) typeP++returnTypeTupleP :: Parsec String () [ParsedType]+returnTypeTupleP =+    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 <|> 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 ':')+    name <- identifierP+    whitespaceP+    t <- option AutoType $ do+            string "::"+            whitespaceP *> typeP <* whitespaceP+    newlineP+    return $ ParsedParam name t++projectionP :: Parsec String () String+projectionP = char '.' *> identifierP++commentP :: Parsec String () ParsedItem+commentP = do+    try (whitespaceP >> string "--")+    whitespaceP+    ParsedComment <$> manyTill anyChar newlineP++paramP :: Parsec String () ParsedItem+paramP = do+    char ':'+    pname <- identifierP+    projections <- many projectionP+    ptype <- option AutoType $ do+                string "::"+                typeP+    if null projections+        then return $ ParsedParam pname ptype+        else return $ ParsedParamAttrib pname projections 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 ()++whitespace1P :: Parsec String () ()+whitespace1P = do+    many1 (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 ()

@@ -0,0 +1,121 @@+{-#LANGUAGE TemplateHaskell #-}+{-#LANGUAGE CPP #-}+{-#LANGUAGE RankNTypes #-}+{-#LANGUAGE FlexibleInstances #-}+module Database.YeshQL.Util+where++import Database.YeshQL.Parser+import Language.Haskell.TH+import Language.Haskell.TH.Quote+#if MIN_VERSION_template_haskell(2,7,0)+import Language.Haskell.TH.Syntax (Quasi(qAddDependentFile))+#endif+import Data.Char (toLower, toUpper, isAlpha, isAlphaNum, chr, ord)+import System.FilePath (takeBaseName)++queryName :: String -> String -> Name+queryName prefix = mkName . queryIdentifier prefix++queryIdentifier :: String -> String -> String+queryIdentifier "" basename =+    lcfirst . makeValidIdentifier . takeBaseName $ basename+queryIdentifier prefix basename =+    (prefix ++) . ucfirst . makeValidIdentifier . takeBaseName $ basename++ucfirst :: String -> String+ucfirst "" = ""+ucfirst (x:xs) = toUpper x:xs++lcfirst :: String -> String+lcfirst "" = ""+lcfirst (x:xs) = toLower x:xs++makeValidIdentifier :: String -> String+makeValidIdentifier =+    filter isAlphaNum .+    dropWhile (not . isAlpha)++headMay :: [a] -> Maybe a+headMay [] = Nothing+headMay (x:_) = Just x++nthIdent :: Int -> String+nthIdent i+    | i < 26 = [chr (ord 'a' + i)]+    | otherwise = let (j, k) = divMod i 26+                    in nthIdent j ++ nthIdent k++nameQuery :: String -> ParsedQuery -> ParsedQuery+nameQuery qname pq+    | null (pqQueryName pq) = pq { pqQueryName = qname }+    | otherwise = pq++nameQueries :: String -> [ParsedQuery] -> [ParsedQuery]+nameQueries basename queries =+    zipWith nameQuery queryNames queries+    where+        queryNames = [ basename ++ "_" ++ show i | i <- [0..] ]++withParsedQuery :: (MonadPerformIO m, Monad m)+                => (ParsedQuery -> m a) -> String -> m a+withParsedQuery = withParsed parseQuery++withParsedQueries :: (MonadPerformIO m, Monad m)+                  => ([ParsedQuery] -> m a) -> String -> m a+withParsedQueries = withParsed parseQueries++withParsedQueryFile :: (MonadPerformIO m, Monad m)+                    => (ParsedQuery -> m a) -> FilePath -> m a+withParsedQueryFile p fn =+    withParsedFile+        (parseQueryN fn)+        (p . nameQuery (queryIdentifier "" fn))+        fn++withParsedQueriesFile :: (MonadPerformIO m, Monad m)+                      => ([ParsedQuery] -> m a) -> FilePath -> m a+withParsedQueriesFile p fn =+    withParsedFile+        (parseQueriesN fn)+        (p . nameQueries (queryIdentifier "" fn))+        fn++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++-- | Monad in which we can perform IO and tag dependencies. Mostly needed+-- because we cannot easily make a 'MonadIO' instance for 'Q', and also+-- because we want to avoid a dependency on mtl or transformers. For+-- convenience, we also pull 'addDependentFile' into this typeclass.+class MonadPerformIO m where+    performIO :: IO a -> m a+    addDependentFile :: FilePath -> m ()++instance MonadPerformIO IO where+    performIO = id+    -- in IO, don't try to track dependencies+    addDependentFile = const $ return ()++instance MonadPerformIO Q where+    performIO = runIO+#if MIN_VERSION_template_haskell(2,7,0)+    -- modern GHC: proper implementation+    addDependentFile = qAddDependentFile+#else+    -- ancient GHC: ignore dependency+    addDependentFile = const $ return ()+#endif++withParsedFile :: (MonadPerformIO m, Monad m, Show e) => (String -> Either e a) -> (a -> m b) -> FilePath -> m b+withParsedFile p a filename =+    addDependentFile filename >>+    performIO (readFile filename) >>=+        withParsed p a+

@@ -0,0 +1,44 @@+{-#LANGUAGE QuasiQuotes #-}+{-#LANGUAGE RankNTypes #-}+{-#LANGUAGE LambdaCase #-}+{-#LANGUAGE TemplateHaskell #-}+module Database.YeshQL.ParserTests+( tests+)+where++import Test.Tasty+import Test.Tasty.HUnit+import Database.YeshQL+import Database.YeshQL.Parser+import qualified Data.Map as Map++tests =+  [ testAllTheThings+  ]++testAllTheThings :: TestTree+testAllTheThings =+  testCase "all parser features" $+    assertEqual "" expected actual+    where+      actual = parseQuery query+      query = unlines+        [ "-- name:perfectlyNormal :: (Integer)"+        , "-- A completely normal query."+        , "-- One more free-form comment."+        , "-- :username :: String"+        , "SELECT id FROM users WHERE username = :username"+        ]+      expected =+        Right ParsedQuery+          { pqQueryName = "perfectlyNormal"+          , pqQueryString = "SELECT id FROM users WHERE username = ?\n"+          , pqParamsRaw = [ExtractedParam "username" [] AutoType]+          , pqParamNames = ["username"]+          , pqParamTypes = Map.fromList [("username", PlainType "String")]+          , pqReturnType = ReturnTuple One [PlainType "Integer"]+          , pqDocComment = "A completely normal query.\nOne more free-form comment.\n"+          , pqDDL = False+          }+    

@@ -0,0 +1,12 @@+{-#LANGUAGE TemplateHaskell #-}+{-#LANGUAGE QuasiQuotes #-}+module Main where++import Test.Tasty+import qualified Database.YeshQL.ParserTests as ParserTests++main = defaultMain allTests+    where+        allTests = testGroup "All Tests"+            [ testGroup "Parser Tests" ParserTests.tests+            ]

@@ -0,0 +1,49 @@+name: yeshql-core+version: 4.1.0.0+synopsis: YesQL-style SQL database abstraction (core)+description: Use quasi-quotations or TemplateHaskell to write SQL in SQL, while+             adding type annotations to turn SQL into well-typed Haskell+             functions.+homepage: https://github.com/tdammers/yeshql+bug-reports: https://github.com/tdammers/yeshql/issues+license: MIT+license-file: LICENSE+author: Tobias Dammers+maintainer: tdammers@gmail.com+copyright: 2015-2017 Tobias Dammers and contributors+category: Database+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++source-repository head+  type: git+  location: https://github.com/tdammers/yeshql.git++library+    exposed-modules: Database.YeshQL.Core+                   , Database.YeshQL.Parser+                   , Database.YeshQL.Util+                   , Database.YeshQL.Backend+    -- other-extensions:+    build-depends: base >=4.6 && <5.0+                 , containers >= 0.5 && < 1.0+                 , filepath+                 , parsec >= 3.0 && <4.0+                 , template-haskell+                 , convertible >= 1.1.1.0 && <2+    hs-source-dirs: src+    default-language: Haskell2010+test-suite tests+    type: exitcode-stdio-1.0+    build-depends: base >=4.6 && <5.0+                 , yeshql-core+                 , containers+                 , stm+                 , tasty+                 , tasty-hunit+                 , tasty-quickcheck+    hs-source-dirs: tests+    main-is: tests.hs+    other-modules: Database.YeshQL.ParserTests+    default-language: Haskell2010