{-# OPTIONS_GHC -fno-warn-orphans  #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- Module      : Database.HDBC.Schema.MySQL
-- Copyright   : 2013 Sho KURODA, 2017-2019 Kei Hibiono
-- License     : BSD3
--
-- Maintainer  : krdlab@gmail.com
-- Stability   : experimental
-- Portability : unknown
module Database.HDBC.Schema.MySQL
    (
      driverMySQL
    )
    where

import           Prelude                            hiding (length)
import           Language.Haskell.TH                (TypeQ)
import           Control.Applicative                ((<$>), (<|>))
import           Control.Monad                      (guard)
import           Control.Monad.Trans.Class          (lift)
import           Control.Monad.Trans.Maybe          (MaybeT)
import qualified Data.List                          as List
import           Data.Map                           (fromList)

import           Database.HDBC                      (IConnection, SqlValue)
import           Database.Record                    (FromSql, ToSql)
import           Database.HDBC.Record.Query         (runQuery')
import           Database.HDBC.Record.Persistable   ()
import           Database.HDBC.Schema.Driver        ( TypeMap
                                                    , LogChan
                                                    , putVerbose
                                                    , failWith
                                                    , maybeIO
                                                    , hoistMaybe
                                                    , Driver
                                                    , driverConfig
                                                    , getFieldsWithMap
                                                    , getPrimaryKey
                                                    , emptyDriver
                                                    )
import           Database.Relational.Schema.MySQL   ( normalizeColumn
                                                    , notNull
                                                    , getType
                                                    , columnsQuerySQL
                                                    , primaryKeyQuerySQL
                                                    )

import           Database.Relational.Schema.MySQL.Columns (Columns)
import qualified Database.Relational.Schema.MySQL.Columns as Columns
import           Database.Relational.Schema.MySQL (config)


instance FromSql SqlValue Columns
instance ToSql SqlValue Columns

logPrefix :: String -> String
logPrefix :: String -> String
logPrefix = (String
"MySQL: " 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
    [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
    [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
    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)
    where
        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 MySQL type: "
             forall a. [a] -> [a] -> [a]
++ Columns -> String
Columns.dataType Columns
col)

-- | Driver implementation
driverMySQL :: IConnection conn => Driver conn
driverMySQL :: forall conn. IConnection conn => Driver conn
driverMySQL =
    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 }