MetaHDBC 0.1.2 → 0.1.4

raw patch · 4 files changed

+50/−27 lines, 4 filesdep +hashtablesdep ~HDBC-odbcdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: hashtables

Dependency ranges changed: HDBC-odbc, base

API changes (from Hackage documentation)

Files

• MetaHDBC.cabal +3/−3
• src/Database/MetaHDBC/Connection.hs +5/−3
• src/Database/MetaHDBC/OdbcInferTypes.hs +1/−1
• src/Database/MetaHDBC/SqlExpr.hs +41/−20

@@ -1,5 +1,5 @@ Name:           MetaHDBC-Version:        0.1.2+Version:        0.1.4 Cabal-version:  >=1.6 Copyright:      Mads Lindstrøm <mads.lindstroem@gmail.com> 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

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

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

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