{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE CPP #-}
module Database.Relational.TH (
defineTable,
unsafeInlineQuery,
inlineQuery,
defineTableTypesAndRecord,
defineHasPrimaryKeyInstance,
defineHasPrimaryKeyInstanceWithConfig,
defineHasNotNullKeyInstance,
defineHasNotNullKeyInstanceWithConfig,
defineScalarDegree,
defineColumnsDefault, defineOverloadedColumnsDefault,
defineColumns, defineOverloadedColumns,
defineTuplePi,
defineTableTypes, defineTableTypesWithConfig,
definePrimaryQuery,
definePrimaryUpdate,
derivationExpDefault,
tableVarExpDefault,
relationVarExp,
defineSqlsWithPrimaryKey,
defineSqlsWithPrimaryKeyDefault,
makeRelationalRecordDefault,
makeRelationalRecordDefault',
reifyRelation,
) where
import Data.Char (toUpper, toLower)
import Data.List (foldl1')
import Data.Array.IArray ((!))
import Data.Functor.ProductIsomorphic.TH
(reifyRecordType, defineProductConstructor)
import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..))
import Language.Haskell.TH
(Name, nameBase, Q, reify, Dec, instanceD, ExpQ, stringE, listE,
TypeQ, Type (AppT, ConT), varT, tupleT, appT, arrowT)
import Language.Haskell.TH.Compat.Reify (unVarI)
import Language.Haskell.TH.Compat.Constraint (classP)
import Language.Haskell.TH.Name.CamelCase
(VarName, varName, ConName (ConName), conName,
varCamelcaseName, toVarExp, toTypeCon)
import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE)
import Database.Record.TH
(columnOffsetsVarNameDefault, recordTypeName, recordTemplate,
defineRecordTypeWithConfig, defineHasColumnConstraintInstance)
import qualified Database.Record.TH as Record
import Database.Relational
(Table, Pi, id', Relation, LiteralSQL,
NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..), defaultConfig,
Config (normalizedTableName, disableOverloadedProjection, disableSpecializedProjection,
schemaNameMode, nameConfig, identifierQuotation),
Query, untypeQuery, relationalQuery_, relationalQuery, KeyUpdate,
Insert, insert, InsertQuery, insertQuery,
HasConstraintKey(constraintKey), Primary, NotNull, primarySelect, primaryUpdate)
import Database.Relational.InternalTH.Base (defineTuplePi, defineRecordProjections)
import Database.Relational.Scalar (defineScalarDegree)
import Database.Relational.Constraint (unsafeDefineConstraintKey)
import Database.Relational.Table (TableDerivable (..))
import qualified Database.Relational.Table as Table
import Database.Relational.Relation (derivedRelation)
import Database.Relational.SimpleSql (QuerySuffix)
import Database.Relational.Type (unsafeTypedQuery)
import qualified Database.Relational.Pi.Unsafe as UnsafePi
import qualified Database.Relational.InternalTH.Overloaded as Overloaded
defineHasConstraintKeyInstance :: TypeQ
-> TypeQ
-> TypeQ
-> [Int]
-> Q [Dec]
defineHasConstraintKeyInstance :: TypeQ -> TypeQ -> TypeQ -> [Int] -> Q [Dec]
defineHasConstraintKeyInstance TypeQ
constraint TypeQ
recType TypeQ
colType [Int]
indexes =
[d| instance HasConstraintKey $constraint $recType $colType where
constraintKey = unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes])
|]
defineHasPrimaryKeyInstance :: TypeQ
-> TypeQ
-> [Int]
-> Q [Dec]
defineHasPrimaryKeyInstance :: TypeQ -> TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstance TypeQ
recType TypeQ
colType [Int]
indexes = do
[Dec]
kc <- TypeQ -> [Int] -> Q [Dec]
Record.defineHasPrimaryKeyInstance TypeQ
recType [Int]
indexes
[Dec]
ck <- TypeQ -> TypeQ -> TypeQ -> [Int] -> Q [Dec]
defineHasConstraintKeyInstance [t| Primary |] TypeQ
recType TypeQ
colType [Int]
indexes
[Dec]
pp <- TypeQ -> TypeQ -> [Int] -> Q [Dec]
Overloaded.definePrimaryHasProjection TypeQ
recType TypeQ
colType [Int]
indexes
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
kc forall a. [a] -> [a] -> [a]
++ [Dec]
ck forall a. [a] -> [a] -> [a]
++ [Dec]
pp
defineHasPrimaryKeyInstanceWithConfig :: Config
-> String
-> String
-> TypeQ
-> [Int]
-> Q [Dec]
defineHasPrimaryKeyInstanceWithConfig :: Config -> String -> String -> TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstanceWithConfig Config
config String
scm =
TypeQ -> TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstance forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig forall a b. (a -> b) -> a -> b
$ Config -> NameConfig
nameConfig Config
config) String
scm
defineHasNotNullKeyInstance :: TypeQ
-> Int
-> Q [Dec]
defineHasNotNullKeyInstance :: TypeQ -> Int -> Q [Dec]
defineHasNotNullKeyInstance =
TypeQ -> TypeQ -> Int -> Q [Dec]
defineHasColumnConstraintInstance [t| NotNull |]
defineHasNotNullKeyInstanceWithConfig :: Config
-> String
-> String
-> Int
-> Q [Dec]
defineHasNotNullKeyInstanceWithConfig :: Config -> String -> String -> Int -> Q [Dec]
defineHasNotNullKeyInstanceWithConfig Config
config String
scm =
TypeQ -> Int -> Q [Dec]
defineHasNotNullKeyInstance forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig forall a b. (a -> b) -> a -> b
$ Config -> NameConfig
nameConfig Config
config) String
scm
projectionTemplate :: ConName
-> VarName
-> Int
-> TypeQ
-> Q [Dec]
projectionTemplate :: ConName -> VarName -> Int -> TypeQ -> Q [Dec]
projectionTemplate ConName
recName VarName
var Int
ix TypeQ
colType = do
let offsetsExp :: ExpQ
offsetsExp = VarName -> ExpQ
toVarExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> VarName
columnOffsetsVarNameDefault forall a b. (a -> b) -> a -> b
$ ConName -> Name
conName ConName
recName
Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD (VarName -> Name
varName VarName
var)
[t| Pi $(toTypeCon recName) $colType |]
[| UnsafePi.definePi $ $offsetsExp ! $(integralE ix) |]
defineColumns :: ConName
-> [(VarName, TypeQ)]
-> Q [Dec]
defineColumns :: ConName -> [(VarName, TypeQ)] -> Q [Dec]
defineColumns ConName
recTypeName [(VarName, TypeQ)]
cols = do
let defC :: (VarName, TypeQ) -> Int -> Q [Dec]
defC (VarName
name, TypeQ
typ) Int
ix = ConName -> VarName -> Int -> TypeQ -> Q [Dec]
projectionTemplate ConName
recTypeName VarName
name Int
ix TypeQ
typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (VarName, TypeQ) -> Int -> Q [Dec]
defC [(VarName, TypeQ)]
cols [Int
0 :: Int ..]
defineOverloadedColumns :: ConName
-> [(String, TypeQ)]
-> Q [Dec]
defineOverloadedColumns :: ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumns ConName
recTypeName [(String, TypeQ)]
cols = do
let defC :: (String, TypeQ) -> Int -> Q [Dec]
defC (String
name, TypeQ
typ) Int
ix =
ConName -> String -> Int -> TypeQ -> Q [Dec]
Overloaded.monomorphicProjection ConName
recTypeName String
name Int
ix TypeQ
typ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (String, TypeQ) -> Int -> Q [Dec]
defC [(String, TypeQ)]
cols [Int
0 :: Int ..]
defineColumnsDefault :: ConName
-> [(String, TypeQ)]
-> Q [Dec]
defineColumnsDefault :: ConName -> [(String, TypeQ)] -> Q [Dec]
defineColumnsDefault ConName
recTypeName [(String, TypeQ)]
cols =
ConName -> [(VarName, TypeQ)] -> Q [Dec]
defineColumns ConName
recTypeName [ (String -> VarName
varCamelcaseName forall a b. (a -> b) -> a -> b
$ String
name forall a. [a] -> [a] -> [a]
++ String
"'", TypeQ
typ) | (String
name, TypeQ
typ) <- [(String, TypeQ)]
cols ]
defineOverloadedColumnsDefault :: ConName
-> [(String, TypeQ)]
-> Q [Dec]
defineOverloadedColumnsDefault :: ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumnsDefault ConName
recTypeName [(String, TypeQ)]
cols =
ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumns ConName
recTypeName [ (Name -> String
nameBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> Name
varName forall a b. (a -> b) -> a -> b
$ String -> VarName
varCamelcaseName String
name, TypeQ
typ) | (String
name, TypeQ
typ) <- [(String, TypeQ)]
cols ]
defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec]
defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec]
defineTableDerivableInstance TypeQ
recordType' String
table [String]
columns =
[d| instance TableDerivable $recordType' where
derivedTable = Table.table $(stringE table) $(listE $ map stringE columns)
|]
defineTableDerivations :: VarName
-> VarName
-> VarName
-> VarName
-> TypeQ
-> Q [Dec]
defineTableDerivations :: VarName -> VarName -> VarName -> VarName -> TypeQ -> Q [Dec]
defineTableDerivations VarName
tableVar' VarName
relVar' VarName
insVar' VarName
insQVar' TypeQ
recordType' = do
let tableVar :: Name
tableVar = VarName -> Name
varName VarName
tableVar'
[Dec]
tableDs <- Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
tableVar [t| Table $recordType' |]
[| derivedTable |]
let relVar :: Name
relVar = VarName -> Name
varName VarName
relVar'
[Dec]
relDs <- Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
relVar [t| Relation () $recordType' |]
[| derivedRelation |]
let insVar :: Name
insVar = VarName -> Name
varName VarName
insVar'
[Dec]
insDs <- Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
insVar [t| Insert $recordType' |]
[| insert id' |]
let insQVar :: Name
insQVar = VarName -> Name
varName VarName
insQVar'
[Dec]
insQDs <- Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
insQVar [t| forall p . Relation p $recordType' -> InsertQuery p |]
[| insertQuery id' |]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
tableDs, [Dec]
relDs, [Dec]
insDs, [Dec]
insQDs]
defineTableTypes :: VarName
-> VarName
-> VarName
-> VarName
-> TypeQ
-> String
-> [String]
-> Q [Dec]
defineTableTypes :: VarName
-> VarName
-> VarName
-> VarName
-> TypeQ
-> String
-> [String]
-> Q [Dec]
defineTableTypes VarName
tableVar' VarName
relVar' VarName
insVar' VarName
insQVar' TypeQ
recordType' String
table [String]
columns = do
[Dec]
iDs <- TypeQ -> String -> [String] -> Q [Dec]
defineTableDerivableInstance TypeQ
recordType' String
table [String]
columns
[Dec]
dDs <- VarName -> VarName -> VarName -> VarName -> TypeQ -> Q [Dec]
defineTableDerivations VarName
tableVar' VarName
relVar' VarName
insVar' VarName
insQVar' TypeQ
recordType'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
iDs forall a. [a] -> [a] -> [a]
++ [Dec]
dDs
tableSQL :: Bool -> SchemaNameMode -> IdentifierQuotation -> String -> String -> String
tableSQL :: Bool
-> SchemaNameMode
-> IdentifierQuotation
-> String
-> String
-> String
tableSQL Bool
normalize SchemaNameMode
snm IdentifierQuotation
iq String
schema String
table = case SchemaNameMode
snm of
SchemaNameMode
SchemaQualified -> (String -> String
qt String
normalizeS) forall a. [a] -> [a] -> [a]
++ Char
'.' forall a. a -> [a] -> [a]
: (String -> String
qt String
normalizeT)
SchemaNameMode
SchemaNotQualified -> (String -> String
qt String
normalizeT)
where
normalizeS :: String
normalizeS
| Bool
normalize = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
schema
| Bool
otherwise = String
schema
normalizeT :: String
normalizeT
| Bool
normalize = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
table
| Bool
otherwise = String
table
qt :: String -> String
qt = IdentifierQuotation -> String -> String
quote IdentifierQuotation
iq
quote :: IdentifierQuotation -> String -> String
quote :: IdentifierQuotation -> String -> String
quote IdentifierQuotation
NoQuotation String
s = String
s
quote (Quotation Char
q) String
s = Char
q forall a. a -> [a] -> [a]
: (String -> String
escape String
s) forall a. [a] -> [a] -> [a]
++ Char
q forall a. a -> [a] -> [a]
: []
where escape :: String -> String
escape = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Char
c -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
q then [Char
q, Char
q] else [Char
c]))
varNameWithPrefix :: String -> String -> VarName
varNameWithPrefix :: String -> String -> VarName
varNameWithPrefix String
n String
p = String -> VarName
varCamelcaseName forall a b. (a -> b) -> a -> b
$ String
p forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ String
n
derivationVarNameDefault :: String -> VarName
derivationVarNameDefault :: String -> VarName
derivationVarNameDefault = (String -> String -> VarName
`varNameWithPrefix` String
"derivationFrom")
derivationExpDefault :: String
-> ExpQ
derivationExpDefault :: String -> ExpQ
derivationExpDefault = VarName -> ExpQ
toVarExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> VarName
derivationVarNameDefault
tableVarNameDefault :: String -> VarName
tableVarNameDefault :: String -> VarName
tableVarNameDefault = (String -> String -> VarName
`varNameWithPrefix` String
"tableOf")
tableVarExpDefault :: String
-> ExpQ
tableVarExpDefault :: String -> ExpQ
tableVarExpDefault = VarName -> ExpQ
toVarExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> VarName
tableVarNameDefault
relationVarExp :: Config
-> String
-> String
-> ExpQ
relationVarExp :: Config -> String -> String -> ExpQ
relationVarExp Config
config String
scm = VarName -> ExpQ
toVarExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConfig -> String -> String -> VarName
relationVarName (Config -> NameConfig
nameConfig Config
config) String
scm
defineProductConstructorInstanceWithConfig :: Config -> String -> String -> [Q Type] -> Q [Dec]
defineProductConstructorInstanceWithConfig :: Config -> String -> String -> [TypeQ] -> Q [Dec]
defineProductConstructorInstanceWithConfig Config
config String
schema String
table [TypeQ]
colTypes = do
let (TypeQ
recType, ExpQ
recData) = NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig forall a b. (a -> b) -> a -> b
$ Config -> NameConfig
nameConfig Config
config) String
schema String
table
[d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recType colTypes) where
productConstructor = $(recData)
|]
defineTableTypesWithConfig :: Config
-> String
-> String
-> [(String, TypeQ)]
-> Q [Dec]
defineTableTypesWithConfig :: Config -> String -> String -> [(String, TypeQ)] -> Q [Dec]
defineTableTypesWithConfig Config
config String
schema String
table [(String, TypeQ)]
columns = do
let nmconfig :: NameConfig
nmconfig = Config -> NameConfig
nameConfig Config
config
recConfig :: NameConfig
recConfig = NameConfig -> NameConfig
recordConfig NameConfig
nmconfig
[Dec]
tableDs <- VarName
-> VarName
-> VarName
-> VarName
-> TypeQ
-> String
-> [String]
-> Q [Dec]
defineTableTypes
(String -> VarName
tableVarNameDefault String
table)
(NameConfig -> String -> String -> VarName
relationVarName NameConfig
nmconfig String
schema String
table)
(String
table String -> String -> VarName
`varNameWithPrefix` String
"insert")
(String
table String -> String -> VarName
`varNameWithPrefix` String
"insertQuery")
(forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate NameConfig
recConfig String
schema String
table)
(Bool
-> SchemaNameMode
-> IdentifierQuotation
-> String
-> String
-> String
tableSQL (Config -> Bool
normalizedTableName Config
config) (Config -> SchemaNameMode
schemaNameMode Config
config) (Config -> IdentifierQuotation
identifierQuotation Config
config) String
schema String
table)
(forall a b. (a -> b) -> [a] -> [b]
map ((IdentifierQuotation -> String -> String
quote (Config -> IdentifierQuotation
identifierQuotation Config
config)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(String, TypeQ)]
columns)
let typeName :: ConName
typeName = NameConfig -> String -> String -> ConName
recordTypeName NameConfig
recConfig String
schema String
table
[Dec]
colsDs <- if Config -> Bool
disableSpecializedProjection Config
config
then [d| |]
else ConName -> [(String, TypeQ)] -> Q [Dec]
defineColumnsDefault ConName
typeName [(String, TypeQ)]
columns
[Dec]
pcolsDs <- if Config -> Bool
disableOverloadedProjection Config
config
then [d| |]
else ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumnsDefault ConName
typeName [(String, TypeQ)]
columns
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
tableDs forall a. [a] -> [a] -> [a]
++ [Dec]
colsDs forall a. [a] -> [a] -> [a]
++ [Dec]
pcolsDs
defineTableTypesAndRecord :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
defineTableTypesAndRecord :: Config
-> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineTableTypesAndRecord Config
config String
schema String
table [(String, TypeQ)]
columns [Name]
derives = do
let recConfig :: NameConfig
recConfig = NameConfig -> NameConfig
recordConfig forall a b. (a -> b) -> a -> b
$ Config -> NameConfig
nameConfig Config
config
[Dec]
recD <- NameConfig
-> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineRecordTypeWithConfig NameConfig
recConfig String
schema String
table [(String, TypeQ)]
columns [Name]
derives
[Dec]
rconD <- Config -> String -> String -> [TypeQ] -> Q [Dec]
defineProductConstructorInstanceWithConfig Config
config String
schema String
table [TypeQ
t | (String
_, TypeQ
t) <- [(String, TypeQ)]
columns]
[Dec]
ctD <- [d| instance LiteralSQL $(fst $ recordTemplate recConfig schema table) |]
[Dec]
tableDs <- Config -> String -> String -> [(String, TypeQ)] -> Q [Dec]
defineTableTypesWithConfig Config
config String
schema String
table [(String, TypeQ)]
columns
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
recD forall a. [a] -> [a] -> [a]
++ [Dec]
rconD forall a. [a] -> [a] -> [a]
++ [Dec]
ctD forall a. [a] -> [a] -> [a]
++ [Dec]
tableDs
definePrimaryQuery :: VarName
-> TypeQ
-> TypeQ
-> ExpQ
-> Q [Dec]
definePrimaryQuery :: VarName -> TypeQ -> TypeQ -> ExpQ -> Q [Dec]
definePrimaryQuery VarName
toDef' TypeQ
paramType TypeQ
recType ExpQ
relE = do
let toDef :: Name
toDef = VarName -> Name
varName VarName
toDef'
Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
toDef
[t| Query $paramType $recType |]
[| relationalQuery (primarySelect $relE) |]
definePrimaryUpdate :: VarName
-> TypeQ
-> TypeQ
-> ExpQ
-> Q [Dec]
definePrimaryUpdate :: VarName -> TypeQ -> TypeQ -> ExpQ -> Q [Dec]
definePrimaryUpdate VarName
toDef' TypeQ
paramType TypeQ
recType ExpQ
tableE = do
let toDef :: Name
toDef = VarName -> Name
varName VarName
toDef'
Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD Name
toDef
[t| KeyUpdate $paramType $recType |]
[| primaryUpdate $tableE |]
defineSqlsWithPrimaryKey :: VarName
-> VarName
-> TypeQ
-> TypeQ
-> ExpQ
-> ExpQ
-> Q [Dec]
defineSqlsWithPrimaryKey :: VarName -> VarName -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> Q [Dec]
defineSqlsWithPrimaryKey VarName
sel VarName
upd TypeQ
paramType TypeQ
recType ExpQ
relE ExpQ
tableE = do
[Dec]
selD <- VarName -> TypeQ -> TypeQ -> ExpQ -> Q [Dec]
definePrimaryQuery VarName
sel TypeQ
paramType TypeQ
recType ExpQ
relE
[Dec]
updD <- VarName -> TypeQ -> TypeQ -> ExpQ -> Q [Dec]
definePrimaryUpdate VarName
upd TypeQ
paramType TypeQ
recType ExpQ
tableE
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
selD forall a. [a] -> [a] -> [a]
++ [Dec]
updD
defineSqlsWithPrimaryKeyDefault :: String
-> TypeQ
-> TypeQ
-> ExpQ
-> ExpQ
-> Q [Dec]
defineSqlsWithPrimaryKeyDefault :: String -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> Q [Dec]
defineSqlsWithPrimaryKeyDefault String
table =
VarName -> VarName -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> Q [Dec]
defineSqlsWithPrimaryKey VarName
sel VarName
upd
where
sel :: VarName
sel = String
table String -> String -> VarName
`varNameWithPrefix` String
"select"
upd :: VarName
upd = String
table String -> String -> VarName
`varNameWithPrefix` String
"update"
defineWithPrimaryKey :: Config
-> String
-> String
-> TypeQ
-> [Int]
-> Q [Dec]
defineWithPrimaryKey :: Config -> String -> String -> TypeQ -> [Int] -> Q [Dec]
defineWithPrimaryKey Config
config String
schema String
table TypeQ
keyType [Int]
ixs = do
[Dec]
instD <- Config -> String -> String -> TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstanceWithConfig Config
config String
schema String
table TypeQ
keyType [Int]
ixs
let recType :: TypeQ
recType = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig forall a b. (a -> b) -> a -> b
$ Config -> NameConfig
nameConfig Config
config) String
schema String
table
tableE :: ExpQ
tableE = String -> ExpQ
tableVarExpDefault String
table
relE :: ExpQ
relE = Config -> String -> String -> ExpQ
relationVarExp Config
config String
schema String
table
[Dec]
sqlsD <- String -> TypeQ -> TypeQ -> ExpQ -> ExpQ -> Q [Dec]
defineSqlsWithPrimaryKeyDefault String
table TypeQ
keyType TypeQ
recType ExpQ
relE ExpQ
tableE
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
instD forall a. [a] -> [a] -> [a]
++ [Dec]
sqlsD
defineWithNotNullKeyWithConfig :: Config -> String -> String -> Int -> Q [Dec]
defineWithNotNullKeyWithConfig :: Config -> String -> String -> Int -> Q [Dec]
defineWithNotNullKeyWithConfig = Config -> String -> String -> Int -> Q [Dec]
defineHasNotNullKeyInstanceWithConfig
defineTable :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> [Int]
-> Maybe Int
-> Q [Dec]
defineTable :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> [Int]
-> Maybe Int
-> Q [Dec]
defineTable Config
config String
schema String
table [(String, TypeQ)]
columns [Name]
derives [Int]
primaryIxs Maybe Int
mayNotNullIdx = do
[Dec]
tblD <- Config
-> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineTableTypesAndRecord Config
config String
schema String
table [(String, TypeQ)]
columns [Name]
derives
let pairT :: m Type -> m Type -> m Type
pairT m Type
x m Type
y = forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
2) m Type
x) m Type
y
keyType :: TypeQ
keyType = forall a. (a -> a -> a) -> [a] -> a
foldl1' forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
pairT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(String, TypeQ)]
columns forall a. [a] -> Int -> a
!!)) forall a b. (a -> b) -> a -> b
$ [Int]
primaryIxs
[Dec]
primD <- case [Int]
primaryIxs of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return []
[Int]
ixs -> Config -> String -> String -> TypeQ -> [Int] -> Q [Dec]
defineWithPrimaryKey Config
config String
schema String
table TypeQ
keyType [Int]
ixs
[Dec]
nnD <- forall a. (a -> Q [Dec]) -> Maybe a -> Q [Dec]
maybeD (\Int
i -> Config -> String -> String -> Int -> Q [Dec]
defineWithNotNullKeyWithConfig Config
config String
schema String
table Int
i) Maybe Int
mayNotNullIdx
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
tblD forall a. [a] -> [a] -> [a]
++ [Dec]
primD forall a. [a] -> [a] -> [a]
++ [Dec]
nnD
unsafeInlineQuery :: TypeQ
-> TypeQ
-> String
-> VarName
-> Q [Dec]
unsafeInlineQuery :: TypeQ -> TypeQ -> String -> VarName -> Q [Dec]
unsafeInlineQuery TypeQ
p TypeQ
r String
sql VarName
qVar' =
Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD (VarName -> Name
varName VarName
qVar')
[t| Query $p $r |]
[| unsafeTypedQuery $(stringE sql) |]
reifyRelation :: Name
-> Q (Type, Type)
reifyRelation :: Name -> Q (Type, Type)
reifyRelation Name
relVar = do
Info
relInfo <- Name -> Q Info
reify Name
relVar
case Info -> Maybe (Name, Type, Maybe Dec)
unVarI Info
relInfo of
Just (Name
_, (AppT (AppT (ConT Name
prn) Type
p) Type
r), Maybe Dec
_)
| Name
prn forall a. Eq a => a -> a -> Bool
== ''Relation -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type
p, Type
r)
Maybe (Name, Type, Maybe Dec)
_ ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"expandRelation: Variable must have Relation type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
relVar
inlineQuery :: Name
-> Relation p r
-> Config
-> QuerySuffix
-> String
-> Q [Dec]
inlineQuery :: forall p r.
Name -> Relation p r -> Config -> QuerySuffix -> String -> Q [Dec]
inlineQuery Name
relVar Relation p r
rel Config
config QuerySuffix
sufs String
qns = do
(Type
p, Type
r) <- Name -> Q (Type, Type)
reifyRelation Name
relVar
TypeQ -> TypeQ -> String -> VarName -> Q [Dec]
unsafeInlineQuery (forall (m :: * -> *) a. Monad m => a -> m a
return Type
p) (forall (m :: * -> *) a. Monad m => a -> m a
return Type
r)
(forall p a. Query p a -> String
untypeQuery forall a b. (a -> b) -> a -> b
$ forall p r. Config -> Relation p r -> QuerySuffix -> Query p r
relationalQuery_ Config
config Relation p r
rel QuerySuffix
sufs)
(String -> VarName
varCamelcaseName String
qns)
makeRelationalRecordDefault' :: Config
-> Name
-> Q [Dec]
makeRelationalRecordDefault' :: Config -> Name -> Q [Dec]
makeRelationalRecordDefault' Config
config Name
recTypeName = do
let recTypeConName :: ConName
recTypeConName = Name -> ConName
ConName Name
recTypeName
(((TypeQ
tyCon, [Name]
vars), ExpQ
_dataCon), (Maybe [Name]
mayNs, [TypeQ]
cts)) <- Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType Name
recTypeName
[Dec]
pw <- TypeQ -> [Name] -> Q [Dec]
Record.definePersistableWidthInstance TypeQ
tyCon [Name]
vars
[Dec]
cols <- case Maybe [Name]
mayNs of
Maybe [Name]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just [Name]
ns -> case [Name]
vars of
[] -> do
[Dec]
off <- ConName -> Q [Dec]
Record.defineColumnOffsets ConName
recTypeConName
let cnames :: [(String, TypeQ)]
cnames = [ (Name -> String
nameBase Name
n, TypeQ
ct) | Name
n <- [Name]
ns | TypeQ
ct <- [TypeQ]
cts ]
[Dec]
cs <- if Config -> Bool
disableSpecializedProjection Config
config
then [d| |]
else ConName -> [(String, TypeQ)] -> Q [Dec]
defineColumnsDefault ConName
recTypeConName [(String, TypeQ)]
cnames
[Dec]
pcs <- if Config -> Bool
disableOverloadedProjection Config
config
then [d| |]
else ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumnsDefault ConName
recTypeConName [(String, TypeQ)]
cnames
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
off forall a. [a] -> [a] -> [a]
++ [Dec]
cs forall a. [a] -> [a] -> [a]
++ [Dec]
pcs
Name
_:[Name]
_ -> do
[Dec]
cols <- if Config -> Bool
disableSpecializedProjection Config
config
then [d| |]
else TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]
defineRecordProjections TypeQ
tyCon [Name]
vars
[VarName -> Name
varName forall a b. (a -> b) -> a -> b
$ String -> VarName
varCamelcaseName (Name -> String
nameBase Name
n forall a. [a] -> [a] -> [a]
++ String
"'") | Name
n <- [Name]
ns]
[TypeQ]
cts
[Dec]
ovls <- if Config -> Bool
disableOverloadedProjection Config
config
then [d| |]
else TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec]
Overloaded.polymorphicProjections TypeQ
tyCon [Name]
vars
[Name -> String
nameBase Name
n | Name
n <- [Name]
ns]
[TypeQ]
cts
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
cols forall a. [a] -> [a] -> [a]
++ [Dec]
ovls
[Dec]
pc <- Name -> Q [Dec]
defineProductConstructor Name
recTypeName
let scPred :: Name -> TypeQ
scPred Name
v = Name -> [TypeQ] -> TypeQ
classP ''LiteralSQL [forall (m :: * -> *). Quote m => Name -> m Type
varT Name
v]
Dec
ct <- forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> TypeQ
scPred [Name]
vars) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t| LiteralSQL |] TypeQ
tyCon) []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]
pw, [Dec]
cols, [Dec]
pc, [Dec
ct]]
makeRelationalRecordDefault :: Name
-> Q [Dec]
makeRelationalRecordDefault :: Name -> Q [Dec]
makeRelationalRecordDefault = Config -> Name -> Q [Dec]
makeRelationalRecordDefault' Config
defaultConfig