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

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

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

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

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

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

sqlsrvOidPlaceHolder :: (PlaceHolders (String, String), Record Flat Int32)
sqlsrvOidPlaceHolder :: (PlaceHolders (String, String), Record Flat Int32)
sqlsrvOidPlaceHolder =  (PlaceHolders String
nsParam PlaceHolders String
-> PlaceHolders String -> PlaceHolders (String, String)
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< PlaceHolders String
relParam, Record Flat Int32
oid)
  where
    (nsParam :: PlaceHolders String
nsParam, (relParam :: PlaceHolders String
relParam, oid :: Record Flat Int32
oid)) =
      (Record Flat String -> (PlaceHolders String, Record Flat Int32))
-> (PlaceHolders String, (PlaceHolders String, Record Flat Int32))
forall t c a.
(PersistableWidth t, SqlContext c) =>
(Record c t -> a) -> (PlaceHolders t, a)
placeholder' (\nsPh :: Record Flat String
nsPh ->
                     (Record Flat String -> Record Flat Int32)
-> (PlaceHolders String, Record Flat Int32)
forall t c a.
(PersistableWidth t, SqlContext c) =>
(Record c t -> a) -> (PlaceHolders t, a)
placeholder' (\relPh :: 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 = SimpleQuery (String, String) ((Columns, Types), String)
-> Relation (String, String) ((Columns, Types), String)
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery (String, String) ((Columns, Types), String)
 -> Relation (String, String) ((Columns, Types), String))
-> SimpleQuery (String, String) ((Columns, Types), String)
-> Relation (String, String) ((Columns, Types), String)
forall a b. (a -> b) -> a -> b
$ do
    Record Flat Columns
cols <- Relation () Columns
-> Orderings Flat QueryCore (Record Flat Columns)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () Columns
columns
    Record Flat Types
typs <- Relation () Types -> Orderings Flat QueryCore (Record Flat Types)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () Types
types

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

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