From e731a0ea164223c65941408155a5cb5c9d3d3fec Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Wed, 15 May 2013 01:10:06 +0900 Subject: [PATCH] Move system catalog schemas into relational-join package which doesn't depend on HDBC. --HG-- rename : schema-th/src/Database/HDBC/Schema/PgCatalog/PgAttribute.hs => relational-join/src/Database/Relational/Schema/PgCatalog/PgAttribute.hs rename : schema-th/src/Database/HDBC/Schema/PgCatalog/PgType.hs => relational-join/src/Database/Relational/Schema/PgCatalog/PgType.hs --- relational-join/relational-join.cabal | 5 + .../src/Database/Relational/Query/Table.hs | 9 +- .../Relational/Schema/DB2Syscat/Columns.hs | 97 +++++++++++++++++++ .../Schema/PgCatalog/PgAttribute.hs | 9 +- .../Relational}/Schema/PgCatalog/PgType.hs | 11 +-- schema-th/HDBC-schema-th.cabal | 4 +- schema-th/src/Database/HDBC/Schema/IBMDB2.hs | 92 ++---------------- .../src/Database/HDBC/Schema/PostgreSQL.hs | 22 ++++- schema-th/src/Database/HDBC/TH.hs | 14 ++- 9 files changed, 149 insertions(+), 114 deletions(-) create mode 100644 relational-join/src/Database/Relational/Schema/DB2Syscat/Columns.hs rename {schema-th/src/Database/HDBC => relational-join/src/Database/Relational}/Schema/PgCatalog/PgAttribute.hs (91%) rename {schema-th/src/Database/HDBC => relational-join/src/Database/Relational}/Schema/PgCatalog/PgType.hs (91%) diff --git a/relational-join/relational-join.cabal b/relational-join/relational-join.cabal index d9d3c0b6..2f95f938 100644 --- a/relational-join/relational-join.cabal +++ b/relational-join/relational-join.cabal @@ -32,6 +32,11 @@ library Database.Relational.Query.Type Database.Relational.Query.Derives Database.Relational.Query.TH + + Database.Relational.Schema.DB2Syscat.Columns + Database.Relational.Schema.PgCatalog.PgAttribute + Database.Relational.Schema.PgCatalog.PgType + -- other-modules: build-depends: base <5 , array diff --git a/relational-join/src/Database/Relational/Query/Table.hs b/relational-join/src/Database/Relational/Query/Table.hs index 090910b5..2cb4c2f4 100644 --- a/relational-join/src/Database/Relational/Query/Table.hs +++ b/relational-join/src/Database/Relational/Query/Table.hs @@ -1,15 +1,15 @@ module Database.Relational.Query.Table ( Untyped, name', width', columns', (!), - Table, unType, name, width, columns, index, table, outer, + Table, unType, name, shortName, width, columns, index, table, outer, ) where import Data.Array (Array, listArray, elems) import qualified Data.Array as Array data Untyped = Untyped - { name' :: String - , width' :: Int + { name' :: String + , width' :: Int , columnArray :: Array Int String } @@ -25,6 +25,9 @@ newtype Table r = Table { unType :: Untyped } name :: Table r -> String name = name' . unType +shortName :: Table r -> String +shortName = tail . dropWhile (/= '.') . name + width :: Table r -> Int width = width' . unType diff --git a/relational-join/src/Database/Relational/Schema/DB2Syscat/Columns.hs b/relational-join/src/Database/Relational/Schema/DB2Syscat/Columns.hs new file mode 100644 index 00000000..53ec4751 --- /dev/null +++ b/relational-join/src/Database/Relational/Schema/DB2Syscat/Columns.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Database.Relational.Schema.DB2Syscat.Columns +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +module Database.Relational.Schema.DB2Syscat.Columns where + +import Data.Int (Int16, Int32, Int64) + +import Database.Record.TH (derivingShow) +import Database.Relational.Query.TH (defineTableTypesAndRecordDefault) + +$(defineTableTypesAndRecordDefault + "SYSCAT" "columns" + [ + -- column schema type length NULL + -- ------------------------------ --------- ------------------ -------- ----- ------ + -- TABSCHEMA SYSIBM VARCHAR 128 0 No + ("tabschema", [t|String|]), + -- TABNAME SYSIBM VARCHAR 128 0 No + ("tabname", [t|String|]), + -- COLNAME SYSIBM VARCHAR 128 0 No + ("colname", [t|String|]), + -- COLNO SYSIBM SMALLINT 2 0 No + ("colno", [t|Int16|]), + -- TYPESCHEMA SYSIBM VARCHAR 128 0 No + ("typeschema", [t|String|]), + -- TYPENAME SYSIBM VARCHAR 18 0 No + ("typename", [t|String|]), + -- LENGTH SYSIBM INTEGER 4 0 No + ("length", [t|Int32|]), + -- SCALE SYSIBM SMALLINT 2 0 No + ("scale", [t|Int16|]), + -- DEFAULT SYSIBM VARCHAR 254 0 Yes + ("default", [t|Maybe String|]), + -- NULLS SYSIBM CHARACTER 1 0 No + ("nulls", [t|String|]), + -- CODEPAGE SYSIBM SMALLINT 2 0 No + ("codepage", [t|Int16|]), + -- LOGGED SYSIBM CHARACTER 1 0 No + ("logged", [t|String|]), + -- COMPACT SYSIBM CHARACTER 1 0 No + ("compact", [t|String|]), + -- COLCARD SYSIBM BIGINT 8 0 No + ("colcard", [t|Int64|]), + -- HIGH2KEY SYSIBM VARCHAR 254 0 Yes + ("high2key", [t|Maybe String|]), + -- LOW2KEY SYSIBM VARCHAR 254 0 Yes + ("low2key", [t|Maybe String|]), + -- AVGCOLLEN SYSIBM INTEGER 4 0 No + ("avgcollen", [t|Int32|]), + -- KEYSEQ SYSIBM SMALLINT 2 0 Yes + ("keyseq", [t|Maybe Int16|]), + -- PARTKEYSEQ SYSIBM SMALLINT 2 0 Yes + ("partkeyseq", [t|Maybe Int16|]), + -- NQUANTILES SYSIBM SMALLINT 2 0 No + ("nquantiles", [t|Int16|]), + -- NMOSTFREQ SYSIBM SMALLINT 2 0 No + ("nmostfreq", [t|Int16|]), + -- NUMNULLS SYSIBM BIGINT 8 0 No + ("numnulls", [t|Int64|]), + -- TARGET_TYPESCHEMA SYSIBM VARCHAR 128 0 Yes + ("target_typeschema", [t|Maybe String|]), + -- TARGET_TYPENAME SYSIBM VARCHAR 18 0 Yes + ("target_typename", [t|Maybe String|]), + -- SCOPE_TABSCHEMA SYSIBM VARCHAR 128 0 Yes + ("scope_tabschema", [t|Maybe String|]), + -- SCOPE_TABNAME SYSIBM VARCHAR 128 0 Yes + ("scope_tabname", [t|Maybe String|]), + -- SOURCE_TABSCHEMA SYSIBM VARCHAR 128 0 Yes + ("source_tabschema", [t|Maybe String|]), + -- SOURCE_TABNAME SYSIBM VARCHAR 128 0 Yes + ("source_tabname", [t|Maybe String|]), + -- DL_FEATURES SYSIBM CHARACTER 10 0 Yes + ("dl_features", [t|Maybe String|]), + -- SPECIAL_PROPS SYSIBM CHARACTER 8 0 Yes + ("special_props", [t|Maybe String|]), + -- HIDDEN SYSIBM CHARACTER 1 0 No + ("hidden", [t|String|]), + -- INLINE_LENGTH SYSIBM INTEGER 4 0 No + ("inline_length", [t|Int32|]), + -- IDENTITY SYSIBM CHARACTER 1 0 No + ("identity", [t|String|]), + -- GENERATED SYSIBM CHARACTER 1 0 No + ("generated", [t|String|]), + -- TEXT SYSIBM CLOB 65538 0 Yes + ("text", [t|Maybe String|]), + -- REMARKS SYSIBM VARCHAR 254 0 Yes + ("remarks", [t|Maybe String|]) + + ] + [derivingShow]) diff --git a/schema-th/src/Database/HDBC/Schema/PgCatalog/PgAttribute.hs b/relational-join/src/Database/Relational/Schema/PgCatalog/PgAttribute.hs similarity index 91% rename from schema-th/src/Database/HDBC/Schema/PgCatalog/PgAttribute.hs rename to relational-join/src/Database/Relational/Schema/PgCatalog/PgAttribute.hs index 2fd41373..747fd878 100644 --- a/schema-th/src/Database/HDBC/Schema/PgCatalog/PgAttribute.hs +++ b/relational-join/src/Database/Relational/Schema/PgCatalog/PgAttribute.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.PgCatalog.PgAttribute @@ -9,20 +8,14 @@ -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -module Database.HDBC.Schema.PgCatalog.PgAttribute where +module Database.Relational.Schema.PgCatalog.PgAttribute where import Data.Int (Int16, Int32) -import Database.HDBC (SqlValue) - -import Database.HDBC.Record.Persistable () - import Database.Record.TH (derivingShow) - import Database.Relational.Query.TH (defineTableTypesAndRecordDefault) $(defineTableTypesAndRecordDefault - [t| SqlValue |] "PG_CATALOG" "pg_attribute" [ diff --git a/schema-th/src/Database/HDBC/Schema/PgCatalog/PgType.hs b/relational-join/src/Database/Relational/Schema/PgCatalog/PgType.hs similarity index 91% rename from schema-th/src/Database/HDBC/Schema/PgCatalog/PgType.hs rename to relational-join/src/Database/Relational/Schema/PgCatalog/PgType.hs index 7fd87fe3..79d43c82 100644 --- a/schema-th/src/Database/HDBC/Schema/PgCatalog/PgType.hs +++ b/relational-join/src/Database/Relational/Schema/PgCatalog/PgType.hs @@ -1,28 +1,21 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} -- | --- Module : Database.HDBC.Schema.PgCatalog.PgType +-- Module : Database.Relational.Schema.PgCatalog.PgType -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -module Database.HDBC.Schema.PgCatalog.PgType where +module Database.Relational.Schema.PgCatalog.PgType where import Data.Int (Int16, Int32) -import Database.HDBC (SqlValue) - -import Database.HDBC.Record.Persistable () - import Database.Record.TH (derivingShow) - import Database.Relational.Query.TH (defineTableTypesAndRecordDefault) $(defineTableTypesAndRecordDefault - [t| SqlValue |] "PG_CATALOG" "pg_type" [ diff --git a/schema-th/HDBC-schema-th.cabal b/schema-th/HDBC-schema-th.cabal index b55eebe8..f11870a5 100644 --- a/schema-th/HDBC-schema-th.cabal +++ b/schema-th/HDBC-schema-th.cabal @@ -27,8 +27,8 @@ 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.PgCatalog.PgAttribute + -- Database.HDBC.Schema.PgCatalog.PgType Database.HDBC.Schema.PostgreSQL build-depends: base <5 diff --git a/schema-th/src/Database/HDBC/Schema/IBMDB2.hs b/schema-th/src/Database/HDBC/Schema/IBMDB2.hs index 771c2afd..64890219 100644 --- a/schema-th/src/Database/HDBC/Schema/IBMDB2.hs +++ b/schema-th/src/Database/HDBC/Schema/IBMDB2.hs @@ -23,6 +23,7 @@ import Data.Map (Map, fromList) import qualified Data.Map as Map import Data.Time (LocalTime, Day) 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,6 +32,7 @@ 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) @@ -44,90 +46,8 @@ import qualified Language.SQL.Keyword as SQL import Database.HDBC.Schema.Driver (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) - - -$(defineTableTypesAndRecordDefault - [t| SqlValue |] - "SYSCAT" "columns" - [ - -- column schema type length NULL - -- ------------------------------ --------- ------------------ -------- ----- ------ - -- TABSCHEMA SYSIBM VARCHAR 128 0 No - ("tabschema", [t|String|]), - -- TABNAME SYSIBM VARCHAR 128 0 No - ("tabname", [t|String|]), - -- COLNAME SYSIBM VARCHAR 128 0 No - ("colname", [t|String|]), - -- COLNO SYSIBM SMALLINT 2 0 No - ("colno", [t|Int16|]), - -- TYPESCHEMA SYSIBM VARCHAR 128 0 No - ("typeschema", [t|String|]), - -- TYPENAME SYSIBM VARCHAR 18 0 No - ("typename", [t|String|]), - -- LENGTH SYSIBM INTEGER 4 0 No - ("length", [t|Int32|]), - -- SCALE SYSIBM SMALLINT 2 0 No - ("scale", [t|Int16|]), - -- DEFAULT SYSIBM VARCHAR 254 0 Yes - ("default", [t|Maybe String|]), - -- NULLS SYSIBM CHARACTER 1 0 No - ("nulls", [t|String|]), - -- CODEPAGE SYSIBM SMALLINT 2 0 No - ("codepage", [t|Int16|]), - -- LOGGED SYSIBM CHARACTER 1 0 No - ("logged", [t|String|]), - -- COMPACT SYSIBM CHARACTER 1 0 No - ("compact", [t|String|]), - -- COLCARD SYSIBM BIGINT 8 0 No - ("colcard", [t|Int64|]), - -- HIGH2KEY SYSIBM VARCHAR 254 0 Yes - ("high2key", [t|Maybe String|]), - -- LOW2KEY SYSIBM VARCHAR 254 0 Yes - ("low2key", [t|Maybe String|]), - -- AVGCOLLEN SYSIBM INTEGER 4 0 No - ("avgcollen", [t|Int32|]), - -- KEYSEQ SYSIBM SMALLINT 2 0 Yes - ("keyseq", [t|Maybe Int16|]), - -- PARTKEYSEQ SYSIBM SMALLINT 2 0 Yes - ("partkeyseq", [t|Maybe Int16|]), - -- NQUANTILES SYSIBM SMALLINT 2 0 No - ("nquantiles", [t|Int16|]), - -- NMOSTFREQ SYSIBM SMALLINT 2 0 No - ("nmostfreq", [t|Int16|]), - -- NUMNULLS SYSIBM BIGINT 8 0 No - ("numnulls", [t|Int64|]), - -- TARGET_TYPESCHEMA SYSIBM VARCHAR 128 0 Yes - ("target_typeschema", [t|Maybe String|]), - -- TARGET_TYPENAME SYSIBM VARCHAR 18 0 Yes - ("target_typename", [t|Maybe String|]), - -- SCOPE_TABSCHEMA SYSIBM VARCHAR 128 0 Yes - ("scope_tabschema", [t|Maybe String|]), - -- SCOPE_TABNAME SYSIBM VARCHAR 128 0 Yes - ("scope_tabname", [t|Maybe String|]), - -- SOURCE_TABSCHEMA SYSIBM VARCHAR 128 0 Yes - ("source_tabschema", [t|Maybe String|]), - -- SOURCE_TABNAME SYSIBM VARCHAR 128 0 Yes - ("source_tabname", [t|Maybe String|]), - -- DL_FEATURES SYSIBM CHARACTER 10 0 Yes - ("dl_features", [t|Maybe String|]), - -- SPECIAL_PROPS SYSIBM CHARACTER 8 0 Yes - ("special_props", [t|Maybe String|]), - -- HIDDEN SYSIBM CHARACTER 1 0 No - ("hidden", [t|String|]), - -- INLINE_LENGTH SYSIBM INTEGER 4 0 No - ("inline_length", [t|Int32|]), - -- IDENTITY SYSIBM CHARACTER 1 0 No - ("identity", [t|String|]), - -- GENERATED SYSIBM CHARACTER 1 0 No - ("generated", [t|String|]), - -- TEXT SYSIBM CLOB 65538 0 Yes - ("text", [t|Maybe String|]), - -- REMARKS SYSIBM VARCHAR 254 0 Yes - ("remarks", [t|Maybe String|]) - - ] - [derivingShow]) - + +import Database.Relational.Schema.DB2Syscat.Columns mapFromSqlDefault :: Map String TypeQ mapFromSqlDefault = @@ -188,6 +108,10 @@ primaryKeyQuerySQL = "const.tabschema = ?", AND, "const.tabname = ?"] + +$(defineRecordWithSqlTypeDefaultFromDefined + [t| SqlValue |] (Table.shortName tableOfColumns)) + logPrefix :: String -> String logPrefix = ("IBMDB2: " ++) diff --git a/schema-th/src/Database/HDBC/Schema/PostgreSQL.hs b/schema-th/src/Database/HDBC/Schema/PostgreSQL.hs index a6bc6090..3f591a42 100644 --- a/schema-th/src/Database/HDBC/Schema/PostgreSQL.hs +++ b/schema-th/src/Database/HDBC/Schema/PostgreSQL.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.PostgreSQL @@ -14,6 +15,7 @@ module Database.HDBC.Schema.PostgreSQL ( ) where import Language.Haskell.TH (TypeQ) +import qualified Language.Haskell.TH.Name.CamelCase as TH import qualified Language.Haskell.TH.Name.Extra as TH import Data.Int (Int16, Int32, Int64) @@ -24,24 +26,27 @@ import Data.Time (DiffTime, NominalDiffTime, LocalTime, ZonedTime, Day, TimeOfDay) -import Database.HDBC (IConnection) +import Database.HDBC (IConnection, SqlValue) +import Database.Record.TH (defineRecordWithSqlTypeDefaultFromDefined) import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.Type (unsafeTypedQuery) import Database.Relational.Query (Query(untypeQuery)) import Database.HDBC.Record.Query (runQuery', listToUnique) -import Database.HDBC.Schema.PgCatalog.PgAttribute (PgAttribute, tableOfPgAttribute) -import qualified Database.HDBC.Schema.PgCatalog.PgAttribute as Attr -import Database.HDBC.Schema.PgCatalog.PgType (PgType(..), tableOfPgType) -import qualified Database.HDBC.Schema.PgCatalog.PgType as Type +import Database.Relational.Schema.PgCatalog.PgAttribute (PgAttribute(PgAttribute), tableOfPgAttribute) +import qualified Database.Relational.Schema.PgCatalog.PgAttribute as Attr +import Database.Relational.Schema.PgCatalog.PgType (PgType(..), tableOfPgType) +import qualified Database.Relational.Schema.PgCatalog.PgType as Type import Language.SQL.Keyword (Keyword(..), (<.>), (.=.)) import qualified Language.SQL.Keyword as SQL +import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) + mapFromSqlDefault :: Map String TypeQ mapFromSqlDefault = fromList [("bool", [t| Bool |]), @@ -160,6 +165,13 @@ primaryKeyQuerySQL = "contype" .=. "'p'", AND, "array_length (conkey, 1)" .=. "1"] + +$(defineRecordWithSqlTypeDefaultFromDefined + [t| SqlValue |] (Table.shortName tableOfPgAttribute)) + +$(defineRecordWithSqlTypeDefaultFromDefined + [t| SqlValue |] (Table.shortName tableOfPgType)) + logPrefix :: String -> String logPrefix = ("PostgreSQL: " ++) diff --git a/schema-th/src/Database/HDBC/TH.hs b/schema-th/src/Database/HDBC/TH.hs index aaa452f5..dfc13e69 100644 --- a/schema-th/src/Database/HDBC/TH.hs +++ b/schema-th/src/Database/HDBC/TH.hs @@ -29,18 +29,26 @@ import Database.HDBC (IConnection, SqlValue) import Language.Haskell.TH.Name.CamelCase (ConName) import Language.Haskell.TH (Q, runIO, TypeQ, Dec) -import Database.HDBC.Session (withConnectionIO) +import Database.Record.TH (defineRecordWithSqlTypeDefault) import qualified Database.Relational.Query.TH as Relational + +import Database.HDBC.Session (withConnectionIO) import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver (Driver, getFields, getPrimaryKey) defineTableDefault' :: String -> String -> [(String, TypeQ)] -> [ConName] -> Q [Dec] -defineTableDefault' = Relational.defineTableDefault' [t| SqlValue |] +defineTableDefault' schema table columns derives = do + modelD <- Relational.defineTableDefault' schema table columns derives + sqlvD <- defineRecordWithSqlTypeDefault [t| SqlValue |] table columns + return $ modelD ++ sqlvD defineTableDefault :: String -> String -> [(String, TypeQ)] -> [ConName] -> Maybe Int -> Maybe Int -> Q [Dec] -defineTableDefault = Relational.defineTableDefault [t| SqlValue |] +defineTableDefault schema table columns derives primary notNull = do + modelD <- Relational.defineTableDefault schema table columns derives primary notNull + sqlvD <- defineRecordWithSqlTypeDefault [t| SqlValue |] table columns + return $ modelD ++ sqlvD putLog :: String -> IO () putLog = putStrLn