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

-- |
-- Module      : Database.HDBC.Schema.SQLServer
-- Copyright   : 2013 Shohei Murayama, 2017-2019 Kei Hibiono
-- License     : BSD3
--
-- Maintainer  : shohei.murayama@gmail.com
-- Stability   : experimental
-- Portability : unknown
module Database.HDBC.Schema.SQLServer (
  driverSQLServer,
  ) where

import qualified Database.Relational.Schema.SQLServer.Columns as Columns
import qualified Database.Relational.Schema.SQLServer.Types as Types

import Control.Applicative ((<$>), (<|>))
import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT)
import Data.Map (fromList)
import Data.Maybe (catMaybes)
import Database.HDBC (IConnection, SqlValue)
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.Record (FromSql, ToSql)
import Database.Relational.Schema.SQLServer (columnTypeQuerySQL, getType, normalizeColumn,
                                            notNull, primaryKeyQuerySQL)
import Database.Relational.Schema.SQLServer.Columns (Columns)
import Database.Relational.Schema.SQLServer.Types (Types)
import Database.Relational.Schema.SQLServer (config)
import Language.Haskell.TH (TypeQ)


instance FromSql SqlValue Columns
instance ToSql SqlValue Columns

instance FromSql SqlValue Types
instance ToSql SqlValue Types

logPrefix :: String -> String
logPrefix :: String -> String
logPrefix = (String
"SQLServer: " 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]
prims <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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) (Maybe String)
primaryKeyQuerySQL (String
scm,String
tbl)
    let primColumns :: [String]
primColumns = forall a b. (a -> b) -> [a] -> [b]
map String -> String
normalizeColumn [String]
prims
    LogChan -> String -> IO ()
putLog LogChan
lchan forall a b. (a -> b) -> a -> b
$ String
"getPrimaryKey: keys=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
primColumns
    forall (m :: * -> *) a. Monad m => a -> m a
return [String]
primColumns

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, Types), String)]
rows <- 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, Types), String)
columnTypeQuerySQL (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, Types), String)]
rows) 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 columnId :: ((Columns, b), b) -> Int32
columnId ((Columns
cols,b
_),b
_) = Columns -> Int32
Columns.columnId Columns
cols forall a. Num a => a -> a -> a
- Int32
1
    let notNullIdxs :: [Int]
notNullIdxs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b} {b}. ((Columns, b), b) -> Int32
columnId) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((Columns, Types), String) -> Bool
notNull forall a b. (a -> b) -> a -> b
$ [((Columns, Types), String)]
rows
    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
length [((Columns, Types), String)]
rows)
        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, Types), String) -> MaybeT IO (String, TypeQ)
getType' rec' :: ((Columns, Types), String)
rec'@((Columns
_,Types
typs),String
typScms) =
          forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Map String TypeQ
-> ((Columns, Types), String) -> Maybe (String, TypeQ)
getType (forall k a. Ord k => [(k, a)] -> Map k a
fromList TypeMap
tmap) ((Columns, Types), String)
rec') 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 SQLServer type: "
           forall a. [a] -> [a] -> [a]
++ String
typScms forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ Types -> String
Types.name Types
typs)
    TypeMap
types <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Columns, Types), String) -> MaybeT IO (String, TypeQ)
getType' [((Columns, Types), String)]
rows
    forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMap
types, [Int]
notNullIdxs)

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