diff --git a/relational-postgresql8.cabal b/relational-postgresql8.cabal --- a/relational-postgresql8.cabal +++ b/relational-postgresql8.cabal @@ -1,5 +1,5 @@ name: relational-postgresql8 -version: 0.1.0.0 +version: 0.2.0.0 synopsis: PostgreSQL v8.x driver for haskell-relational-record description: This package contains a driver of old PostgreSQL for haskell-relational-record. homepage: https://github.com/yuga/haskell-relational-record-driver-postgresql8 @@ -30,13 +30,14 @@ build-depends: base <5 , containers , time + , transformers , persistable-record , HDBC >=2 , names-th - , relational-query - , relational-query-HDBC + , relational-query >=0.8.0.0 + , relational-query-HDBC >=0.2.0.0 , template-haskell hs-source-dirs: src - + ghc-options: -Wall diff --git a/src/Database/HDBC/Schema/PostgreSQL8.hs b/src/Database/HDBC/Schema/PostgreSQL8.hs --- a/src/Database/HDBC/Schema/PostgreSQL8.hs +++ b/src/Database/HDBC/Schema/PostgreSQL8.hs @@ -18,8 +18,11 @@ ) where import Language.Haskell.TH (TypeQ) -import qualified Language.Haskell.TH.Lib.Extra as TH +import Control.Applicative ((<|>)) +import Control.Monad (guard) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT) import Data.Char (toLower) import Data.Map (fromList) @@ -38,7 +41,8 @@ import qualified Database.Relational.Schema.PgCatalog8.PgType as Type import Database.HDBC.Schema.Driver - (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) + (TypeMap, LogChan, putVerbose, maybeIO, failWith, + Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) $(makeRecordPersistableWithSqlTypeDefaultFromDefined @@ -50,57 +54,58 @@ logPrefix :: String -> String logPrefix = ("PostgreSQL: " ++) -putLog :: String -> IO () -putLog = TH.reportMessage . logPrefix +putLog :: LogChan -> String -> IO () +putLog lchan = putVerbose lchan . logPrefix -compileErrorIO :: String -> IO a -compileErrorIO = fail . logPrefix +compileError :: LogChan -> String -> MaybeT IO a +compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn - => conn - -> String - -> String - -> IO [String] -getPrimaryKey' conn scm' tbl' = do + => conn + -> LogChan + -> String + -> String + -> IO [String] +getPrimaryKey' conn lchan scm' tbl' = do let scm = map toLower scm' tbl = map toLower tbl' mayKeyLen <- runQuery' conn primaryKeyLengthQuerySQL (scm, tbl) case mayKeyLen of [] -> do - putLog "getPrimaryKey: Primary key not found." + putLog lchan "getPrimaryKey: Primary key not found." return [] [keyLen] -> do primCols <- runQuery' conn (primaryKeyQuerySQL keyLen) (scm, tbl) let primaryKeyCols = normalizeColumn `fmap` primCols - putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols + putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols return primaryKeyCols _:_:_ -> do - putLog "getPrimaryKey: Fail to detect primary key. Something wrong." + putLog lchan "getPrimaryKey: Fail to detect primary key. Something wrong." return [] -getFields' :: IConnection conn - => TypeMap - -> conn - -> String - -> String - -> IO ([(String, TypeQ)], [Int]) -getFields' tmap conn scm' tbl' = do +getColumns' :: IConnection conn + => TypeMap + -> conn + -> LogChan + -> String + -> String + -> IO ([(String, TypeQ)], [Int]) +getColumns' tmap conn lchan scm' tbl' = maybeIO ([], []) id $ do let scm = map toLower scm' tbl = map toLower tbl' - cols <- runQuery' conn columnQuerySQL (scm, tbl) - case cols of - [] -> compileErrorIO - $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl - _ -> return () + cols <- lift $ runQuery' conn columnQuerySQL (scm, tbl) + guard (not $ null cols) <|> + compileError lchan + ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl) let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols - putLog + lift . putLog lchan $ "getFields: num of columns = " ++ show (length cols) ++ ", not null columns = " ++ show notNullIdxs - let getType' col = case getType (fromList tmap) col of - Nothing -> compileErrorIO - $ "Type mapping is not defined against PostgreSQL type: " ++ Type.typname (snd col) - Just p -> return p + let getType' col = + hoistMaybe (getType (fromList tmap) col) <|> + compileError lchan + ("Type mapping is not defined against PostgreSQL type: " ++ Type.typname (snd col)) types <- mapM getType' cols return (types, notNullIdxs) @@ -108,5 +113,5 @@ -- | Driver implementation driverPostgreSQL :: IConnection conn => Driver conn driverPostgreSQL = - emptyDriver { getFieldsWithMap = getFields' } + emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } diff --git a/src/Database/Relational/Schema/PgCatalog8/PgAttribute.hs b/src/Database/Relational/Schema/PgCatalog8/PgAttribute.hs --- a/src/Database/Relational/Schema/PgCatalog8/PgAttribute.hs +++ b/src/Database/Relational/Schema/PgCatalog8/PgAttribute.hs @@ -13,14 +13,11 @@ import Data.Int (Int16, Int32) -import Database.Record.TH (derivingShow) -import Database.Relational.Query.TH (defineTableTypesAndRecordDefault) - +import Database.Relational.Query.TH (defineTableTypesAndRecord) import Database.Relational.Schema.PgCatalog8.Config (config) -$(defineTableTypesAndRecordDefault config +$(defineTableTypesAndRecord config "PG_CATALOG" "pg_attribute" - [ -- Table "pg_catalog.pg_attribute" -- Column | Type | Modifiers @@ -68,4 +65,4 @@ -- attfdwoptions | text[] | <- since 9.2 -- ("attfdwoptions", [t|String|]) ] - [derivingShow]) + [''Show]) diff --git a/src/Database/Relational/Schema/PgCatalog8/PgClass.hs b/src/Database/Relational/Schema/PgCatalog8/PgClass.hs --- a/src/Database/Relational/Schema/PgCatalog8/PgClass.hs +++ b/src/Database/Relational/Schema/PgCatalog8/PgClass.hs @@ -13,12 +13,10 @@ import Data.Int (Int32) -import Database.Record.TH (derivingShow) -import Database.Relational.Query.TH (defineTableTypesAndRecordDefault) - +import Database.Relational.Query.TH (defineTableTypesAndRecord) import Database.Relational.Schema.PgCatalog8.Config (config) -$(defineTableTypesAndRecordDefault config +$(defineTableTypesAndRecord config "PG_CATALOG" "pg_class" [("oid" , [t| Int32 |]), -- relname | name | not null @@ -55,4 +53,4 @@ -- relacl | aclitem[] | -- reloptions | text[] | <= since 8.2 ] - [derivingShow]) + [''Show]) diff --git a/src/Database/Relational/Schema/PgCatalog8/PgConstraint.hs b/src/Database/Relational/Schema/PgCatalog8/PgConstraint.hs --- a/src/Database/Relational/Schema/PgCatalog8/PgConstraint.hs +++ b/src/Database/Relational/Schema/PgCatalog8/PgConstraint.hs @@ -13,12 +13,10 @@ import Data.Int (Int32) -import Database.Record.TH (derivingShow) -import Database.Relational.Query.TH (defineTableTypesAndRecordDefault) - +import Database.Relational.Query.TH (defineTableTypesAndRecord) import Database.Relational.Schema.PgCatalog8.Config (config) -$(defineTableTypesAndRecordDefault config +$(defineTableTypesAndRecord config "PG_CATALOG" "pg_constraint" [ -- ("oid" , [t| Int32 |]), -- conname | name | not null @@ -49,4 +47,4 @@ -- conbin | pg_node_tree | -- consrc | text | ] - [derivingShow]) + [''Show]) diff --git a/src/Database/Relational/Schema/PgCatalog8/PgNamespace.hs b/src/Database/Relational/Schema/PgCatalog8/PgNamespace.hs --- a/src/Database/Relational/Schema/PgCatalog8/PgNamespace.hs +++ b/src/Database/Relational/Schema/PgCatalog8/PgNamespace.hs @@ -13,12 +13,10 @@ import Data.Int (Int32) -import Database.Record.TH (derivingShow) -import Database.Relational.Query.TH (defineTableTypesAndRecordDefault) - +import Database.Relational.Query.TH (defineTableTypesAndRecord) import Database.Relational.Schema.PgCatalog8.Config (config) -$(defineTableTypesAndRecordDefault config +$(defineTableTypesAndRecord config "PG_CATALOG" "pg_namespace" [("oid" , [t| Int32 |]), -- nspname | name | not null @@ -26,4 +24,4 @@ -- nspowner | oid | not null -- nspacl | aclitem[] | ] - [derivingShow]) + [''Show]) diff --git a/src/Database/Relational/Schema/PgCatalog8/PgType.hs b/src/Database/Relational/Schema/PgCatalog8/PgType.hs --- a/src/Database/Relational/Schema/PgCatalog8/PgType.hs +++ b/src/Database/Relational/Schema/PgCatalog8/PgType.hs @@ -13,14 +13,11 @@ import Data.Int (Int16, Int32) -import Database.Record.TH (derivingShow) -import Database.Relational.Query.TH (defineTableTypesAndRecordDefault) - +import Database.Relational.Query.TH (defineTableTypesAndRecord) import Database.Relational.Schema.PgCatalog8.Config (config) -$(defineTableTypesAndRecordDefault config +$(defineTableTypesAndRecord config "PG_CATALOG" "pg_type" - [ ("oid", [t|Int32|]), -- Table "pg_catalog.pg_type" @@ -87,4 +84,4 @@ ("typdefault", [t|Maybe String|]) -- typacl | aclitem[] | <= since 9.2 ] - [derivingShow]) + [''Show])