module Database.Relational.Query.TH (
defineTableDefault,
unsafeInlineQuery,
inlineQuery,
defineTableTypesAndRecordDefault,
defineHasPrimaryKeyInstance,
defineHasPrimaryKeyInstanceDefault,
defineHasNotNullKeyInstance,
defineHasNotNullKeyInstanceDefault,
defineScalarDegree,
defineColumns, defineColumnsDefault,
defineTableTypes, defineTableTypesDefault,
definePrimaryQuery,
definePrimaryUpdate,
derivationExpDefault,
tableVarExpDefault,
relationVarExpDefault,
defineSqlsWithPrimaryKey,
defineSqlsWithPrimaryKeyDefault,
defineProductConstructorInstance,
makeRelationalRecordDefault,
reifyRelation,
) where
import Data.Char (toUpper, toLower)
import Data.List (foldl1')
import Data.Array.IArray ((!))
import Language.Haskell.TH
(Name, nameBase, Q, reify, Info (VarI), TypeQ, Type (AppT, ConT), ExpQ,
tupleT, appT, arrowT, Dec, stringE, listE)
import Language.Haskell.TH.Name.CamelCase
(VarName, varName, ConName (ConName), conName, varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon, toDataCon)
import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE)
import Database.Record.TH
(recordTypeNameDefault, recordTypeDefault, columnOffsetsVarNameDefault,
defineRecordTypeDefault,
defineHasColumnConstraintInstance)
import qualified Database.Record.TH as Record
import Database.Relational.Query
(Table, Pi, id', Relation, Config (normalizedTableName), ProductConstructor (..),
relationalQuerySQL, Query, relationalQuery, KeyUpdate,
Insert, derivedInsert, InsertQuery, derivedInsertQuery,
HasConstraintKey(constraintKey), Primary, NotNull, primary, primaryUpdate)
import Database.Relational.Query.Scalar (defineScalarDegree)
import Database.Relational.Query.Constraint (Key, unsafeDefineConstraintKey)
import Database.Relational.Query.Table (TableDerivable (..))
import qualified Database.Relational.Query.Table as Table
import Database.Relational.Query.Relation (derivedRelation)
import Database.Relational.Query.SQL (QuerySuffix)
import Database.Relational.Query.Type (unsafeTypedQuery)
import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi
defineHasConstraintKeyInstance :: TypeQ
-> TypeQ
-> TypeQ
-> [Int]
-> Q [Dec]
defineHasConstraintKeyInstance constraint recType colType indexes = do
ck <- [d| instance HasConstraintKey $constraint $recType $colType where
constraintKey = unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes])
|]
return ck
defineHasPrimaryKeyInstance :: TypeQ
-> TypeQ
-> [Int]
-> Q [Dec]
defineHasPrimaryKeyInstance recType colType indexes = do
kc <- Record.defineHasPrimaryKeyInstance recType indexes
ck <- defineHasConstraintKeyInstance [t| Primary |] recType colType indexes
return $ kc ++ ck
defineHasPrimaryKeyInstanceDefault :: String
-> TypeQ
-> [Int]
-> Q [Dec]
defineHasPrimaryKeyInstanceDefault =
defineHasPrimaryKeyInstance . recordTypeDefault
defineHasNotNullKeyInstance :: TypeQ
-> Int
-> Q [Dec]
defineHasNotNullKeyInstance =
defineHasColumnConstraintInstance [t| NotNull |]
defineHasNotNullKeyInstanceDefault :: String
-> Int
-> Q [Dec]
defineHasNotNullKeyInstanceDefault =
defineHasNotNullKeyInstance . recordTypeDefault
columnTemplate' :: TypeQ
-> VarName
-> ExpQ
-> TypeQ
-> Q [Dec]
columnTemplate' recType var' iExp colType = do
let var = varName var'
simpleValD var [t| Pi $recType $colType |]
[| UnsafePi.definePi $(iExp) |]
columnTemplate :: Maybe (TypeQ, VarName)
-> TypeQ
-> VarName
-> ExpQ
-> TypeQ
-> Q [Dec]
columnTemplate mayConstraint recType var' iExp colType = do
col <- columnTemplate' recType var' iExp colType
cr <- maybe
(return [])
( \(constraint, cname') -> do
simpleValD (varName cname') [t| Key $constraint $recType $colType |]
[| unsafeDefineConstraintKey $(iExp) |] )
mayConstraint
return $ col ++ cr
defineColumns :: ConName
-> [((VarName, TypeQ), Maybe (TypeQ, VarName))]
-> Q [Dec]
defineColumns recTypeName cols = do
let defC ((cn, ct), mayCon) ix = columnTemplate mayCon (toTypeCon recTypeName) cn
[| $(toVarExp . columnOffsetsVarNameDefault $ conName recTypeName) ! $(integralE ix) |] ct
fmap concat . sequence $ zipWith defC cols [0 :: Int ..]
defineColumnsDefault :: ConName
-> [((String, TypeQ), Maybe TypeQ)]
-> Q [Dec]
defineColumnsDefault recTypeName cols =
defineColumns recTypeName [((varN n, ct), fmap (withCName n) mayC) | ((n, ct), mayC) <- cols]
where varN name = varCamelcaseName (name ++ "'")
withCName name t = (t, varCamelcaseName ("constraint_key_" ++ name))
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 |]
[| derivedInsert id' |]
let insQVar = varName insQVar'
insQDs <- simpleValD insQVar [t| forall p . Relation p $recordType -> InsertQuery p |]
[| derivedInsertQuery 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 -> String -> String -> String
tableSQL normalize schema table = normalizeS schema ++ '.' : normalizeT table where
normalizeS
| normalize = map toUpper
| otherwise = id
normalizeT
| normalize = map toLower
| otherwise = id
derivationVarNameDefault :: String -> VarName
derivationVarNameDefault = (`varNameWithPrefix` "derivationFrom")
derivationExpDefault :: String
-> ExpQ
derivationExpDefault = toVarExp . derivationVarNameDefault
tableVarNameDefault :: String -> VarName
tableVarNameDefault = (`varNameWithPrefix` "tableOf")
tableVarExpDefault :: String
-> ExpQ
tableVarExpDefault = toVarExp . tableVarNameDefault
relationVarNameDefault :: String -> VarName
relationVarNameDefault = varCamelcaseName
relationVarExpDefault :: String
-> ExpQ
relationVarExpDefault = toVarExp . relationVarNameDefault
defineProductConstructorInstance :: TypeQ -> ExpQ -> [TypeQ] -> Q [Dec]
defineProductConstructorInstance recTypeQ recData colTypes =
[d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where
productConstructor = $(recData)
|]
defineProductConstructorInstanceDefault :: String -> [TypeQ] -> Q [Dec]
defineProductConstructorInstanceDefault table colTypes = do
let typeName = recordTypeNameDefault table
defineProductConstructorInstance
(toTypeCon typeName)
(toDataCon typeName)
colTypes
defineTableTypesDefault :: Config
-> String
-> String
-> [((String, TypeQ), Maybe TypeQ)]
-> Q [Dec]
defineTableTypesDefault config schema table columns = do
tableDs <- defineTableTypes
(tableVarNameDefault table)
(relationVarNameDefault table)
(table `varNameWithPrefix` "insert")
(table `varNameWithPrefix` "insertQuery")
(recordTypeDefault table)
(tableSQL (normalizedTableName config) schema table)
(map (fst . fst) columns)
colsDs <- defineColumnsDefault (recordTypeNameDefault table) columns
return $ tableDs ++ colsDs
defineTableTypesAndRecordDefault :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [ConName]
-> Q [Dec]
defineTableTypesAndRecordDefault config schema table columns drives = do
recD <- defineRecordTypeDefault table columns drives
rconD <- defineProductConstructorInstanceDefault table [t | (_, t) <- columns]
tableDs <- defineTableTypesDefault config schema table [(c, Nothing) | c <- columns ]
return $ recD ++ rconD ++ 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 (primary $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"
defineWithPrimaryKeyDefault :: String
-> TypeQ
-> [Int]
-> Q [Dec]
defineWithPrimaryKeyDefault table keyType ixs = do
instD <- defineHasPrimaryKeyInstanceDefault table keyType ixs
let recType = recordTypeDefault table
tableE = tableVarExpDefault table
relE = relationVarExpDefault table
sqlsD <- defineSqlsWithPrimaryKeyDefault table keyType recType relE tableE
return $ instD ++ sqlsD
defineWithNotNullKeyDefault :: String -> Int -> Q [Dec]
defineWithNotNullKeyDefault = defineHasNotNullKeyInstanceDefault
defineTableDefault :: Config
-> String
-> String
-> [(String, TypeQ)]
-> [ConName]
-> [Int]
-> Maybe Int
-> Q [Dec]
defineTableDefault config schema table columns derives primaryIxs mayNotNullIdx = do
tblD <- defineTableTypesAndRecordDefault 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 -> defineWithPrimaryKeyDefault table keyType ixs
nnD <- maybeD (\i -> defineWithNotNullKeyDefault 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 relInfo of
VarI _ (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)
(relationalQuerySQL config rel sufs)
(varCamelcaseName qns)
makeRelationalRecordDefault :: Name
-> Q [Dec]
makeRelationalRecordDefault recTypeName = do
let recTypeConName = ConName recTypeName
((tyCon, dataCon), (mayNs, cts)) <- Record.reifyRecordType recTypeName
pw <- Record.defineColumnOffsets recTypeConName cts
cs <- maybe
(return [])
(\ns -> defineColumnsDefault recTypeConName
[ ((nameBase n, ct), Nothing) | n <- ns | ct <- cts ])
mayNs
pc <- defineProductConstructorInstance tyCon dataCon cts
return $ concat [pw, cs, pc]