{-# 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 = (String
"IBMDB2: " forall a. [a] -> [a] -> [a]
++)
putLog :: LogChan -> String -> IO ()
putLog :: LogChan -> String -> IO ()
putLog LogChan
lchan = LogChan -> String -> IO ()
putVerbose LogChan
lchan forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix
compileError :: LogChan -> String -> MaybeT IO a
compileError :: forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan = forall a. LogChan -> String -> MaybeT IO a
failWith LogChan
lchan forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
logPrefix
getPrimaryKey' :: IConnection conn
=> conn
-> LogChan
-> String
-> String
-> IO [String]
getPrimaryKey' :: forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' conn
conn LogChan
lchan String
scm' String
tbl' = do
let tbl :: String
tbl = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
tbl'
scm :: String
scm = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
scm'
[String]
primCols <- 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
primCols
LogChan -> String -> IO ()
putLog LogChan
lchan forall a b. (a -> b) -> a -> b
$ String
"getPrimaryKey: primary key = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
primaryKeyCols
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
primaryKeyCols
getColumns' :: IConnection conn
=> TypeMap
-> conn
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getColumns' :: forall conn.
IConnection conn =>
TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' TypeMap
tmap conn
conn LogChan
lchan String
scm' String
tbl' = forall b a. b -> (a -> b) -> MaybeT IO a -> IO b
maybeIO ([], []) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ do
let tbl :: String
tbl = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
tbl'
scm :: String
scm = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
scm'
[Columns]
cols <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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)
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Columns]
cols) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan (String
"getFields: No columns found: schema = " forall a. [a] -> [a] -> [a]
++ String
scm forall a. [a] -> [a] -> [a]
++ String
", table = " forall a. [a] -> [a] -> [a]
++ String
tbl)
let notNullIdxs :: [Int]
notNullIdxs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Columns -> Bool
notNull forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall a b. (a -> b) -> a -> b
$ [Columns]
cols
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogChan -> String -> IO ()
putLog LogChan
lchan
forall a b. (a -> b) -> a -> b
$ String
"getFields: num of columns = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Columns]
cols)
forall a. [a] -> [a] -> [a]
++ String
", not null columns = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Int]
notNullIdxs
let getType' :: Columns -> MaybeT IO (String, TypeQ)
getType' Columns
col =
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Map String TypeQ -> Columns -> Maybe (String, TypeQ)
getType (forall k a. Ord k => [(k, a)] -> Map k a
fromList TypeMap
tmap) Columns
col) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
forall a. LogChan -> String -> MaybeT IO a
compileError LogChan
lchan (String
"Type mapping is not defined against DB2 type: " forall a. [a] -> [a] -> [a]
++ Columns -> String
Columns.typename Columns
col)
TypeMap
types <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap
types, [Int]
notNullIdxs)
driverIBMDB2 :: IConnection conn => Driver conn
driverIBMDB2 :: forall conn. IConnection conn => Driver conn
driverIBMDB2 =
forall conn. IConnection conn => Driver conn
emptyDriver { getFieldsWithMap :: TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getFieldsWithMap = forall conn.
IConnection conn =>
TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getColumns' }
{ getPrimaryKey :: conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey = forall conn.
IConnection conn =>
conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey' }
{ driverConfig :: Config
driverConfig = Config
config }