diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 --- a/ChangeLog.md +++ /dev/null @@ -1,41 +0,0 @@ - - -## 0.6.2.1 - -- add tested-with 8.2.1. - -## 0.6.2.0 - -- Apply generic instances. - -## 0.6.0.2 - -- Add tested-with. - -## 0.6.0.1 - -- Update compatibility for GHC 8. -- Drop old tests of Oracle. - -## 0.6.0.0 - -- Use updated template of persistable-record. -- Drop persistableSqlValue. - -## 0.5.0.0 - -- Use updated template of relational-query. -- Drop old examples of Oracle. - -## 0.4.0.0 - -- TH quotation of derive class names. - -## 0.3.0.0 - -- Hide chunksInsertActions. -- Add withPrepareDelete. - -## 0.2.0.0 - -- Add logging interface for schema driver. diff --git a/relational-query-HDBC.cabal b/relational-query-HDBC.cabal --- a/relational-query-HDBC.cabal +++ b/relational-query-HDBC.cabal @@ -1,5 +1,5 @@ name: relational-query-HDBC -version: 0.6.2.1 +version: 0.6.3.0 synopsis: HDBC instance of relational-query and typed query interface for HDBC description: This package contains the HDBC instance of relational-query and the typed query interface for HDBC. @@ -21,7 +21,6 @@ , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3 , GHC == 7.4.1, GHC == 7.4.2 -extra-source-files: ChangeLog.md library exposed-modules: @@ -57,8 +56,8 @@ , th-data-compat , names-th - , persistable-record >= 0.5 - , relational-query >= 0.9 + , persistable-record >= 0.4 && < 0.5 + , relational-query >= 0.8 , relational-schemas , HDBC >=2 , HDBC-session diff --git a/src/Database/HDBC/Query/TH.hs b/src/Database/HDBC/Query/TH.hs --- a/src/Database/HDBC/Query/TH.hs +++ b/src/Database/HDBC/Query/TH.hs @@ -5,7 +5,7 @@ -- | -- Module : Database.HDBC.Query.TH --- Copyright : 2013-2017 Kei Hibino +-- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -15,7 +15,6 @@ -- This module contains templates to generate Haskell record types -- and HDBC instances correspond to RDB table schema. module Database.HDBC.Query.TH ( - makeRelationalRecord, makeRecordPersistableDefault, defineTableDefault', @@ -38,11 +37,9 @@ import Language.Haskell.TH.Name.CamelCase (varCamelcaseName) import Language.Haskell.TH.Lib.Extra (reportWarning, reportError) -import Database.Record (ToSql, FromSql) -import Database.Record.TH (recordTemplate, reifyRecordType) -import Database.Relational.Query - (Config, nameConfig, recordConfig, verboseAsCompilerWarning, defaultConfig, - Relation, relationalQuerySQL) +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefault) +import qualified Database.Record.TH as Record +import Database.Relational.Query (Relation, Config, verboseAsCompilerWarning, defaultConfig, relationalQuerySQL) import Database.Relational.Query.SQL (QuerySuffix) import qualified Database.Relational.Query.TH as Relational @@ -53,29 +50,18 @@ (runLog, newLogChan, takeLogs, Driver, getFields, getPrimaryKey) -defineInstancesForSqlValue :: TypeQ -- ^ Record type constructor. - -> Q [Dec] -- ^ Instance declarations. -defineInstancesForSqlValue typeCon = do - [d| instance FromSql SqlValue $typeCon - instance ToSql SqlValue $typeCon - |] - -- | Generate all persistable templates against defined record like type constructor. -makeRelationalRecord :: Name -- ^ Type constructor name - -> Q [Dec] -- ^ Result declaration -makeRelationalRecord recTypeName = do - rr <- Relational.makeRelationalRecordDefault recTypeName - ((typeCon, _), _) <- reifyRecordType recTypeName - ps <- defineInstancesForSqlValue typeCon - return $ rr ++ ps - -{-# DEPRECATED makeRecordPersistableDefault "Use makeRelationalRecord instead of this." #-} --- | Deprecated. use 'makeRelationalRecord'. makeRecordPersistableDefault :: Name -- ^ Type constructor name -> Q [Dec] -- ^ Result declaration -makeRecordPersistableDefault = makeRelationalRecord +makeRecordPersistableDefault recTypeName = do + rr <- Relational.makeRelationalRecordDefault recTypeName + (pair, (_mayNs, cts)) <- Record.reifyRecordType recTypeName + let width = length cts + ps <- Record.makeRecordPersistableWithSqlType [t| SqlValue |] + (Record.persistableFunctionNamesDefault recTypeName) pair width + return $ rr ++ ps --- | Generate all HDBC templates about table except for constraint keys. +-- | Generate all HDBC templates about table except for constraint keys using default naming rule. defineTableDefault' :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name -> String -- ^ Table name @@ -84,10 +70,10 @@ -> Q [Dec] -- ^ Result declaration defineTableDefault' config schema table columns derives = do modelD <- Relational.defineTableTypesAndRecord config schema table columns derives - sqlvD <- defineInstancesForSqlValue . fst $ recordTemplate (recordConfig $ nameConfig config) schema table + sqlvD <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] schema table $ length columns return $ modelD ++ sqlvD --- | Generate all HDBC templates about table. +-- | Generate all HDBC templates about table using default naming rule. defineTableDefault :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name -> String -- ^ Table name @@ -98,7 +84,7 @@ -> Q [Dec] -- ^ Result declaration defineTableDefault config schema table columns derives primary notNull = do modelD <- Relational.defineTable config schema table columns derives primary notNull - sqlvD <- defineInstancesForSqlValue . fst $ recordTemplate (recordConfig $ nameConfig config) schema table + sqlvD <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] schema table $ length columns return $ modelD ++ sqlvD -- | Generate all HDBC templates using system catalog informations with specified config. diff --git a/src/Database/HDBC/Record/KeyUpdate.hs b/src/Database/HDBC/Record/KeyUpdate.hs --- a/src/Database/HDBC/Record/KeyUpdate.hs +++ b/src/Database/HDBC/Record/KeyUpdate.hs @@ -2,7 +2,7 @@ -- | -- Module : Database.HDBC.Record.KeyUpdate --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com diff --git a/src/Database/HDBC/Record/Query.hs b/src/Database/HDBC/Record/Query.hs --- a/src/Database/HDBC/Record/Query.hs +++ b/src/Database/HDBC/Record/Query.hs @@ -33,7 +33,7 @@ import Database.HDBC.Record.Statement (unsafePrepare, withUnsafePrepare, PreparedStatement, bind, BoundStatement, - execute, ExecutedStatement, executed) + executeBound, ExecutedStatement, executed) -- | Typed prepared query type. @@ -112,11 +112,11 @@ -- | Execute statement and lazily fetch all records. runStatement :: FromSql SqlValue a => BoundStatement a -> IO [a] -runStatement = (>>= fetchAll) . execute +runStatement = (>>= fetchAll) . executeBound -- | Strict version of 'runStatement'. runStatement' :: FromSql SqlValue a => BoundStatement a -> IO [a] -runStatement' = (>>= fetchAll') . execute +runStatement' = (>>= fetchAll') . executeBound -- | Bind parameters, execute statement and lazily fetch all records. runPreparedQuery :: (ToSql SqlValue p, FromSql SqlValue a) diff --git a/src/Database/HDBC/Record/Statement.hs b/src/Database/HDBC/Record/Statement.hs --- a/src/Database/HDBC/Record/Statement.hs +++ b/src/Database/HDBC/Record/Statement.hs @@ -18,9 +18,13 @@ BoundStatement (..), bind', bind, bindTo, - ExecutedStatement, executed, result, execute, + ExecutedStatement, executed, result, - executePrepared, prepareNoFetch, executeNoFetch, runPreparedNoFetch, runNoFetch, mapNoFetch + executeBound, execute, executePrepared, + + prepareNoFetch, + executeBoundNoFetch, executeNoFetch, runPreparedNoFetch, + runNoFetch, mapNoFetch, ) where import Control.Exception (bracket) @@ -115,26 +119,38 @@ bindTo = flip bind -- | Typed execute operation. -execute :: BoundStatement a -> IO (ExecutedStatement a) -execute bs = do +executeBound :: BoundStatement a -> IO (ExecutedStatement a) +executeBound bs = do let stmt = bound bs n <- HDBC.execute stmt (params bs) return $ ExecutedStatement stmt n --- | Bind parameters, execute statement and get executed statement. +{-# WARNING execute "Use 'executeBound' instead of this. This name will be used for executePrepared function in future release." #-} +-- | Use 'executeBound' instead of this. +-- WARNING! This name will be used for executePrepared function in future release. +execute :: BoundStatement a -> IO (ExecutedStatement a) +execute = executeBound + +-- | Bind parameters, execute prepared statement and get executed statement. executePrepared :: ToSql SqlValue p => PreparedStatement p a -> p -> IO (ExecutedStatement a) -executePrepared st = execute . bind st +executePrepared st = executeBound . bind st -- | Typed execute operation. Only get result. +executeBoundNoFetch :: BoundStatement () -> IO Integer +executeBoundNoFetch = fmap result . executeBound + +{- WARNING executeNoFetch "Use 'executeBoundNoFetch' instead of this. This name will be used for runPreparedNoFetch function in future release." -} +-- | Use 'executeBoundNoFetch' instead of this. +-- WARNING! This name will be used for runPreparedNoFetch function in future release. executeNoFetch :: BoundStatement () -> IO Integer -executeNoFetch = fmap result . execute +executeNoFetch = executeBoundNoFetch --- | Bind parameters, execute statement and get execution result. +-- | Bind parameters, execute prepared statement and get execution result. runPreparedNoFetch :: ToSql SqlValue a - => PreparedStatement a () - -> a - -> IO Integer -runPreparedNoFetch p = executeNoFetch . (p `bind`) + => PreparedStatement a () + -> a + -> IO Integer +runPreparedNoFetch p = executeBoundNoFetch . (p `bind`) -- | Prepare and run sequence for polymorphic no-fetch statement. runNoFetch :: (UntypeableNoFetch s, IConnection conn, ToSql SqlValue a) diff --git a/src/Database/HDBC/Schema/IBMDB2.hs b/src/Database/HDBC/Schema/IBMDB2.hs --- a/src/Database/HDBC/Schema/IBMDB2.hs +++ b/src/Database/HDBC/Schema/IBMDB2.hs @@ -34,7 +34,7 @@ import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () -import Database.Record (FromSql, ToSql) +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.IBMDB2 (normalizeColumn, notNull, getType, columnsQuerySQL, primaryKeyQuerySQL) @@ -46,8 +46,9 @@ Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) -instance FromSql SqlValue Columns -instance ToSql SqlValue Columns +-- Specify type constructor and data constructor from same table name. +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''Columns) logPrefix :: String -> String logPrefix = ("IBMDB2: " ++) diff --git a/src/Database/HDBC/Schema/MySQL.hs b/src/Database/HDBC/Schema/MySQL.hs --- a/src/Database/HDBC/Schema/MySQL.hs +++ b/src/Database/HDBC/Schema/MySQL.hs @@ -26,7 +26,6 @@ import Data.Map (fromList) import Database.HDBC (IConnection, SqlValue) -import Database.Record (FromSql, ToSql) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver ( TypeMap @@ -40,6 +39,7 @@ , getPrimaryKey , emptyDriver ) +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.MySQL ( normalizeColumn , notNull , getType @@ -50,9 +50,7 @@ import Database.Relational.Schema.MySQLInfo.Columns (Columns) import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns - -instance FromSql SqlValue Columns -instance ToSql SqlValue Columns +$(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''Columns) logPrefix :: String -> String logPrefix = ("MySQL: " ++) diff --git a/src/Database/HDBC/Schema/Oracle.hs b/src/Database/HDBC/Schema/Oracle.hs --- a/src/Database/HDBC/Schema/Oracle.hs +++ b/src/Database/HDBC/Schema/Oracle.hs @@ -23,10 +23,9 @@ import Language.Haskell.TH (TypeQ) import Database.HDBC (IConnection, SqlValue) -import Database.Record (FromSql, ToSql) - import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.HDBC.Schema.Driver ( TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver @@ -39,9 +38,9 @@ import Database.Relational.Schema.OracleDataDictionary.TabColumns (DbaTabColumns) import qualified Database.Relational.Schema.OracleDataDictionary.TabColumns as Cols - -instance FromSql SqlValue DbaTabColumns -instance ToSql SqlValue DbaTabColumns +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t|SqlValue|] + ''DbaTabColumns) logPrefix :: String -> String logPrefix = ("Oracle: " ++) diff --git a/src/Database/HDBC/Schema/PostgreSQL.hs b/src/Database/HDBC/Schema/PostgreSQL.hs --- a/src/Database/HDBC/Schema/PostgreSQL.hs +++ b/src/Database/HDBC/Schema/PostgreSQL.hs @@ -31,7 +31,7 @@ import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () -import Database.Record (FromSql, ToSql) +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.PostgreSQL (normalizeColumn, notNull, getType, columnQuerySQL, @@ -45,11 +45,11 @@ Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) -instance FromSql SqlValue PgAttribute -instance ToSql SqlValue PgAttribute +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''PgAttribute) -instance FromSql SqlValue PgType -instance ToSql SqlValue PgType +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''PgType) logPrefix :: String -> String logPrefix = ("PostgreSQL: " ++) diff --git a/src/Database/HDBC/Schema/SQLServer.hs b/src/Database/HDBC/Schema/SQLServer.hs --- a/src/Database/HDBC/Schema/SQLServer.hs +++ b/src/Database/HDBC/Schema/SQLServer.hs @@ -29,7 +29,7 @@ import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) -import Database.Record (FromSql, ToSql) +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.SQLServer (columnTypeQuerySQL, getType, normalizeColumn, notNull, primaryKeyQuerySQL) import Database.Relational.Schema.SQLServerSyscat.Columns (Columns) @@ -37,11 +37,11 @@ import Language.Haskell.TH (TypeQ) -instance FromSql SqlValue Columns -instance ToSql SqlValue Columns +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''Columns) -instance FromSql SqlValue Types -instance ToSql SqlValue Types +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''Types) logPrefix :: String -> String logPrefix = ("SQLServer: " ++) diff --git a/src/Database/HDBC/Schema/SQLite3.hs b/src/Database/HDBC/Schema/SQLite3.hs --- a/src/Database/HDBC/Schema/SQLite3.hs +++ b/src/Database/HDBC/Schema/SQLite3.hs @@ -30,7 +30,7 @@ import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) -import Database.Record (FromSql, ToSql) +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.SQLite3 (getType, indexInfoQuerySQL, indexListQuerySQL, normalizeColumn, normalizeType, notNull, tableInfoQuerySQL) import Database.Relational.Schema.SQLite3Syscat.IndexInfo (IndexInfo) @@ -38,15 +38,14 @@ import Database.Relational.Schema.SQLite3Syscat.TableInfo (TableInfo) import Language.Haskell.TH (TypeQ) - -instance FromSql SqlValue TableInfo -instance ToSql SqlValue TableInfo +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''TableInfo) -instance FromSql SqlValue IndexList -instance ToSql SqlValue IndexList +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''IndexList) -instance FromSql SqlValue IndexInfo -instance ToSql SqlValue IndexInfo +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''IndexInfo) logPrefix :: String -> String logPrefix = ("SQLite3: " ++)