yeshql 3.0.1.3 → 4.1.0.0

raw patch · 13 files changed

+29/−1604 lines, 13 filesdep +yeshql-coredep +yeshql-hdbcdep −HDBCdep −containersdep −convertiblesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: yeshql-core, yeshql-hdbc

Dependencies removed: HDBC, containers, convertible, filepath, parsec, stm, tasty, tasty-hunit, tasty-quickcheck, template-haskell, yeshql

API changes (from Hackage documentation)

Files

• README.md +14/−0
• Setup.hs +0/−2
• src/Database/YeshQL.hs +4/−360
• src/Database/YeshQL/Parser.hs +0/−340
• src/Database/YeshQL/SqlRow/Class.hs +0/−64
• src/Database/YeshQL/SqlRow/TH.hs +0/−129
• tests/Database/HDBC/Mock.hs +0/−235
• tests/Database/YeshQL/SimulationTests.hs +0/−422
• tests/fixtures/getUser.sql +0/−3
• tests/fixtures/getUserNamed.sql +0/−3
• tests/fixtures/multiQueries.sql +0/−7
• tests/tests.hs +0/−12
• yeshql.cabal +11/−27

@@ -56,3 +56,17 @@  YeshQL is Free Software and provided as-is. Please see the enclosed LICENSE file for details.++## Legacy / Backwards-Compatibility Notice++**Note** that the `yeshql` package, starting with the 4.1 release, is now+merely a wrapper around `yeshql-core` and `yeshql-hdbc`, re-exporting what is+hopefully close enough to the original `yeshql` API to be somewhat compatible.++This is because starting with this release, `yeshql` has been split up into a+frontend, which takes care of query parsing and the whole TemplateHaskell+machinery, and several backends - at the time of writing, these are+`yeshql-hdbc`, which uses HDBC just like the original `yeshql` package, and+`yeshql-postgresql-simpel`, which uses `postgresql-simple`. With this+architecture, it is possible to add more backends without affecting the+frontend or any of the other backends.

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -245,9 +245,6 @@   Yesh (..) -- * Quasi-quoters that take filenames , YeshFile (..)--- * Low-level generators in the 'Q' monad-, mkQueryDecs-, mkQueryExp -- * Query parsers , parseQuery , parseQueries@@ -256,361 +253,8 @@ ) 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 Data.List (isPrefixOf, foldl')-import Data.Maybe (catMaybes, fromMaybe)-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 ( (<$>), (<*>) )-import System.FilePath (takeBaseName)-import Data.Char (isAlpha, isAlphaNum)-+import Database.YeshQL.Core+import Database.YeshQL.Backend import Database.YeshQL.Parser-import Database.YeshQL.SqlRow.Class--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---- | This typeclass is needed to allow 'yesh' and 'yesh1' to be used--- interchangeably as quasi-quoters and TH functions.  Because the intended--- instances are @String -> Q [Dec]@ and @QuasiQuoter@, it is unfortunately not--- possible to give the methods more obvious signatures like @String -> a@.-class Yesh a where-    -- | 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 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---- | This typeclass is needed to allow 'yeshFile' and 'yesh1File' to be used--- interchangeably as quasi-quoters and TH functions.--- Because the intended instances are @FilePath -> Q [Dec]@ and @QuasiQuoter@,--- it is unfortunately not possible to give the methods more obvious signatures--- like @FilePath -> a@.-class YeshFile a where-    -- | 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--    -- | 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:-    ---    -- 1. Take only the basename (stripping off the directories and extension)-    -- 2. Remove all non-alphabetic characters from the beginning of the name-    -- 3. Remove all non-alphanumeric characters from the name-    -- 4. 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--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"-            }--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-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--withParsedQuery :: (ParsedQuery -> Q a) -> String -> Q a-withParsedQuery = withParsed parseQuery--withParsedQueries :: ([ParsedQuery] -> Q a) -> String -> Q a-withParsedQueries = withParsed parseQueries--withParsedQueryFile :: (ParsedQuery -> Q a) -> FilePath -> Q a-withParsedQueryFile p fn =-    withParsedFile-        (parseQueryN fn)-        (p . nameQuery (queryIdentifier "" fn))-        fn--withParsedQueriesFile :: ([ParsedQuery] -> Q a) -> FilePath -> Q a-withParsedQueriesFile p fn =-    withParsedFile-        (parseQueriesN fn)-        (p . nameQueries (queryIdentifier "" fn))-        fn--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..] ]--makeValidIdentifier :: String -> String-makeValidIdentifier =-    filter isAlphaNum .-    dropWhile (not . isAlpha)--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--pgQueryType :: ParsedQuery -> TypeQ-pgQueryType query =-    [t|forall conn. IConnection conn =>-        $(foldr-            (\a b -> [t| $a -> $b |])-            [t| conn -> IO $(returnType) |]-          $ argTypes)-      |]-    where-        argTypes = map (mkType . fromMaybe AutoType . pqTypeFor query) (pqParamNames query)-        returnType =-            if pqDDL query-                then-                    tupleT 0-                else-                    case pqReturnType query of-                        ReturnRowCount tn -> mkType tn-                        ReturnTuple One [] -> tupleT 0-                        ReturnTuple One (x:[]) -> appT [t|Maybe|] $ mkType x-                        ReturnTuple One xs -> appT [t|Maybe|] $ foldl' appT (tupleT $ length xs) (map mkType xs)-                        ReturnTuple Many [] -> tupleT 0-                        ReturnTuple Many (x:[]) -> appT listT $ mkType x-                        ReturnTuple Many xs -> appT listT $ foldl' appT (tupleT $ length xs) (map mkType xs)-                        ReturnRecord One x -> appT [t|Maybe|] $ mkType x-                        ReturnRecord Many x -> appT listT $ mkType x--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---- TODO: instead of sequencing the queries, put them in a tuple.-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-                    ReturnRowCount tn -> varE 'fromInteger-                    ReturnTuple _ [] -> [|\_ -> ()|]-                    ReturnTuple _ (x:[]) -> [|map (fromSql . head)|]-                    ReturnTuple _ 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)))|]-                    ReturnRecord _ x -> [|fromSqlRow|]-        queryFunc = case pqReturnType query of-                        ReturnRowCount _ ->-                            [| \qstr params conn -> $convert <$> run conn qstr params |]-                        ReturnTuple Many _ ->-                            [| \qstr params conn -> $convert <$> quickQuery' conn qstr params |]-                        ReturnTuple One _ ->-                            [| \qstr params conn -> fmap headMay $ $convert <$> quickQuery' conn qstr params |]-                        ReturnRecord Many _ ->-                            [| \qstr params conn -> mapM $convert =<< quickQuery' conn qstr params |]-                        ReturnRecord One _ ->-                            [| \qstr params conn -> fmap headMay $ mapM $convert =<< quickQuery' conn qstr params |]-        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 (map paramArg $ pqParamsRaw query))-                `appE` (varE . mkName $ "conn")--    where-        paramArg :: ExtractedParam -> ExpQ-        paramArg (ExtractedParam n ps _) = do-            let valE = foldl1 (flip appE) (map (varE . mkName) (n:ps))-            varE 'toSql `appE` valE+import Database.YeshQL.HDBC+import Database.YeshQL.HDBC.SqlRow.Class

@@ -1,340 +0,0 @@-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--data OneOrMany = One | Many-    deriving (Show, Eq, Enum, Ord)--data ParsedReturnType = ReturnRowCount ParsedType-                      | ReturnTuple OneOrMany [ParsedType]-                      | ReturnRecord OneOrMany ParsedType-                      deriving (Show)--data ExtractedParam =-    ExtractedParam-        { paramName :: String-        , paramProjections :: [String]-        , paramType :: ParsedType-        }-        deriving (Show)--data ParsedQuery =-    ParsedQuery-        { pqQueryName :: String-        , pqQueryString :: String-        , pqParamsRaw :: [ExtractedParam]-        , pqParamNames :: [String]-        , pqParamTypes :: Map String ParsedType-        , pqReturnType :: ParsedReturnType-        , pqDocComment :: String-        , pqDDL :: Bool-        }-        deriving (Show)--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 (noneOf " \t\n;") 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 ()

@@ -1,64 +0,0 @@-{-#LANGUAGE OverloadedStrings #-}-{-#LANGUAGE DeriveGeneric #-}-{-#LANGUAGE DeriveFunctor #-}-{-#LANGUAGE GeneralizedNewtypeDeriving #-}-{-#LANGUAGE LambdaCase #-}-{-#LANGUAGE TemplateHaskell #-}-{-#LANGUAGE MultiParamTypeClasses #-}-{-#LANGUAGE FlexibleContexts #-}-module Database.YeshQL.SqlRow.Class-where--import Database.HDBC-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-    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)

@@ -1,129 +0,0 @@-{-#LANGUAGE OverloadedStrings #-}-{-#LANGUAGE DeriveGeneric #-}-{-#LANGUAGE TemplateHaskell #-}-{-#LANGUAGE QuasiQuotes #-}-{-#LANGUAGE LambdaCase #-}-{-#LANGUAGE CPP #-}-module Database.YeshQL.SqlRow.TH-( makeSqlRow-)-where--import Database.YeshQL.SqlRow.Class-import Database.HDBC (fromSql, toSql)-import Language.Haskell.TH-import Language.Haskell.TH.Quote--makeSqlRow :: Name -> Q [Dec]-makeSqlRow entityName = do-    (TyConI d) <- reify entityName-    (typeName, _, constructors) <- typeInfo d--    (constructorName, fieldNames, fieldTypes) <--        case constructors of-            [(constructorName, _, Just fieldNames, fieldTypes)] ->-                return (constructorName, fieldNames, fieldTypes)-            _ -> fail "Unsuitable type for deriving SqlRow"--    [d|-        instance ToSqlRow $(conT typeName) where-            toSqlRow entity =-                $(listE $ map (toSqlRowField 'entity) fieldNames)--        instance FromSqlRow $(conT typeName) where-            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-        toSqlRowField entityName fieldName =-            appE [|toSql|] $ appE (varE fieldName) (varE entityName)--        fromSqlPatternItem :: Name -> PatQ-        fromSqlPatternItem fieldName =-            varP (mkName $ "sql_" ++ nameBase fieldName)--        fromSqlPatternArg :: Name -> ExpQ-        fromSqlPatternArg fieldName =-            appE-                (varE (mkName "fromSql"))-                (varE (mkName $ "sql_" ++ nameBase fieldName))--{---Subsequent code taken from syb-with-class, under the following license:--Copyright (c)       2004 - 2008 The University of Glasgow, CWI,-                                Simon Peyton Jones, Ralf Laemmel,-                                Ulf Norell, Sean Seefried, Simon D. Foster,-                                HAppS LLC--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-1. Redistributions of source code must retain the above copyright-   notice, this list of conditions and the following disclaimer.-2. 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.-3. Neither the name of the author nor the names of his contributors-   may be used to endorse or promote products derived from this software-   without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.---}--type Constructor =-  (Name,         -- Name of the constructor-   Int,          -- Number of constructor arguments-   Maybe [Name], -- Name of the field selector, if any-   [Type])       -- Type of the constructor argument--typeInfo :: Dec-         -> Q (Name,            -- Name of the datatype-               [Name],          -- Names of the type parameters-               [Constructor])   -- The constructors-typeInfo d-        = case d of-#if MIN_VERSION_template_haskell(2,11,0)-            DataD    _ n ps _ cs _ -> return (n, map varName ps, map conA cs)-            NewtypeD _ n ps _ c  _ -> return (n, map varName ps, [conA c])-#else-            DataD    _ n ps cs _ -> return (n, map varName ps, map conA cs)-            NewtypeD _ n ps c  _ -> return (n, map varName ps, [conA c])-#endif-            _ -> error ("derive: not a data type declaration: " ++ show d)-        where-            conA (NormalC c xs) = (c, length xs, Nothing, map snd xs)-            conA (InfixC x1 c x2) = conA (NormalC c [x1, x2])-            conA (ForallC _ _ c) = conA c-            conA (RecC c xs) =-                    let getField (n, _, _) = n-                        getType  (_, _, t) = t-                        fields = map getField xs-                        types  = map getType xs-                    in (c, length xs, Just fields, types)-            varName (PlainTV n) = n-            varName (KindedTV n _) = n

@@ -1,235 +0,0 @@--- | Mock HDBC database connection for unit testing purposes.-module Database.HDBC.Mock-( --- * Mock Connections-  MockConnection (..)-, defMockConnection--- * Logging interaction-, loggingConnection--- * Chat Scripts-, newChatConnection-, ChatStep (..)--- * Constraints--- The Contraint API is a minilanguage for declaring and combining constraints--- on arbitrary values.-, Constraint--- | Construct a constraint from a raw predicate.-, constraint--- | Check a constraint against a value.-, check--- | Check a list of constraints against a list of values.-, checkAll--- | A constraint that matches a value exactly (as per 'Eq' / '==')-, exactly--- | A constraint that matches a value by a comparison function-, sameBy--- | A constraint that matches a value exactly after applying some pre-processing-, sameThrough--- | A constraint that matches any value-, anything--- | The inclusive-OR operator on 'Constraint's.-, (<||>)-)-where--import Database.HDBC-            ( IConnection (..)-            , SqlValue (..)-            , SqlColDesc (..)-            )-import Database.HDBC.Statement-            ( Statement (..)-            )-import Control.Monad (forM_, when)-import Control.Concurrent.STM (atomically, STM)-import Control.Concurrent.STM.TChan-    ( TChan-    , newTChan-    , writeTChan-    , readTChan-    , tryReadTChan-    , newTChanIO-    )--data MockConnection =-    MockConnection-        { mockDisconnect :: IO ()-        , mockCommit :: IO ()-        , mockRollback :: IO ()-        , mockRun :: String -> [SqlValue] -> IO Integer-        , mockPrepare :: String -> IO Statement-        , mockClone :: IO MockConnection-        , mockTransactionSupport :: Bool-        , mockGetTables :: IO [String]-        , mockDescribeTable :: String -> IO [(String, SqlColDesc)]-        }--defMockConnection :: MockConnection-defMockConnection =-    MockConnection-        { mockDisconnect = return ()-        , mockCommit = return ()-        , mockRollback = return ()-        , mockRun = \q p -> fail "'run' method not implemented"-        , mockPrepare = \q -> fail "'prepare' method not implemented"-        , mockClone = fail "'clone' method not implemented"-        , mockTransactionSupport = False-        , mockGetTables = return []-        , mockDescribeTable = const $ return []-        }--instance IConnection MockConnection where-    disconnect = mockDisconnect-    commit = mockCommit-    rollback = mockRollback-    run = mockRun-    prepare = mockPrepare-    clone = mockClone-    hdbcDriverName = const "mock"-    hdbcClientVer = const "0.0"-    dbServerVer = const "0.0"-    dbTransactionSupport = mockTransactionSupport-    getTables = mockGetTables-    describeTable = mockDescribeTable--tee :: (a -> IO ()) -> IO a -> IO a-tee sideChannel action = do-    retval <- action-    sideChannel retval-    return retval--loggingStatement :: String -> (String -> IO ()) -> Statement -> Statement-loggingStatement query log stmt =-    stmt-        { execute = \params -> do-            log $ "execute " ++ show query ++ " with " ++ show params-            tee (log . show) $ execute stmt params-        , executeRaw = do-            log $ "executeRaw " ++ show query-            tee (log . show) $ executeRaw stmt-        , executeMany = \rows -> do-            log $ "executeMany " ++ show query ++ " with: "-            forM_ rows $ \params -> log $ "    " ++ show params-            tee (log . show) $ executeMany stmt rows-        , finish = do-            log $ "finish"-            finish stmt-        }--loggingConnection :: IConnection conn => (String -> IO ()) -> conn -> MockConnection-loggingConnection log conn =-    defMockConnection-        { mockDisconnect = do-            log "disconnect"-            disconnect conn-        , mockCommit = do-            log "commit"-            commit conn-        , mockRollback = do-            log "rollback"-            rollback conn-        , mockRun = \q p -> do-            log $ "run " ++ show q ++ " with " ++ show p-            tee (log . show) $ run conn q p-        , mockPrepare = \q -> do-            log $ "prepare " ++ show q-            loggingStatement q log <$> prepare conn q-        , mockClone = do-            log $ "clone"-            loggingConnection log <$> clone conn-        , mockTransactionSupport = dbTransactionSupport conn-        , mockGetTables = do-            log $ "getTables"-            tee (log . show) $ getTables conn-        , mockDescribeTable = \tbl -> do-            log $ "describeTable " ++ tbl-            tee (log . show) $ describeTable conn tbl-        }--tChanFromList :: [a] -> IO (TChan a)-tChanFromList xs = atomically $ do-    newTChan >>= fillTChanFromList xs--fillTChanFromList :: [a] -> (TChan a) -> STM (TChan a)-fillTChanFromList xs c = do-    forM_ xs $ writeTChan c-    return c--newtype Constraint a = Constraint { check :: a -> Bool }--instance Monoid (Constraint a) where-    mempty = anything-    mappend (Constraint a) (Constraint b) =-        Constraint (\x -> a x && b x)--(<||>) :: Constraint a -> Constraint a -> Constraint a-a <||> b = Constraint $ \x -> check a x || check b x--constraint :: (a -> Bool) -> Constraint a-constraint = Constraint--exactly :: Eq a => a -> Constraint a-exactly = sameBy (==)--sameThrough :: Eq a => (a -> a) -> a -> Constraint a-sameThrough pp lhs = constraint $ \rhs -> pp lhs == pp rhs--sameBy :: (a -> a -> Bool) -> a -> Constraint a-sameBy cmp val = constraint $ cmp val--anything :: Constraint a-anything = constraint (const True)--data ChatStep =-    ChatStep-        { chatQuery :: Constraint String-        , chatParams :: [Constraint SqlValue]-        , chatResultSet :: [[SqlValue]]-        , chatColumnNames :: [String]-        , chatRowsAffected :: Integer-        }--checkAll :: [Constraint a] -> [a] -> Bool-checkAll constraints values =-    all id $ zipWith check constraints values--execChatStep :: String -> [SqlValue] -> TChan [SqlValue] -> ChatStep -> IO Integer-execChatStep query params resultChan step = do-    when (not $ check (chatQuery step) query) $-        fail $-            "Chat script mismatch: unexpected query:\n\t" ++-            query-    when (not $ checkAll (chatParams step) params) $-        fail $-            "Parameter mismatch: got " ++ show params-    atomically $ fillTChanFromList (chatResultSet step) resultChan-    return $ chatRowsAffected step--newChatConnection :: [ChatStep] -> IO MockConnection-newChatConnection steps = do-    c <- tChanFromList steps-    mkChatConnection c-    where-        mkChatConnection c =-            return $ defMockConnection-                { mockRun = \q p -> do-                    resultVar <- newTChanIO-                    step <- atomically $ readTChan c-                    execChatStep q p resultVar step-                , mockPrepare = \q -> do-                    resultVar <- newTChanIO-                    let exec p = do-                            atomically (readTChan c) >>= execChatStep q p resultVar-                    return $-                        Statement-                            { execute = exec-                            , executeRaw = exec [] >> return ()-                            , executeMany = \ps -> mapM exec ps >> return ()-                            , finish = return ()-                            , fetchRow = atomically $ tryReadTChan resultVar-                            , getColumnNames = return []-                            , originalQuery = q-                            , describeResult = return []-                            }-                , mockClone = mkChatConnection c-                }

@@ -1,422 +0,0 @@-{-#LANGUAGE QuasiQuotes #-}-{-#LANGUAGE RankNTypes #-}-{-#LANGUAGE LambdaCase #-}-{-#LANGUAGE TemplateHaskell #-}-module Database.YeshQL.SimulationTests-( tests-)-where--import Test.Tasty-import Test.Tasty.HUnit-import Database.HDBC-import Database.HDBC.Mock-import Database.YeshQL-import Database.YeshQL.SqlRow.Class-import Database.YeshQL.SqlRow.TH-import System.IO-import Data.Char-import Data.List (dropWhile, dropWhileEnd)--data User =-    User-        { userID :: Int-        , 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-    , testQueryFromFile-    , testQueryFromFileAutoName-    , testManyQueriesFromFileAutoName-    , testDDL-    ]--testSimpleSelect :: TestTree-testSimpleSelect = testCase "Simple SELECT" $ chatTest chatScript $ \conn -> do-    results <- [yesh|-        -- 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-                }-            ]--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|-        -- name:getUserByName :: (Integer, String)-        -- :username :: String-        SELECT id, username FROM users WHERE username = :username LIMIT 1|] "billy" conn-    let expected :: Maybe (Integer, String)-        expected = Just (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"]]-                , chatColumnNames = ["username"]-                , chatRowsAffected = 0-                }-            ]--testRecordReturn :: TestTree-testRecordReturn = testCase "Return record from SELECT" $ 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"]]-                , 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-                }-            ]--testRecordParams :: TestTree-testRecordParams = testCase "Pass records as params" $ chatTest chatScript $ \conn -> do-    actual <- [yesh|-        -- name:getUserByName :: User-        -- :user :: User-        SELECT id, username FROM users WHERE username = :user.userName.reverse LIMIT 1|]-        (User 10 "yllib")-        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"]]-                , chatColumnNames = ["username"]-                , chatRowsAffected = 0-                }-            ]--testSingleInsert :: TestTree-testSingleInsert = testCase "Single INSERT" $ chatTest chatScript $ \conn -> do-    actual <- [yesh|-        -- name:createUser :: (Integer)-        -- :username :: String-        INSERT INTO users (username) VALUES (:username) RETURNING id|] "billy" conn-    let expected :: Maybe Integer-        expected = Just 23-    assertEqual "" expected actual-    where-        chatScript =-            [ ChatStep-                { chatQuery = sameThrough trim "INSERT INTO users (username) VALUES (?) RETURNING id"-                , chatParams = [exactly $ toSql "billy"]-                , chatResultSet = [[toSql (23 :: Int)]]-                , chatColumnNames = ["id"]-                , chatRowsAffected = 1-                }-            ]--testUpdateReturnRowCount :: TestTree-testUpdateReturnRowCount = testCase "UPDATE, get row count" $ chatTest chatScript $ \conn -> do-    actual <- [yesh|-        -- name:renameUser :: rowcount Integer-        -- :oldName :: String-        -- :newName :: String-        UPDATE users SET username = :oldName WHERE username = :newName AND username <> :oldName|]-            "tony" "billy" conn-    let expected :: Integer-        expected = 1-    assertEqual "" expected actual-    where-        chatScript =-            [ ChatStep-                { chatQuery = sameThrough trim-                    "UPDATE users SET username = ? WHERE username = ? AND username <> ?"-                , chatParams =-                    [ exactly $ toSql "tony"-                    , exactly $ toSql "billy"-                    , exactly $ toSql "tony"-                    ]-                , chatResultSet = []-                , chatColumnNames = []-                , chatRowsAffected = 1-                }-            ]--[yesh|-    -- name:findUser :: (Int)-    -- :username :: String-    SELECT id FROM users WHERE username = :username-    ;;;-    -- name:setUserName :: rowcount Integer-    -- :userID :: Int-    -- :username :: String-    UPDATE users SET username = :username WHERE id = :userID-|]--testMultiQuery :: TestTree-testMultiQuery = testCase "Define multiple queries in one QQ inside a where" $ chatTest chatScript $ \conn -> do-    userID <- maybe (fail "User Not Found") return =<< findUser "billy" conn-    rowCount <- setUserName userID "tony" conn-    assertEqual "" rowCount 1-    where-        chatScript =-            [ ChatStep-                { chatQuery = sameThrough trim-                    "SELECT id FROM users WHERE username = ?"-                , chatParams =-                    [ exactly $ toSql "billy"-                    ]-                , chatResultSet = [[toSql (1 :: Int)]]-                , chatColumnNames = ["id"]-                , chatRowsAffected = 0-                }-            , ChatStep-                { chatQuery = sameThrough trim-                    "UPDATE users SET username = ? WHERE id = ?"-                , chatParams =-                    [ exactly $ toSql "tony"-                    , exactly $ toSql (1 :: Int)-                    ]-                , chatResultSet = []-                , chatColumnNames = []-                , chatRowsAffected = 1-                }-            ]--testQueryFromFile :: TestTree-testQueryFromFile = testCase "Query loaded from fixture file" $-        chatTest chatScript $ \conn -> do-            [(userID, username)] <- [yesh1File|tests/fixtures/getUserNamed.sql|] 1 conn-            assertEqual "" userID 1-            assertEqual "" username "billy"-    where-        chatScript =-            [ ChatStep-                { chatQuery = sameThrough trim-                    "SELECT id, username FROM users WHERE id = ?"-                , chatParams =-                    [ exactly $ toSql (1 :: Int)-                    ]-                , chatResultSet = [[toSql (1 :: Int), toSql "billy"]]-                , chatColumnNames = ["id", "username"]-                , chatRowsAffected = 0-                }-            ]--[yesh1File|tests/fixtures/getUser.sql|]--testQueryFromFileAutoName :: TestTree-testQueryFromFileAutoName = testCase "Query loaded from fixture file, deriving query name from filename" $-        chatTest chatScript $ \conn -> do-            [(userID, username)] <- getUser 1 conn-            assertEqual "" userID 1-            assertEqual "" username "billy"-    where-        chatScript =-            [ ChatStep-                { chatQuery = sameThrough trim-                    "SELECT id, username FROM users WHERE id = ?"-                , chatParams =-                    [ exactly $ toSql (1 :: Int)-                    ]-                , chatResultSet = [[toSql (1 :: Int), toSql "billy"]]-                , chatColumnNames = ["id", "username"]-                , chatRowsAffected = 0-                }-            ]--[yeshFile|tests/fixtures/multiQueries.sql|]--testManyQueriesFromFileAutoName :: TestTree-testManyQueriesFromFileAutoName = testCase "Many queries from fixture file, auto-naming some" $-        chatTest chatScript $ \conn -> do-            count0 <- multiQueries_0 conn-            count1 <- multiQueriesNamed conn-            count2 <- multiQueries_2 conn-            assertEqual "" count0 1-            assertEqual "" count1 2-            assertEqual "" count2 3-    where-        chatScript =-            [ ChatStep-                { chatQuery = sameThrough trim-                    "BLAH"-                , chatParams =-                    []-                , chatResultSet = []-                , chatColumnNames = []-                , chatRowsAffected = 1-                }-            , ChatStep-                { chatQuery = sameThrough trim-                    "PIZZA"-                , chatParams =-                    []-                , chatResultSet = []-                , chatColumnNames = []-                , chatRowsAffected = 2-                }-            , ChatStep-                { chatQuery = sameThrough trim-                    "OLIVES"-                , chatParams =-                    []-                , chatResultSet = []-                , chatColumnNames = []-                , chatRowsAffected = 3-                }-            ]--testDDL :: TestTree-testDDL = testCase "typical DDL statement sequence" $-        chatTest chatScript-        [yesh1|-            -- @ddl-            CREATE TABLE users-                ( id INTEGER-                , username TEXT-                );-            CREATE TABLE pages-                ( id INTEGER-                , owner_id INTEGER-                , title TEXT-                , body TEXT-                , FOREIGN KEY (owner_id) REFERENCES users (id)-                );-        |]-        where-            chatScript =-                [ ChatStep-                    { chatQuery = anything-                    , chatParams = []-                    , chatResultSet = []-                    , chatColumnNames = []-                    , chatRowsAffected = 0-                    }-                ]--chatTest :: [ChatStep] -> (forall conn. IConnection conn => conn -> IO ()) -> Assertion-chatTest chatScript action =-    newChatConnection chatScript >>= action--trim :: String -> String-trim = dropWhile isSpace . dropWhileEnd isSpace

@@ -1,3 +0,0 @@--- :: [(Int, String)]--- :userID :: Int-SELECT id, username FROM users WHERE id = :userID

@@ -1,3 +0,0 @@--- name:getUser :: [(Int, String)]--- :userID :: Int-SELECT id, username FROM users WHERE id = :userID

@@ -1,7 +0,0 @@--- :: rowcount Integer-BLAH-;;;--- name: multiQueriesNamed :: rowcount Integer-PIZZA-;;;-OLIVES

@@ -1,12 +0,0 @@-{-#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-            ]

@@ -1,46 +1,30 @@ name: yeshql-version: 3.0.1.3-synopsis: YesQL-style SQL database abstraction+version: 4.1.0.0+synopsis: YesQL-style SQL database abstraction (legacy compatibility wrapper) 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-2016 Tobias Dammers+copyright: 2015-2017 Tobias Dammers and contributors category: Database build-type: Simple extra-source-files: README.md-                  , tests/fixtures/*.sql cabal-version: >=1.10 +source-repository head+  type: git+  location: https://github.com/tdammers/yeshql.git+ library     exposed-modules: Database.YeshQL-                   , Database.YeshQL.SqlRow.Class-                   , Database.YeshQL.SqlRow.TH-    other-modules: Database.YeshQL.Parser     -- other-extensions:     build-depends: base >=4.6 && <5.0-                 , HDBC >= 2.4 && <3.0-                 , containers >= 0.5 && < 1.0-                 , filepath-                 , parsec >= 3.0 && <4.0-                 , template-haskell-                 , convertible >= 1.1.1.0 && <2+                 , yeshql-core+                 , yeshql-hdbc     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-    other-modules: Database.YeshQL.SimulationTests-                 , Database.HDBC.Mock     default-language: Haskell2010