{-# LANGUAGE TemplateHaskell #-}

module Database.Relational.Schema.SQLServer (
  module Database.Relational.Schema.SQLServer.Config,

  getType, normalizeColumn, notNull,
  columnTypeQuerySQL, primaryKeyQuerySQL
  ) where

import qualified Data.Map as Map
import qualified Database.Relational.Schema.SQLServer.Columns as Columns
import qualified Database.Relational.Schema.SQLServer.Indexes as Indexes
import qualified Database.Relational.Schema.SQLServer.IndexColumns as IndexColumns
import qualified Database.Relational.Schema.SQLServer.Types as Types

import Control.Applicative ((<|>))
import Data.ByteString (ByteString)
import Data.Char (toLower)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Map (Map)
import Data.Time (LocalTime, Day, TimeOfDay)
import Database.Relational (Query, Relation, PlaceHolders, Record, Flat,
                            (!), (.=.), (><), asc, relationalQuery, just, placeholder',
                            query, relation', unsafeShowSql,
                            unsafeProjectSql, wheres)

import Database.Relational.Schema.SQLServer.Config
import Database.Relational.Schema.SQLServer.Columns
import Database.Relational.Schema.SQLServer.Indexes
import Database.Relational.Schema.SQLServer.IndexColumns
import Database.Relational.Schema.SQLServer.Types
import Language.Haskell.TH (TypeQ)

--{-# ANN module "HLint: ignore Redundant $" #-}

mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (String
"text",          [t|ByteString|])
                 , (String
"date",          [t|Day|])
                 , (String
"time",          [t|TimeOfDay|])
                 , (String
"tinyint",       [t|Int8|])
                 , (String
"smallint",      [t|Int16|])
                 , (String
"int",           [t|Int32|])
                 , (String
"real",          [t|Double|])
                 , (String
"datetime",      [t|LocalTime|])
                 , (String
"float",         [t|Double|])
                 , (String
"ntext",         [t|String|])
                 , (String
"bit",           [t|Char|])
                 , (String
"bigint",        [t|Int64|])
                 , (String
"varchar",       [t|String|])
                 , (String
"binary",        [t|ByteString|])
                 , (String
"char",          [t|String|])
                 , (String
"timestamp",     [t|LocalTime|])
                 , (String
"nvarchar",      [t|String|])
                 , (String
"nchar",         [t|String|])
                 ]

normalizeColumn :: String -> String
normalizeColumn :: String -> String
normalizeColumn = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower

notNull :: ((Columns,Types),String) -> Bool
notNull :: ((Columns, Types), String) -> Bool
notNull ((Columns
cols,Types
_),String
_) = Maybe Bool -> Bool
isTrue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Columns -> Maybe Bool
Columns.isNullable forall a b. (a -> b) -> a -> b
$ Columns
cols
  where
    isTrue :: Maybe Bool -> Bool
isTrue (Just Bool
b) = Bool -> Bool
not Bool
b
    isTrue Maybe Bool
_        = Bool
True

getType :: Map String TypeQ -> ((Columns,Types),String) -> Maybe (String, TypeQ)
getType :: Map String TypeQ
-> ((Columns, Types), String) -> Maybe (String, TypeQ)
getType Map String TypeQ
mapFromSql rec :: ((Columns, Types), String)
rec@((Columns
cols,Types
typs),String
typScms) = do
    String
colName <- Columns -> Maybe String
Columns.name Columns
cols
    TypeQ
typ <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String TypeQ
mapFromSql
           forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
           forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String TypeQ
mapFromSqlDefault
    forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
normalizeColumn String
colName, forall {m :: * -> *}. Quote m => m Type -> m Type
mayNull TypeQ
typ)
  where
    key :: String
key = if String
typScms forall a. Eq a => a -> a -> Bool
== String
"sys"
            then Types -> String
Types.name Types
typs
            else String
typScms forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ Types -> String
Types.name Types
typs
    mayNull :: m Type -> m Type
mayNull m Type
typ = if ((Columns, Types), String) -> Bool
notNull ((Columns, Types), String)
rec
                    then m Type
typ
                    else [t|Maybe $(typ)|]

sqlsrvTrue :: Record Flat Bool
sqlsrvTrue :: Record Flat Bool
sqlsrvTrue =  forall c t. SqlContext c => String -> Record c t
unsafeProjectSql String
"1"

sqlsrvObjectId :: Record Flat String -> Record Flat String -> Record Flat Int32
sqlsrvObjectId :: Record Flat String -> Record Flat String -> Record Flat Int32
sqlsrvObjectId Record Flat String
s Record Flat String
t = forall c t. SqlContext c => String -> Record c t
unsafeProjectSql forall a b. (a -> b) -> a -> b
$
    String
"OBJECT_ID(" forall a. [a] -> [a] -> [a]
++ forall c a. Record c a -> String
unsafeShowSql Record Flat String
s forall a. [a] -> [a] -> [a]
++ String
" + '.' + " forall a. [a] -> [a] -> [a]
++ forall c a. Record c a -> String
unsafeShowSql Record Flat String
t forall a. [a] -> [a] -> [a]
++ String
")"

sqlsrvOidPlaceHolder :: (PlaceHolders (String, String), Record Flat Int32)
sqlsrvOidPlaceHolder :: (PlaceHolders (String, String), Record Flat Int32)
sqlsrvOidPlaceHolder =  (PlaceHolders String
nsParam forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< PlaceHolders String
relParam, Record Flat Int32
oid)
  where
    (PlaceHolders String
nsParam, (PlaceHolders String
relParam, Record Flat Int32
oid)) =
      forall t c a.
(PersistableWidth t, SqlContext c) =>
(Record c t -> a) -> (PlaceHolders t, a)
placeholder' (\Record Flat String
nsPh ->
                     forall t c a.
(PersistableWidth t, SqlContext c) =>
(Record c t -> a) -> (PlaceHolders t, a)
placeholder' (\Record Flat String
relPh ->
                                    Record Flat String -> Record Flat String -> Record Flat Int32
sqlsrvObjectId Record Flat String
nsPh Record Flat String
relPh))

columnTypeRelation :: Relation (String,String) ((Columns,Types),String)
columnTypeRelation :: Relation (String, String) ((Columns, Types), String)
columnTypeRelation = forall p r. SimpleQuery p r -> Relation p r
relation' forall a b. (a -> b) -> a -> b
$ do
    Record Flat Columns
cols <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () Columns
columns
    Record Flat Types
typs <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () Types
types

    forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat Columns
cols forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int32
Columns.userTypeId' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Types
typs forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Types Int32
Types.userTypeId'
    forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat Columns
cols forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int32
Columns.objectId'   forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Int32
oid
    forall (m :: * -> *) c t. Monad m => Record c t -> Orderings c m ()
asc forall a b. (a -> b) -> a -> b
$ Record Flat Columns
cols forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int32
Columns.columnId'
    forall (m :: * -> *) a. Monad m => a -> m a
return   (PlaceHolders (String, String)
params, Record Flat Columns
cols forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< Record Flat Types
typs forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< forall {c} {c} {a} {t}. SqlContext c => Record c a -> Record c t
sqlsrvSchemaName (Record Flat Types
typs forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Types Int32
Types.schemaId' :: Record Flat Int32))
  where
    (PlaceHolders (String, String)
params, Record Flat Int32
oid) = (PlaceHolders (String, String), Record Flat Int32)
sqlsrvOidPlaceHolder
    sqlsrvSchemaName :: Record c a -> Record c t
sqlsrvSchemaName Record c a
i = forall c t. SqlContext c => String -> Record c t
unsafeProjectSql forall a b. (a -> b) -> a -> b
$
        String
"SCHEMA_NAME(" forall a. [a] -> [a] -> [a]
++ forall c a. Record c a -> String
unsafeShowSql Record c a
i forall a. [a] -> [a] -> [a]
++ String
")"

columnTypeQuerySQL :: Query (String, String) ((Columns, Types), String)
columnTypeQuerySQL :: Query (String, String) ((Columns, Types), String)
columnTypeQuerySQL =  forall p r. Relation p r -> Query p r
relationalQuery Relation (String, String) ((Columns, Types), String)
columnTypeRelation

primaryKeyRelation :: Relation (String,String) (Maybe String)
primaryKeyRelation :: Relation (String, String) (Maybe String)
primaryKeyRelation = forall p r. SimpleQuery p r -> Relation p r
relation' forall a b. (a -> b) -> a -> b
$ do
    Record Flat Indexes
idxes  <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () Indexes
indexes
    Record Flat IndexColumns
idxcol <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () IndexColumns
indexColumns
    Record Flat Columns
cols   <- forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () Columns
columns
    forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat Indexes
idxes  forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Indexes Int32
Indexes.objectId'      forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat IndexColumns
idxcol forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi IndexColumns Int32
IndexColumns.objectId'
    forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat Indexes
idxes  forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Indexes Int32
Indexes.indexId'       forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat IndexColumns
idxcol forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi IndexColumns Int32
IndexColumns.indexId'
    forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat IndexColumns
idxcol forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi IndexColumns Int32
IndexColumns.objectId' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Columns
cols   forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int32
Columns.objectId'
    forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat IndexColumns
idxcol forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi IndexColumns Int32
IndexColumns.columnId' forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Columns
cols   forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns Int32
Columns.columnId'
    forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat Indexes
idxes  forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Indexes (Maybe Bool)
Indexes.isPrimaryKey'  forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. forall (p :: * -> *) a. ProjectableMaybe p => p a -> p (Maybe a)
just Record Flat Bool
sqlsrvTrue
    let (PlaceHolders (String, String)
params, Record Flat Int32
oid) = (PlaceHolders (String, String), Record Flat Int32)
sqlsrvOidPlaceHolder
    forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres forall a b. (a -> b) -> a -> b
$ Record Flat Indexes
idxes  forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Indexes Int32
Indexes.objectId'      forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Int32
oid
    forall (m :: * -> *) c t. Monad m => Record c t -> Orderings c m ()
asc    forall a b. (a -> b) -> a -> b
$ Record Flat IndexColumns
idxcol forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi IndexColumns Int32
IndexColumns.keyOrdinal'
    forall (m :: * -> *) a. Monad m => a -> m a
return   (PlaceHolders (String, String)
params, Record Flat Columns
cols   forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi Columns (Maybe String)
Columns.name')

primaryKeyQuerySQL :: Query (String,String) (Maybe String)
primaryKeyQuerySQL :: Query (String, String) (Maybe String)
primaryKeyQuerySQL =  forall p r. Relation p r -> Query p r
relationalQuery Relation (String, String) (Maybe String)
primaryKeyRelation