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