{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.HDBC.Schema.IBMDB2 (
driverIBMDB2
) where
import Prelude hiding (length)
import Language.Haskell.TH (TypeQ)
import qualified Data.List as List
import Data.Char (toUpper)
import Data.Map (fromList)
import Control.Applicative ((<$>), (<|>))
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT)
import Database.HDBC (IConnection, SqlValue)
import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()
import Database.Record (FromSql, ToSql)
import Database.Relational.Schema.IBMDB2
(normalizeColumn, notNull, getType, columnsQuerySQL, primaryKeyQuerySQL)
import Database.Relational.Schema.IBMDB2.Columns (Columns)
import qualified Database.Relational.Schema.IBMDB2.Columns as Columns
import Database.Relational.Schema.IBMDB2 (config)
import Database.HDBC.Schema.Driver
(TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,
Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver)
instance FromSql SqlValue Columns
instance ToSql SqlValue Columns
logPrefix :: String -> String
logPrefix :: String -> String
logPrefix = ("IBMDB2: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
putLog :: LogChan -> String -> IO ()
putLog :: LogChan -> String -> IO ()
putLog lchan :: LogChan
lchan = LogChan -> String -> IO ()
putVerbose LogChan
lchan (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix
compileError :: LogChan -> String -> MaybeT IO a
compileError :: LogChan -> String -> MaybeT IO a
compileError lchan :: LogChan
lchan = LogChan -> String -> MaybeT IO a
forall a. LogChan -> String -> MaybeT IO a
failWith LogChan
lchan (String -> MaybeT IO a)
-> (String -> String) -> String -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix
getPrimaryKey' :: IConnection conn
=> conn
-> LogChan
-> String
-> String
-> IO [String]
getPrimaryKey' :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' conn :: conn
conn lchan :: LogChan
lchan scm' :: String
scm' tbl' :: String
tbl' = do
let tbl :: String
tbl = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
tbl'
scm :: String
scm = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
scm'
[String]
primCols <- conn
-> Query (String, String) String -> (String, String) -> IO [String]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn Query (String, String) String
primaryKeyQuerySQL (String
scm, String
tbl)
let primaryKeyCols :: [String]
primaryKeyCols = String -> String
normalizeColumn (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
primCols
LogChan -> String -> IO ()
putLog LogChan
lchan (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "getPrimaryKey: primary key = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
primaryKeyCols
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
primaryKeyCols
getColumns' :: IConnection conn
=> TypeMap
-> conn
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getColumns' :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' tmap :: TypeMap
tmap conn :: conn
conn lchan :: LogChan
lchan scm' :: String
scm' tbl' :: String
tbl' = (TypeMap, [Int])
-> ((TypeMap, [Int]) -> (TypeMap, [Int]))
-> MaybeT IO (TypeMap, [Int])
-> IO (TypeMap, [Int])
forall b a. b -> (a -> b) -> MaybeT IO a -> IO b
maybeIO ([], []) (TypeMap, [Int]) -> (TypeMap, [Int])
forall a. a -> a
id (MaybeT IO (TypeMap, [Int]) -> IO (TypeMap, [Int]))
-> MaybeT IO (TypeMap, [Int]) -> IO (TypeMap, [Int])
forall a b. (a -> b) -> a -> b
$ do
let tbl :: String
tbl = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
tbl'
scm :: String
scm = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
scm'
[Columns]
cols <- IO [Columns] -> MaybeT IO [Columns]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [Columns] -> MaybeT IO [Columns])
-> IO [Columns] -> MaybeT IO [Columns]
forall a b. (a -> b) -> a -> b
$ conn
-> Query (String, String) Columns
-> (String, String)
-> IO [Columns]
forall conn p a.
(IConnection conn, ToSql SqlValue p, FromSql SqlValue a) =>
conn -> Query p a -> p -> IO [a]
runQuery' conn
conn Query (String, String) Columns
columnsQuerySQL (String
scm, String
tbl)
Bool -> MaybeT IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Columns] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Columns]
cols) MaybeT IO () -> MaybeT IO () -> MaybeT IO ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
LogChan -> String -> MaybeT IO ()
forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan ("getFields: No columns found: schema = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
scm String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", table = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tbl)
let notNullIdxs :: [Int]
notNullIdxs = ((Int, Columns) -> Int) -> [(Int, Columns)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Columns) -> Int
forall a b. (a, b) -> a
fst ([(Int, Columns)] -> [Int])
-> ([Columns] -> [(Int, Columns)]) -> [Columns] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Columns) -> Bool) -> [(Int, Columns)] -> [(Int, Columns)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Columns -> Bool
notNull (Columns -> Bool)
-> ((Int, Columns) -> Columns) -> (Int, Columns) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Columns) -> Columns
forall a b. (a, b) -> b
snd) ([(Int, Columns)] -> [(Int, Columns)])
-> ([Columns] -> [(Int, Columns)]) -> [Columns] -> [(Int, Columns)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Columns] -> [(Int, Columns)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] ([Columns] -> [Int]) -> [Columns] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Columns]
cols
IO () -> MaybeT IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> MaybeT IO ())
-> (String -> IO ()) -> String -> MaybeT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogChan -> String -> IO ()
putLog LogChan
lchan
(String -> MaybeT IO ()) -> String -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ "getFields: num of columns = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Columns] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Columns]
cols)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", not null columns = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
notNullIdxs
let getType' :: Columns -> MaybeT IO (String, TypeQ)
getType' col :: Columns
col =
Maybe (String, TypeQ) -> MaybeT IO (String, TypeQ)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Map String TypeQ -> Columns -> Maybe (String, TypeQ)
getType (TypeMap -> Map String TypeQ
forall k a. Ord k => [(k, a)] -> Map k a
fromList TypeMap
tmap) Columns
col) MaybeT IO (String, TypeQ)
-> MaybeT IO (String, TypeQ) -> MaybeT IO (String, TypeQ)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
LogChan -> String -> MaybeT IO (String, TypeQ)
forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan ("Type mapping is not defined against DB2 type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Columns -> String
Columns.typename Columns
col)
TypeMap
types <- (Columns -> MaybeT IO (String, TypeQ))
-> [Columns] -> MaybeT IO TypeMap
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Columns -> MaybeT IO (String, TypeQ)
getType' [Columns]
cols
(TypeMap, [Int]) -> MaybeT IO (TypeMap, [Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap
types, [Int]
notNullIdxs)
driverIBMDB2 :: IConnection conn => Driver conn
driverIBMDB2 :: Driver conn
driverIBMDB2 =
Driver conn
forall conn. IConnection conn => Driver conn
emptyDriver { getFieldsWithMap :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getFieldsWithMap = TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
forall conn.
IConnection conn =>
TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' }
{ getPrimaryKey :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey = conn -> LogChan -> String -> String -> IO [String]
forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' }
{ driverConfig :: Config
driverConfig = Config
config }