{-# 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
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
kc [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
ck [Dec] -> [Dec] -> [Dec]
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 (TypeQ -> TypeQ -> [Int] -> Q [Dec])
-> (String -> TypeQ) -> String -> TypeQ -> [Int] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeQ, ExpQ) -> TypeQ
forall a b. (a, b) -> a
fst ((TypeQ, ExpQ) -> TypeQ)
-> (String -> (TypeQ, ExpQ)) -> String -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig (NameConfig -> NameConfig) -> NameConfig -> NameConfig
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 (TypeQ -> Int -> Q [Dec])
-> (String -> TypeQ) -> String -> Int -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeQ, ExpQ) -> TypeQ
forall a b. (a, b) -> a
fst ((TypeQ, ExpQ) -> TypeQ)
-> (String -> (TypeQ, ExpQ)) -> String -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig (NameConfig -> NameConfig) -> NameConfig -> NameConfig
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 (VarName -> ExpQ) -> (Name -> VarName) -> Name -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> VarName
columnOffsetsVarNameDefault (Name -> ExpQ) -> Name -> ExpQ
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
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ ((VarName, TypeQ) -> Int -> Q [Dec])
-> [(VarName, TypeQ)] -> [Int] -> [Q [Dec]]
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
([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> ([Q [Dec]] -> Q [[Dec]]) -> [Q [Dec]] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ ((String, TypeQ) -> Int -> Q [Dec])
-> [(String, TypeQ)] -> [Int] -> [Q [Dec]]
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 (String -> VarName) -> String -> VarName
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
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 (Name -> String) -> (VarName -> Name) -> VarName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> Name
varName (VarName -> String) -> VarName -> String
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' |]
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
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'
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
iDs [Dec] -> [Dec] -> [Dec]
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) String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: (String -> String
qt String
normalizeT)
SchemaNameMode
SchemaNotQualified -> (String -> String
qt String
normalizeT)
where
normalizeS :: String
normalizeS
| Bool
normalize = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
schema
| Bool
otherwise = String
schema
normalizeT :: String
normalizeT
| Bool
normalize = (Char -> Char) -> String -> String
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 Char -> String -> String
forall a. a -> [a] -> [a]
: (String -> String
escape String
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
q Char -> String -> String
forall a. a -> [a] -> [a]
: []
where escape :: String -> String
escape = (String -> (Char -> String) -> String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Char
c -> if Char
c Char -> Char -> Bool
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 (String -> VarName) -> String -> VarName
forall a b. (a -> b) -> a -> b
$ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> 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 (VarName -> ExpQ) -> (String -> VarName) -> String -> ExpQ
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 (VarName -> ExpQ) -> (String -> VarName) -> String -> ExpQ
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 (VarName -> ExpQ) -> (String -> VarName) -> String -> ExpQ
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 (NameConfig -> NameConfig) -> NameConfig -> NameConfig
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")
((TypeQ, ExpQ) -> TypeQ
forall a b. (a, b) -> a
fst ((TypeQ, ExpQ) -> TypeQ) -> (TypeQ, ExpQ) -> TypeQ
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)
(((String, TypeQ) -> String) -> [(String, TypeQ)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((IdentifierQuotation -> String -> String
quote (Config -> IdentifierQuotation
identifierQuotation Config
config)) (String -> String)
-> ((String, TypeQ) -> String) -> (String, TypeQ) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, TypeQ) -> String
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
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
tableDs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
colsDs [Dec] -> [Dec] -> [Dec]
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 (NameConfig -> NameConfig) -> NameConfig -> NameConfig
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
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
recD [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
rconD [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
ctD [Dec] -> [Dec] -> [Dec]
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
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
selD [Dec] -> [Dec] -> [Dec]
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 = (TypeQ, ExpQ) -> TypeQ
forall a b. (a, b) -> a
fst ((TypeQ, ExpQ) -> TypeQ) -> (TypeQ, ExpQ) -> TypeQ
forall a b. (a -> b) -> a -> b
$ NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate (NameConfig -> NameConfig
recordConfig (NameConfig -> NameConfig) -> NameConfig -> NameConfig
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
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
instD [Dec] -> [Dec] -> [Dec]
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 :: TypeQ -> TypeQ -> TypeQ
pairT TypeQ
x TypeQ
y = TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT Int
2) TypeQ
x) TypeQ
y
keyType :: TypeQ
keyType = (TypeQ -> TypeQ -> TypeQ) -> [TypeQ] -> TypeQ
forall a. (a -> a -> a) -> [a] -> a
foldl1' TypeQ -> TypeQ -> TypeQ
pairT ([TypeQ] -> TypeQ) -> ([Int] -> [TypeQ]) -> [Int] -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> TypeQ) -> [Int] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map ((String, TypeQ) -> TypeQ
forall a b. (a, b) -> b
snd ((String, TypeQ) -> TypeQ)
-> (Int -> (String, TypeQ)) -> Int -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(String, TypeQ)]
columns [(String, TypeQ)] -> Int -> (String, TypeQ)
forall a. [a] -> Int -> a
!!)) ([Int] -> TypeQ) -> [Int] -> TypeQ
forall a b. (a -> b) -> a -> b
$ [Int]
primaryIxs
[Dec]
primD <- case [Int]
primaryIxs of
[] -> [Dec] -> Q [Dec]
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 <- (Int -> Q [Dec]) -> Maybe Int -> Q [Dec]
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
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
tblD [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
primD [Dec] -> [Dec] -> [Dec]
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Relation -> (Type, Type) -> Q (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
p, Type
r)
Maybe (Name, Type, Maybe Dec)
_ ->
String -> Q (Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Type, Type)) -> String -> Q (Type, Type)
forall a b. (a -> b) -> a -> b
$ String
"expandRelation: Variable must have Relation type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
relVar
inlineQuery :: Name
-> Relation p r
-> Config
-> QuerySuffix
-> String
-> Q [Dec]
inlineQuery :: 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 (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
p) (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
r)
(Query p r -> String
forall p a. Query p a -> String
untypeQuery (Query p r -> String) -> Query p r -> String
forall a b. (a -> b) -> a -> b
$ Config -> Relation p r -> QuerySuffix -> Query p r
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 -> [Dec] -> Q [Dec]
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
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
off [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
cs [Dec] -> [Dec] -> [Dec]
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 (VarName -> Name) -> VarName -> Name
forall a b. (a -> b) -> a -> b
$ String -> VarName
varCamelcaseName (Name -> String
nameBase Name
n String -> String -> String
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
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
cols [Dec] -> [Dec] -> [Dec]
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 [Name -> TypeQ
varT Name
v]
Dec
ct <- CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ((Name -> TypeQ) -> [Name] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> TypeQ
scPred [Name]
vars) (TypeQ -> TypeQ -> TypeQ
appT [t| LiteralSQL |] TypeQ
tyCon) []
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
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