diff --git a/MetaHDBC.cabal b/MetaHDBC.cabal --- a/MetaHDBC.cabal +++ b/MetaHDBC.cabal @@ -1,5 +1,5 @@ Name: MetaHDBC -Version: 0.1.2 +Version: 0.1.4 Cabal-version: >=1.6 Copyright: Mads Lindstrøm License: LGPL @@ -11,12 +11,12 @@ Description: Using Template Haskell and HDBC to do statically checked database access. -Tested-with: GHC==7.0.3 +Tested-with: GHC==7.8.2 Build-type: Simple Stability: experimental Library - Build-Depends: base >= 4 && < 5, mtl,HDBC>=2.2.7.0,HDBC-odbc>=2.2.3.0,template-haskell>=2.2.5.0,convertible>=1.0.10.0 + Build-Depends: base >= 4.7 && < 5, mtl,HDBC >= 2.2.7.0,HDBC-odbc >= 2.2.3.0 && < 2.4.0.0,template-haskell>=2.2.5.0,convertible>=1.0.10.0,hashtables>=1.2.0.0 Ghc-options: -Wall Exposed-modules: Database.MetaHDBC diff --git a/src/Database/MetaHDBC/Connection.hs b/src/Database/MetaHDBC/Connection.hs --- a/src/Database/MetaHDBC/Connection.hs +++ b/src/Database/MetaHDBC/Connection.hs @@ -4,7 +4,7 @@ import Database.HDBC as HDBC import Database.HDBC.ODBC as HDBC -import qualified Data.HashTable as M +import qualified Data.HashTable.IO as M import Control.Concurrent.MVar {- Caching prepared statements @@ -81,15 +81,17 @@ -} +type HashTable k v = M.BasicHashTable k v + data CachingConnection = CachingConnection { hdbcConnection :: HDBC.Connection - , statementMap :: MVar (M.HashTable String HDBC.Statement) + , statementMap :: MVar (HashTable String HDBC.Statement) } cachingConnection :: String -> IO CachingConnection cachingConnection dsn = do conn <- connectODBC dsn - stmtMap <- newMVar =<< M.new (==) M.hashString + stmtMap <- newMVar =<< M.new return $ CachingConnection conn stmtMap -- FIXME: remove putStrLn-s diff --git a/src/Database/MetaHDBC/OdbcInferTypes.hs b/src/Database/MetaHDBC/OdbcInferTypes.hs --- a/src/Database/MetaHDBC/OdbcInferTypes.hs +++ b/src/Database/MetaHDBC/OdbcInferTypes.hs @@ -13,7 +13,7 @@ -> String -- ^SQL -> IO ([SqlColDesc], [SqlColDesc]) -- ^(parameter/input -info, return/column/output -info) dbInferTypes dsn sqlExpr = - do c <- connectODBC dsn `catchSql` connectError + do c <- connectODBC dsn `catchSql` connectError (paramInfo', description') <- getQueryInfo c sqlExpr `catchSql` queryInfoError -- print (paramInfo, description) paramInfo <- strictList paramInfo' diff --git a/src/Database/MetaHDBC/SqlExpr.hs b/src/Database/MetaHDBC/SqlExpr.hs --- a/src/Database/MetaHDBC/SqlExpr.hs +++ b/src/Database/MetaHDBC/SqlExpr.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE TemplateHaskell, BangPatterns #-} +{-# LANGUAGE TemplateHaskell, BangPatterns, QuasiQuotes #-} -{- +{- ToDo: * Better error handling @@ -16,13 +16,15 @@ module Database.MetaHDBC.SqlExpr ( runStmt, prepareStmt, strict - -- + -- , ExprParts(..), Parameter(..), PrepareParts(..) , rethrowDoing, sqlInfo, makeExprParts -- * Helper functions to construct directly runned statements (runStmt) , runStmtLHS, runStmtRHS -- * Helper function to construct prepared statements , makePrepStmtParts, prepStmtLHS, prepStmtQ, execPrepStmtRHS, returnExecPrepStmtLHS + -- * Multiline quasi quotation + , runStmtML, multiline ) where @@ -32,6 +34,7 @@ import Database.MetaHDBC.OdbcInferTypes import Language.Haskell.TH +import Language.Haskell.TH.Quote import Database.HDBC @@ -48,7 +51,7 @@ { parameters :: [Parameter] -- ^Positional parameters , returnTypes :: [SqlColDesc] -- ^Description of values returned from a SQL statement , dbSqlExpr :: String -- ^The SQL expression which is passed on to the database - , connectionName :: Name -- ^Name of the 'Connection' parameter. + , connectionName :: Name -- ^Name of the 'Connection' parameter. } -- |Describing a positional parameter @@ -68,7 +71,7 @@ unboundParameters :: ExprParts -> [Parameter] unboundParameters parts = filter (not . isBound) $ parameters parts --- |Contructs expression-parts. A database is contacting to parse the +-- |Contructs expression-parts. A database is contacted to parse the -- SQL and infer correct types. makeExprParts :: String -> String -> Q ExprParts makeExprParts dsn extendedSql = @@ -88,7 +91,7 @@ -- |Statically typed one-off (not prepared) SQL statement. runStmt :: String -- ^Data source name (DSN) -> String -- ^SQL statement extended with question marks for parameteres - -> ExpQ -- ^The expression has type + -> ExpQ -- ^The expression has type -- /Connection -> a1 -> ... -> an -> IO [x1, ... xm])/, -- where /a1-an/ are inputs to the statement (due to placeholder -- arguments), and /x1-xm/ are the outputs from the statement. @@ -122,13 +125,13 @@ -- *** Prepared statements *** --- |Statically typed prepared SQL statement. +-- |Statically typed prepared SQL statement. prepareStmt :: String -- ^Data source name (DSN) -> String -- ^SQL statement extended with question marks for parameteres - -> ExpQ -- ^ The expression has type + -> ExpQ -- ^ The expression has type -- /Connection -> IO (a1 -> ... -> an -> IO [x1, ... xm])/, -- where /a1-an/ are inputs to the statement (due to placeholder - -- arguments), and /x1-xm/ are the outputs from the statement. + -- arguments), and /x1-xm/ are the outputs from the statement. -- -- If there are no outputs from the statement (e.g. an insert -- statement) the number of affected rows is returned. @@ -138,14 +141,14 @@ , returnExecPrepStmtLHS parts [execPrepStmtRHS parts] ] --- | Creates parts for a prepared statement. Calls 'makeExprParts'. +-- | Creates parts for a prepared statement. Calls 'makeExprParts'. makePrepStmtParts :: String -> String -> Q PrepareParts makePrepStmtParts dsn extendedSql = do parts <- makeExprParts dsn extendedSql preStmtName <- newName "preStmt" return $ PrepareParts parts preStmtName --- | Lambda for prepared statements. +-- | Lambda for prepared statements. prepStmtLHS :: PrepareParts -> [StmtQ] -> ExpQ prepStmtLHS (PrepareParts parts _) stmtQs = lam1E (varP (connectionName parts)) (doE stmtQs) @@ -191,7 +194,7 @@ sqlInfo dsn extendedSql = do (varNames, sqlExpr, paramInfo, columnInfo) <- inferTypes dsn extendedSql let varsString = show $ zip varNames paramInfo - columnInfoString = show columnInfo + columnInfoString = show columnInfo return ("Extended sql: " ++ extendedSql ++ "\n" ++ "Parsed sql: " ++ sqlExpr ++ "\n" ++ "Variables: " ++ varsString ++ "\n" ++ @@ -202,10 +205,10 @@ -- retrieved lazily. fetchRows :: Statement -> [SqlValue] -> IO [[SqlValue]] fetchRows preStmt params = - do execute preStmt params `rethrowDoing` "executing prepared statement" - fetchAllRows preStmt `rethrowDoing` "fetch all rows" + do _ <- execute preStmt params `rethrowDoing` "executing prepared statement" + fetchAllRows preStmt `rethrowDoing` "fetch all rows" -rethrowDoing :: IO a -> String -> IO a +rethrowDoing :: IO a -> String -> IO a rethrowDoing command doing = command `catchSql` (\e -> fail ("Exception when trying \"" ++ doing ++ "\" : " ++ seErrorMsg e)) @@ -225,17 +228,35 @@ -- converted into Haskell types. This TH function returns an -- expression which do this conversion. fromRow :: [SqlColDesc] -> ExpQ -fromRow xs = +fromRow xs = do es <- mapM fromSqlColDesc xs -- es <- mapM (fromSqlTypeId . colType) xs - names <- mapM (\i -> newName ("x" ++ show i)) [0..(length es - 1)] + names <- mapM (\i -> newName ("p" ++ show i)) [0..(length es - 1)] return $ LamE [ListP (map VarP names)] (TupE $ map (\(e, n) -> AppE e (VarE n)) $ zip es names) +-- *** Multiline *** + +runStmtML :: String -> QuasiQuoter +runStmtML conn = QuasiQuoter + { quoteExp = \s -> runStmt conn s + , quotePat = error "Not implemented" + , quoteType = error "Not implemented" + , quoteDec = error "Not implemented" + } + +multiline :: QuasiQuoter +multiline = QuasiQuoter + { quoteExp = litE . stringL + , quotePat = error "Not implemented" + , quoteType = error "Not implemented" + , quoteDec = error "Not implemented" + } + -- Expimental cahcing-connection cachingStmt :: String -- ^Data source name (DSN) -> String -- ^SQL statement extended with question marks for parameteres - -> ExpQ -- ^The expression has type + -> ExpQ -- ^The expression has type -- /Connection -> a1 -> ... -> an -> IO [x1, ... xm])/, -- where /a1-an/ are inputs to the statement (due to placeholder -- arguments), and /x1-xm/ are the outputs from the statement. @@ -254,8 +275,8 @@ (parmNames, parmExpr) <- fromParams' (zip varNames paramInfo) connName <- newName "connection" preStmtName <- newName "preStmt" - let prepareExpQ = - bindS (varP preStmtName) [| cachingPrepare $(varE connName) sqlExpr + let prepareExpQ = + bindS (varP preStmtName) [| cachingPrepare $(varE connName) sqlExpr `rethrowDoing` "calling cachingPrepare" |] executeExpQ = noBindS $ [| do rows <- fetchRows $(varE preStmtName) $( parmExpr )