{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.Record.TH (
defineHasColumnConstraintInstance,
defineHasPrimaryConstraintInstanceDerived,
defineHasPrimaryKeyInstance,
defineHasNotNullKeyInstance,
defineRecordType,
defineRecordTypeWithConfig,
defineColumnOffsets,
recordWidthTemplate,
definePersistableWidthInstance,
defineSqlPersistableInstances,
NameConfig, defaultNameConfig,
recordTypeName, columnName,
recordTemplate,
columnOffsetsVarNameDefault,
deriveNotNullType,
defineTupleInstances,
) where
import GHC.Generics (Generic)
import Data.Array (Array)
import Language.Haskell.TH.Name.CamelCase
(ConName(conName), VarName(varName),
conCamelcaseName, varCamelcaseName,
toTypeCon, toDataCon, )
import Language.Haskell.TH.Lib.Extra (integralE, simpleValD, reportWarning)
import Language.Haskell.TH.Compat.Data (dataD')
import Language.Haskell.TH
(Q, nameBase, Name, Dec, TypeQ, conT, ExpQ, listE, sigE,
recC, cxt, varStrictType, strictType, isStrict)
import Control.Arrow ((&&&))
import Database.Record
(HasColumnConstraint(columnConstraint), Primary, NotNull,
HasKeyConstraint(keyConstraint), derivedCompositePrimary,
PersistableRecordWidth, PersistableWidth(persistableWidth), )
import Database.Record.KeyConstraint
(unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint)
import Database.Record.Persistable
(runPersistableRecordWidth,
ProductConst, getProductConst, genericFieldOffsets)
import qualified Database.Record.Persistable as Persistable
import Database.Record.InternalTH
(definePersistableWidthInstance, defineSqlPersistableInstances, defineTupleInstances)
data NameConfig =
NameConfig
{ NameConfig -> String -> String -> ConName
recordTypeName :: String -> String -> ConName
, NameConfig -> String -> String -> VarName
columnName :: String -> String -> VarName
}
instance Show NameConfig where
show :: NameConfig -> String
show = String -> NameConfig -> String
forall a b. a -> b -> a
const "<nameConfig>"
defaultNameConfig :: NameConfig
defaultNameConfig :: NameConfig
defaultNameConfig =
NameConfig :: (String -> String -> ConName)
-> (String -> String -> VarName) -> NameConfig
NameConfig
{ recordTypeName :: String -> String -> ConName
recordTypeName = (String -> ConName) -> String -> String -> ConName
forall a b. a -> b -> a
const String -> ConName
conCamelcaseName
, columnName :: String -> String -> VarName
columnName = (String -> VarName) -> String -> String -> VarName
forall a b. a -> b -> a
const String -> VarName
varCamelcaseName
}
recordTemplate :: NameConfig
-> String
-> String
-> (TypeQ, ExpQ)
recordTemplate :: NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate config :: NameConfig
config scm :: String
scm = (ConName -> TypeQ
toTypeCon (ConName -> TypeQ) -> (ConName -> ExpQ) -> ConName -> (TypeQ, ExpQ)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ConName -> ExpQ
toDataCon) (ConName -> (TypeQ, ExpQ))
-> (String -> ConName) -> String -> (TypeQ, ExpQ)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConfig -> String -> String -> ConName
recordTypeName NameConfig
config String
scm
columnOffsetsVarNameDefault :: Name
-> VarName
columnOffsetsVarNameDefault :: Name -> VarName
columnOffsetsVarNameDefault = String -> VarName
varCamelcaseName (String -> VarName) -> (Name -> String) -> Name -> VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("column_offsets_" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
defineHasColumnConstraintInstance :: TypeQ
-> TypeQ
-> Int
-> Q [Dec]
defineHasColumnConstraintInstance :: TypeQ -> TypeQ -> Int -> Q [Dec]
defineHasColumnConstraintInstance constraint :: TypeQ
constraint typeCon :: TypeQ
typeCon index :: Int
index =
[d| instance HasColumnConstraint $constraint $typeCon where
columnConstraint = unsafeSpecifyColumnConstraint $(integralE index) |]
defineHasPrimaryConstraintInstanceDerived ::TypeQ
-> Q [Dec]
defineHasPrimaryConstraintInstanceDerived :: TypeQ -> Q [Dec]
defineHasPrimaryConstraintInstanceDerived typeCon :: TypeQ
typeCon =
[d| instance HasKeyConstraint Primary $typeCon where
keyConstraint = derivedCompositePrimary |]
defineHasPrimaryKeyInstance :: TypeQ
-> [Int]
-> Q [Dec]
defineHasPrimaryKeyInstance :: TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstance typeCon :: TypeQ
typeCon = [Int] -> Q [Dec]
d where
d :: [Int] -> Q [Dec]
d [] = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
d [ix :: Int
ix] = do
[Dec]
col <- TypeQ -> TypeQ -> Int -> Q [Dec]
defineHasColumnConstraintInstance [t| Primary |] TypeQ
typeCon Int
ix
[Dec]
comp <- TypeQ -> Q [Dec]
defineHasPrimaryConstraintInstanceDerived TypeQ
typeCon
[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]
col [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
comp
d ixs :: [Int]
ixs =
[d| instance HasKeyConstraint Primary $typeCon where
keyConstraint = unsafeSpecifyKeyConstraint
$(listE [integralE ix | ix <- ixs ])
|]
defineHasNotNullKeyInstance :: TypeQ
-> Int
-> Q [Dec]
defineHasNotNullKeyInstance :: TypeQ -> Int -> Q [Dec]
defineHasNotNullKeyInstance =
TypeQ -> TypeQ -> Int -> Q [Dec]
defineHasColumnConstraintInstance [t| NotNull |]
recordWidthTemplate :: TypeQ
-> ExpQ
recordWidthTemplate :: TypeQ -> ExpQ
recordWidthTemplate ty :: TypeQ
ty =
[| runPersistableRecordWidth
$(sigE [| persistableWidth |] [t| PersistableRecordWidth $(ty) |])
|]
defineColumnOffsets :: ConName
-> Q [Dec]
defineColumnOffsets :: ConName -> Q [Dec]
defineColumnOffsets typeName' :: ConName
typeName' = do
let ofsVar :: VarName
ofsVar = Name -> VarName
columnOffsetsVarNameDefault (Name -> VarName) -> Name -> VarName
forall a b. (a -> b) -> a -> b
$ ConName -> Name
conName ConName
typeName'
Name -> TypeQ -> ExpQ -> Q [Dec]
simpleValD (VarName -> Name
varName VarName
ofsVar) [t| Array Int Int |]
[| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |]
defineRecordType :: ConName
-> [(VarName, TypeQ)]
-> [Name]
-> Q [Dec]
defineRecordType :: ConName -> [(VarName, TypeQ)] -> [Name] -> Q [Dec]
defineRecordType typeName' :: ConName
typeName' columns :: [(VarName, TypeQ)]
columns derives :: [Name]
derives = do
let typeName :: Name
typeName = ConName -> Name
conName ConName
typeName'
fld :: (VarName, TypeQ) -> VarStrictTypeQ
fld (n :: VarName
n, tq :: TypeQ
tq) = Name -> StrictTypeQ -> VarStrictTypeQ
varStrictType (VarName -> Name
varName VarName
n) (Q Strict -> TypeQ -> StrictTypeQ
strictType Q Strict
isStrict TypeQ
tq)
[Name]
derives1 <- if (''Generic Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
derives)
then do String -> Q ()
reportWarning "HRR needs Generic instance, please add ''Generic manually."
[Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> [Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ ''Generic Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
derives
else [Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name]
derives
Dec
rec' <- CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ
dataD' ([TypeQ] -> CxtQ
cxt []) Name
typeName [] [Name -> [VarStrictTypeQ] -> ConQ
recC Name
typeName (((VarName, TypeQ) -> VarStrictTypeQ)
-> [(VarName, TypeQ)] -> [VarStrictTypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (VarName, TypeQ) -> VarStrictTypeQ
fld [(VarName, TypeQ)]
columns)] [Name]
derives1
[Dec]
offs <- ConName -> Q [Dec]
defineColumnOffsets ConName
typeName'
[Dec]
pw <- TypeQ -> [Name] -> Q [Dec]
definePersistableWidthInstance (Name -> TypeQ
conT Name
typeName) []
[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
rec' Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
offs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
pw
defineRecordTypeWithConfig :: NameConfig -> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineRecordTypeWithConfig :: NameConfig
-> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineRecordTypeWithConfig config :: NameConfig
config schema :: String
schema table :: String
table columns :: [(String, TypeQ)]
columns =
ConName -> [(VarName, TypeQ)] -> [Name] -> Q [Dec]
defineRecordType
(NameConfig -> String -> String -> ConName
recordTypeName NameConfig
config String
schema String
table)
[ (NameConfig -> String -> String -> VarName
columnName NameConfig
config String
table String
n, TypeQ
t) | (n :: String
n, t :: TypeQ
t) <- [(String, TypeQ)]
columns ]
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType typeCon :: TypeQ
typeCon =
[d| instance PersistableWidth $typeCon where
persistableWidth = Persistable.unsafeValueWidth
instance HasColumnConstraint NotNull $typeCon where
columnConstraint = unsafeSpecifyNotNullValue
|]