{-# 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 constraint :: TypeQ
constraint recType :: TypeQ
recType colType :: TypeQ
colType indexes :: [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 recType :: TypeQ
recType colType :: TypeQ
colType indexes :: [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
config scm :: 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
config scm :: 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 recName :: ConName
recName var :: VarName
var ix :: Int
ix colType :: 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 recTypeName :: ConName
recTypeName cols :: [(VarName, TypeQ)]
cols = do
let defC :: (VarName, TypeQ) -> Int -> Q [Dec]
defC (name :: VarName
name, typ :: TypeQ
typ) ix :: 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 [0 :: Int ..]
defineOverloadedColumns :: ConName
-> [(String, TypeQ)]
-> Q [Dec]
defineOverloadedColumns :: ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumns recTypeName :: ConName
recTypeName cols :: [(String, TypeQ)]
cols = do
let defC :: (String, TypeQ) -> Int -> Q [Dec]
defC (name :: String
name, typ :: TypeQ
typ) ix :: 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 [0 :: Int ..]
defineColumnsDefault :: ConName
-> [(String, TypeQ)]
-> Q [Dec]
defineColumnsDefault :: ConName -> [(String, TypeQ)] -> Q [Dec]
defineColumnsDefault recTypeName :: ConName
recTypeName cols :: [(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]
++ "'", TypeQ
typ) | (name :: String
name, typ :: TypeQ
typ) <- [(String, TypeQ)]
cols ]
defineOverloadedColumnsDefault :: ConName
-> [(String, TypeQ)]
-> Q [Dec]
defineOverloadedColumnsDefault :: ConName -> [(String, TypeQ)] -> Q [Dec]
defineOverloadedColumnsDefault recTypeName :: ConName
recTypeName cols :: [(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) | (name :: String
name, typ :: TypeQ
typ) <- [(String, TypeQ)]
cols ]
defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec]
defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec]
defineTableDerivableInstance recordType' :: TypeQ
recordType' table :: String
table columns :: [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 tableVar' :: VarName
tableVar' relVar' :: VarName
relVar' insVar' :: VarName
insVar' insQVar' :: VarName
insQVar' recordType' :: 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 tableVar' :: VarName
tableVar' relVar' :: VarName
relVar' insVar' :: VarName
insVar' insQVar' :: VarName
insQVar' recordType' :: TypeQ
recordType' table :: String
table columns :: [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 normalize :: Bool
normalize snm :: SchemaNameMode
snm iq :: IdentifierQuotation
iq schema :: String
schema table :: String
table = case SchemaNameMode
snm of
SchemaQualified -> (String -> String
qt String
normalizeS) String -> String -> String
forall a. [a] -> [a] -> [a]
++ '.' Char -> String -> String
forall a. a -> [a] -> [a]
: (String -> String
qt String
normalizeT)
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 NoQuotation s :: String
s = String
s
quote (Quotation q :: Char
q) s :: 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
>>= (\c :: 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 n :: String
n p :: 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
forall a. [a] -> [a] -> [a]
++ String
n
derivationVarNameDefault :: String -> VarName
derivationVarNameDefault :: String -> VarName
derivationVarNameDefault = (String -> String -> VarName
`varNameWithPrefix` "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` "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
config scm :: 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
config schema :: String
schema table :: String
table colTypes :: [TypeQ]
colTypes = do
let (recType :: TypeQ
recType, recData :: 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
config schema :: String
schema table :: String
table columns :: [(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` "insert")
(String
table String -> String -> VarName
`varNameWithPrefix` "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
config schema :: String
schema table :: String
table columns :: [(String, TypeQ)]
columns derives :: [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 | (_, t :: 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 toDef' :: VarName
toDef' paramType :: TypeQ
paramType recType :: TypeQ
recType relE :: 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 toDef' :: VarName
toDef' paramType :: TypeQ
paramType recType :: TypeQ
recType tableE :: 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 sel :: VarName
sel upd :: VarName
upd paramType :: TypeQ
paramType recType :: TypeQ
recType relE :: ExpQ
relE tableE :: 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 table :: 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` "select"
upd :: VarName
upd = String
table String -> String -> VarName
`varNameWithPrefix` "update"
defineWithPrimaryKey :: Config
-> String
-> String
-> TypeQ
-> [Int]
-> Q [Dec]
defineWithPrimaryKey :: Config -> String -> String -> TypeQ -> [Int] -> Q [Dec]
defineWithPrimaryKey config :: Config
config schema :: String
schema table :: String
table keyType :: TypeQ
keyType ixs :: [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
config schema :: String
schema table :: String
table columns :: [(String, TypeQ)]
columns derives :: [Name]
derives primaryIxs :: [Int]
primaryIxs mayNotNullIdx :: 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 x :: TypeQ
x y :: TypeQ
y = TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
tupleT 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 []
ixs :: [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 (\i :: 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 p :: TypeQ
p r :: TypeQ
r sql :: String
sql qVar' :: 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 relVar :: Name
relVar = do
Info
relInfo <- Name -> Q Info
reify Name
relVar
case Info -> Maybe (Name, Type, Maybe Dec)
unVarI Info
relInfo of
Just (_, (AppT (AppT (ConT prn :: Name
prn) p :: Type
p) r :: Type
r), _)
| 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)
_ ->
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
$ "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 relVar :: Name
relVar rel :: Relation p r
rel config :: Config
config sufs :: QuerySuffix
sufs qns :: String
qns = do
(p :: Type
p, r :: 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
config recTypeName :: Name
recTypeName = do
let recTypeConName :: ConName
recTypeConName = Name -> ConName
ConName Name
recTypeName
(((tyCon :: TypeQ
tyCon, vars :: [Name]
vars), _dataCon :: ExpQ
_dataCon), (mayNs :: Maybe [Name]
mayNs, cts :: [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
Nothing -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just ns :: [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
_:_ -> 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]
++ "'") | 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 v :: 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