content: {-# OPTIONS_GHC -fno-warn-orphans  #-}
  {-# LANGUAGE TemplateHaskell       #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  
  -- |
  -- Module      : Database.Schema.HDBC.MySQL
  -- Copyright   : 2013 Sho KURODA, 2017-2019 Kei Hibiono
  -- License     : BSD3
  --
  -- Maintainer  : krdlab@gmail.com
  -- Stability   : experimental
  -- Portability : unknown
  module Database.Schema.HDBC.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.Relational.HDBC.Query     (runQuery')
  import           Database.Relational.HDBC.Persistable ()
  import           Database.Schema.HDBC.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 = ("MySQL: " ++)
  
  putLog :: LogChan -> String -> IO ()
  putLog lchan = putVerbose lchan . logPrefix
  
  compileError :: LogChan -> String -> MaybeT IO a
  compileError lchan = failWith lchan . logPrefix
  
  getPrimaryKey' :: IConnection conn
                 => conn
                 -> LogChan
                 -> String
                 -> String
                 -> IO [String]
  getPrimaryKey' conn lchan scm tbl = do
      primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl)
      let primaryKeyCols = normalizeColumn <$> primCols
      putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols
      return primaryKeyCols
  
  getColumns' :: IConnection conn
              => TypeMap
              -> conn
              -> LogChan
              -> String
              -> String
              -> IO ([(String, TypeQ)], [Int])
  getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do
      cols <- lift $ runQuery' conn columnsQuerySQL (scm, tbl)
      guard (not $ null cols) <|>
        compileError lchan
        ("getFields: No columns found: schema = " ++ scm
         ++ ", table = " ++ tbl)
      let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols
      lift . putLog lchan
        $  "getFields: num of columns = " ++ show (List.length cols)
        ++ ", not null columns = " ++ show notNullIdxs
      types <- mapM getType' cols
      return (types, notNullIdxs)
      where
          getType' col =
              hoistMaybe (getType (fromList tmap) col) <|>
              compileError lchan
              ("Type mapping is not defined against MySQL type: "
               ++ Columns.dataType col)
  
  -- | Driver implementation
  driverMySQL :: IConnection conn => Driver conn
  driverMySQL =
      emptyDriver { getFieldsWithMap = getColumns' }
                  { getPrimaryKey    = getPrimaryKey' }
                  { driverConfig     = config }
  