From cda839431f8b51ee8bd90d04e81e727c7c1b2c6f Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Wed, 15 May 2013 12:06:08 +0900 Subject: [PATCH] Move schema query for DB2 which does not depend on HDBC. --- relational-join/relational-join.cabal | 3 + .../src/Database/Relational/Schema/IBMDB2.hs | 95 +++++++++++++++++++ schema-th/HDBC-schema-th.cabal | 2 - schema-th/src/Database/HDBC/Record/TH.hs | 35 ++++++- schema-th/src/Database/HDBC/Schema/IBMDB2.hs | 95 ++++--------------- 5 files changed, 144 insertions(+), 86 deletions(-) create mode 100644 relational-join/src/Database/Relational/Schema/IBMDB2.hs diff --git a/relational-join/relational-join.cabal b/relational-join/relational-join.cabal index 2f95f938..ad87570c 100644 --- a/relational-join/relational-join.cabal +++ b/relational-join/relational-join.cabal @@ -34,12 +34,15 @@ library Database.Relational.Query.TH Database.Relational.Schema.DB2Syscat.Columns + Database.Relational.Schema.IBMDB2 Database.Relational.Schema.PgCatalog.PgAttribute Database.Relational.Schema.PgCatalog.PgType -- other-modules: build-depends: base <5 , array + , containers + , time , sql-words , bytestring , text diff --git a/relational-join/src/Database/Relational/Schema/IBMDB2.hs b/relational-join/src/Database/Relational/Schema/IBMDB2.hs new file mode 100644 index 00000000..696b3d96 --- /dev/null +++ b/relational-join/src/Database/Relational/Schema/IBMDB2.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Database.Relational.Schema.IBMDB2 ( + normalizeColumn, notNull, getType, + + columnsQuerySQL, primaryKeyQuerySQL + ) where + + +import Data.Int (Int16, Int32, Int64) +import Data.Char (toLower) +import Data.Map (Map, fromList) +import qualified Data.Map as Map +import Data.Time (LocalTime, Day) +import Language.Haskell.TH (TypeQ) + +import Database.Record.Instances () + +import qualified Database.Relational.Query.Table as Table +import Database.Relational.Query.Type (unsafeTypedQuery, fromRelation) +import Database.Relational.Query + (Query, PrimeRelation, inner, relation, + wheres, (.=.), (!), placeholder, asc) + +import Language.SQL.Keyword (Keyword(..)) +import qualified Language.SQL.Keyword as SQL + +import Control.Applicative ((<|>)) + +import Database.Relational.Schema.DB2Syscat.Columns (Columns, tableOfColumns, columns) +import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns + + +mapFromSqlDefault :: Map String TypeQ +mapFromSqlDefault = + fromList [("VARCHAR", [t|String|]), + ("CHAR", [t|String|]), + ("CHARACTER", [t|String|]), + ("TIMESTAMP", [t|LocalTime|]), + ("DATE", [t|Day|]), + ("SMALLINT", [t|Int16|]), + ("INTEGER", [t|Int32|]), + ("BIGINT", [t|Int64|]), + ("BLOB", [t|String|]), + ("CLOB", [t|String|])] + +normalizeColumn :: String -> String +normalizeColumn = map toLower + +notNull :: Columns -> Bool +notNull = (== "N") . Columns.nulls + +getType :: Map String TypeQ -> Columns -> Maybe (String, TypeQ) +getType mapFromSql rec = do + typ <- (Map.lookup key mapFromSql + <|> + Map.lookup key mapFromSqlDefault) + return (normalizeColumn $ Columns.colname rec, mayNull typ) + where key = Columns.typename rec + mayNull typ = if notNull rec + then typ + else [t| Maybe $(typ) |] + +columnsRelationFromTable :: PrimeRelation (String, String) Columns +columnsRelationFromTable = relation $ do + c <- inner columns + wheres $ c ! Columns.tabschema' .=. placeholder + wheres $ c ! Columns.tabname' .=. placeholder + asc $ c ! Columns.colno' + return c + +columnsQuerySQL :: Query (String, String) Columns +columnsQuerySQL = fromRelation columnsRelationFromTable + + +primaryKeyQuerySQL :: Query (String, String) String +primaryKeyQuerySQL = + unsafeTypedQuery . + SQL.unwordsSQL + $ [SELECT, "key.colname", + FROM, + "SYSCAT.tabconst", AS, "const", ",", + "SYSCAT.keycoluse", AS, "key", ",", + SQL.word (Table.name tableOfColumns), AS, "col", + WHERE, + "const.tabschema = col.tabschema", AND, + "const.tabname = col.tabname", AND, + "key.colname = col.colname", AND, + "const.constname = key.constname", AND, + + "col.nulls = 'N'", AND, + "const.type = 'P'", AND, "const.enforced = 'Y'", AND, + + "const.tabschema = ?", AND, "const.tabname = ?"] diff --git a/schema-th/HDBC-schema-th.cabal b/schema-th/HDBC-schema-th.cabal index f11870a5..dc7ff563 100644 --- a/schema-th/HDBC-schema-th.cabal +++ b/schema-th/HDBC-schema-th.cabal @@ -27,8 +27,6 @@ library Database.HDBC.SqlValueExtra Database.HDBC.Schema.Driver Database.HDBC.Schema.IBMDB2 - -- Database.HDBC.Schema.PgCatalog.PgAttribute - -- Database.HDBC.Schema.PgCatalog.PgType Database.HDBC.Schema.PostgreSQL build-depends: base <5 diff --git a/schema-th/src/Database/HDBC/Record/TH.hs b/schema-th/src/Database/HDBC/Record/TH.hs index 7dc2c896..40613b8b 100644 --- a/schema-th/src/Database/HDBC/Record/TH.hs +++ b/schema-th/src/Database/HDBC/Record/TH.hs @@ -7,7 +7,7 @@ module Database.HDBC.Record.TH ( ) where import Data.Maybe (catMaybes) -import Data.List (intersect) +import Data.List (intersect, find) import Language.Haskell.TH (Q, Dec (InstanceD), Type(AppT, ConT), @@ -20,6 +20,7 @@ import Database.Record (Persistable(persistable), derivedPersistableValueRecord, PersistableWidth(persistableWidth), FromSql(recordFromSql), recordFromSql', ToSql(recordToSql), recordToSql') +import Database.Record.Instances () import qualified Database.Record.Persistable as Persistable @@ -52,12 +53,25 @@ convertibleSqlValues = do to = map fst . filter ((== qvt) . snd) $ vs return $ intersect from to -derivePersistableInstanceFromValue :: Q Type -> Q [Dec] -derivePersistableInstanceFromValue typ = +persistableWidthValues :: Q [Type] +persistableWidthValues = cvInfo >>= d0 where + cvInfo = reify ''PersistableWidth + unknownDeclaration = compileError + . ("persistableWidthValues: Unknown declaration pattern: " ++) + d0 (ClassI _ is) = sequence . map d1 $ is where + d1 (InstanceD _cxt (AppT (ConT _n) a) _ds) = return a + d1 decl = unknownDeclaration $ show decl + d0 cls = unknownDeclaration $ show cls + +derivePersistableWidth :: Q Type -> Q [Dec] +derivePersistableWidth typ = [d| instance PersistableWidth $(typ) where persistableWidth = Persistable.valueWidth + |] - instance Persistable SqlValue $(typ) where +derivePersistableInstanceFromValue :: Q Type -> Q [Dec] +derivePersistableInstanceFromValue typ = + [d| instance Persistable SqlValue $(typ) where persistable = derivedPersistableValueRecord instance FromSql SqlValue $(typ) where @@ -67,7 +81,18 @@ derivePersistableInstanceFromValue typ = recordToSql = recordToSql' |] +mapInstanceD :: (Q Type -> Q [Dec]) -> [Type] -> Q [Dec] +mapInstanceD fD = fmap concat . mapM (fD . return) + derivePersistableInstancesFromConvertibleSqlValues :: Q [Dec] derivePersistableInstancesFromConvertibleSqlValues = do + ds <- persistableWidthValues ts <- convertibleSqlValues - concat `fmap` mapM (derivePersistableInstanceFromValue . return) ts + let defineNotDefined qt = do + t <- qt + case find (== t) ds of + Nothing -> derivePersistableWidth qt + Just _ -> return [] + ws <- mapInstanceD defineNotDefined ts + ps <- mapInstanceD derivePersistableInstanceFromValue ts + return $ ws ++ ps diff --git a/schema-th/src/Database/HDBC/Schema/IBMDB2.hs b/schema-th/src/Database/HDBC/Schema/IBMDB2.hs index 64890219..ee30ed3e 100644 --- a/schema-th/src/Database/HDBC/Schema/IBMDB2.hs +++ b/schema-th/src/Database/HDBC/Schema/IBMDB2.hs @@ -1,5 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | @@ -11,19 +11,15 @@ -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.IBMDB2 ( - Columns, driverIBMDB2 + driverIBMDB2 ) where import Prelude hiding (length) import qualified Data.List as List -import Data.Int (Int16, Int32, Int64) -import Data.Char (toUpper, toLower) -import Data.Map (Map, fromList) -import qualified Data.Map as Map -import Data.Time (LocalTime, Day) +import Data.Char (toUpper) +import Data.Map (fromList) import Language.Haskell.TH (TypeQ) -import qualified Language.Haskell.TH.Name.CamelCase as TH import qualified Language.Haskell.TH.Name.Extra as TH import Database.HDBC (IConnection, SqlValue) @@ -31,84 +27,21 @@ import Database.HDBC (IConnection, SqlValue) import Database.HDBC.Record.Query (runQuery', listToUnique) import Database.HDBC.Record.Persistable () -import Database.Record.TH (derivingShow) import Database.Record.TH (defineRecordWithSqlTypeDefaultFromDefined) import qualified Database.Relational.Query.Table as Table -import Database.Relational.Query.Type (unsafeTypedQuery, fromRelation) -import Database.Relational.Query.TH (defineTableTypesAndRecordDefault) -import Database.Relational.Query - (Query, PrimeRelation, inner, relation, - wheres, (.=.), (!), placeholder, asc) -import Language.SQL.Keyword (Keyword(..)) -import qualified Language.SQL.Keyword as SQL +import Database.Relational.Schema.IBMDB2 + (normalizeColumn, notNull, getType, columnsQuerySQL, primaryKeyQuerySQL) import Database.HDBC.Schema.Driver (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) -import Database.Relational.Schema.DB2Syscat.Columns - -mapFromSqlDefault :: Map String TypeQ -mapFromSqlDefault = - fromList [("VARCHAR", [t|String|]), - ("CHAR", [t|String|]), - ("CHARACTER", [t|String|]), - ("TIMESTAMP", [t|LocalTime|]), - ("DATE", [t|Day|]), - ("SMALLINT", [t|Int16|]), - ("INTEGER", [t|Int32|]), - ("BIGINT", [t|Int64|]), - ("BLOB", [t|String|]), - ("CLOB", [t|String|])] - -normalizeField :: String -> String -normalizeField = map toLower - -notNull :: Columns -> Bool -notNull = (== "N") . nulls - -getType :: Map String TypeQ -> Columns -> (String, TypeQ) -getType mapFromSql rec = - (normalizeField $ colname rec, - mayNull $ mapFromSql Map.! typename rec) - where mayNull typ = if notNull rec - then typ - else [t| Maybe $(typ) |] - -columnsRelationFromTable :: PrimeRelation (String, String) Columns -columnsRelationFromTable = relation $ do - c <- inner columns - wheres $ c ! tabschema' .=. placeholder - wheres $ c ! tabname' .=. placeholder - asc $ c ! colno' - return c - -columnsQuerySQL :: Query (String, String) Columns -columnsQuerySQL = fromRelation columnsRelationFromTable - - -primaryKeyQuerySQL :: Query (String, String) String -primaryKeyQuerySQL = - unsafeTypedQuery . - SQL.unwordsSQL - $ [SELECT, "key.colname", - FROM, - "SYSCAT.tabconst", AS, "const", ",", - "SYSCAT.keycoluse", AS, "key", ",", - SQL.word (Table.name tableOfColumns), AS, "col", - WHERE, - "const.tabschema = col.tabschema", AND, - "const.tabname = col.tabname", AND, - "key.colname = col.colname", AND, - "const.constname = key.constname", AND, - - "col.nulls = 'N'", AND, - "const.type = 'P'", AND, "const.enforced = 'Y'", AND, - - "const.tabschema = ?", AND, "const.tabname = ?"] +import Database.Relational.Schema.DB2Syscat.Columns (Columns(Columns), tableOfColumns) +import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns +-- Specify type constructor and data constructor from same table name. $(defineRecordWithSqlTypeDefaultFromDefined [t| SqlValue |] (Table.shortName tableOfColumns)) @@ -131,7 +64,7 @@ getPrimaryKey' conn scm' tbl' = do scm = map toUpper scm' mayPrim <- runQuery' conn (scm, tbl) primaryKeyQuerySQL >>= listToUnique - let mayPrimaryKey = normalizeField `fmap` mayPrim + let mayPrimaryKey = normalizeColumn `fmap` mayPrim putLog $ "getPrimaryKey: primary key = " ++ show mayPrimaryKey return mayPrimaryKey @@ -156,9 +89,13 @@ getFields' tmap conn scm' tbl' = do putLog $ "getFields: num of columns = " ++ show (List.length cols) ++ ", not null columns = " ++ show notNullIdxs - let mapFromSql = fromList tmap `Map.union` mapFromSqlDefault + let getType' col = case getType (fromList tmap) col of + Nothing -> compileErrorIO + $ "Type mapping is not defined against DB2 type: " ++ Columns.typename col + Just p -> return p - return $ (map (getType mapFromSql) cols, notNullIdxs) + types <- mapM getType' cols + return (types, notNullIdxs) driverIBMDB2 :: IConnection conn => Driver conn driverIBMDB2 =