Move schema query for DB2 which does not depend on HDBC.

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

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 = ?"]

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

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

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 =