{-# OPTIONS_GHC -fno-warn-orphans  #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.HDBC.Schema.MySQL
    (
      driverMySQL
    )
    where

import           Prelude                            hiding (length)
import           Language.Haskell.TH                (TypeQ)
import           Language.Haskell.TH.Lib.Extra      (reportMessage)
import qualified Data.List                          as List
import           Data.Map                           (fromList)

import           Database.HDBC                      (IConnection, SqlValue)
import           Database.HDBC.Record.Query         (runQuery')
import           Database.HDBC.Record.Persistable   ()
import           Database.HDBC.Schema.Driver        ( TypeMap
                                                    , Driver
                                                    , getFieldsWithMap
                                                    , getPrimaryKey
                                                    , emptyDriver
                                                    )
import           Database.Record.TH                 (makeRecordPersistableWithSqlTypeDefaultFromDefined)
import           Database.Relational.Schema.MySQL   ( normalizeColumn
                                                    , notNull
                                                    , getType
                                                    , columnsQuerySQL
                                                    , primaryKeyQuerySQL
                                                    )

import           Database.Relational.Schema.MySQLInfo.Columns (Columns)
import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns

$(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''Columns)

logPrefix :: String -> String
logPrefix = ("MySQL: " ++)

putLog :: String -> IO ()
putLog = reportMessage . logPrefix

compileErrorIO :: String -> IO a
compileErrorIO = fail . logPrefix

getPrimaryKey' :: IConnection conn
               => conn
               -> String
               -> String
               -> IO [String]
getPrimaryKey' conn scm tbl = do
    primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl)
    let primaryKeyCols = normalizeColumn `fmap` primCols
    putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols
    return primaryKeyCols

getFields' :: IConnection conn
           => TypeMap
           -> conn
           -> String
           -> String
           -> IO ([(String, TypeQ)], [Int])
getFields' tmap conn scm tbl = do
    cols <- runQuery' conn columnsQuerySQL (scm, tbl)
    case cols of
        [] -> compileErrorIO
                $ "getFields: No columns found: schema = " ++ scm
                ++ ", table = " ++ tbl
        _  -> return ()
    let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols
    putLog
      $  "getFields: num of columns = " ++ show (List.length cols)
      ++ ", not null columns = " ++ show notNullIdxs
    types <- mapM getType' cols
    return (types, notNullIdxs)
    where
        getType' col =
            case getType (fromList tmap) col of
                Nothing -> compileErrorIO
                             $ "Type mapping is not defined against MySQL type: "
                             ++ Columns.dataType col
                Just p  -> return p

-- | Driver implementation
driverMySQL :: IConnection conn => Driver conn
driverMySQL =
    emptyDriver { getFieldsWithMap = getFields' }
                { getPrimaryKey    = getPrimaryKey' }