{-# 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.Compat.Bang
(varBangType, bangType, bang,
noSourceUnpackedness, sourceStrict)
import Language.Haskell.TH
(Q, nameBase, Name, Dec, TypeQ, conT, ExpQ, listE, sigE, recC, cxt)
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 = forall a b. a -> b -> a
const String
"<nameConfig>"
defaultNameConfig :: NameConfig
defaultNameConfig :: NameConfig
defaultNameConfig =
NameConfig
{ recordTypeName :: String -> String -> ConName
recordTypeName = forall a b. a -> b -> a
const String -> ConName
conCamelcaseName
, columnName :: String -> String -> VarName
columnName = forall a b. a -> b -> a
const String -> VarName
varCamelcaseName
}
recordTemplate :: NameConfig
-> String
-> String
-> (TypeQ, ExpQ)
recordTemplate :: NameConfig -> String -> String -> (TypeQ, ExpQ)
recordTemplate NameConfig
config String
scm = (ConName -> TypeQ
toTypeCon forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ConName -> ExpQ
toDataCon) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"column_offsets_" forall a. [a] -> [a] -> [a]
++) 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 TypeQ
constraint TypeQ
typeCon Int
index =
[d| instance HasColumnConstraint $constraint $typeCon where
columnConstraint = unsafeSpecifyColumnConstraint $(integralE index) |]
defineHasPrimaryConstraintInstanceDerived ::TypeQ
-> Q [Dec]
defineHasPrimaryConstraintInstanceDerived :: TypeQ -> Q [Dec]
defineHasPrimaryConstraintInstanceDerived TypeQ
typeCon =
[d| instance HasKeyConstraint Primary $typeCon where
keyConstraint = derivedCompositePrimary |]
defineHasPrimaryKeyInstance :: TypeQ
-> [Int]
-> Q [Dec]
defineHasPrimaryKeyInstance :: TypeQ -> [Int] -> Q [Dec]
defineHasPrimaryKeyInstance TypeQ
typeCon = [Int] -> Q [Dec]
d where
d :: [Int] -> Q [Dec]
d [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
d [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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
col forall a. [a] -> [a] -> [a]
++ [Dec]
comp
d [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 TypeQ
ty =
[| runPersistableRecordWidth
$(sigE [| persistableWidth |] [t| PersistableRecordWidth $(ty) |])
|]
defineColumnOffsets :: ConName
-> Q [Dec]
defineColumnOffsets :: ConName -> Q [Dec]
defineColumnOffsets ConName
typeName' = do
let ofsVar :: VarName
ofsVar = Name -> VarName
columnOffsetsVarNameDefault 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 ConName
typeName' [(VarName, TypeQ)]
columns [Name]
derives = do
let typeName :: Name
typeName = ConName -> Name
conName ConName
typeName'
fld :: (VarName, m Type) -> m VarBangType
fld (VarName
n, m Type
tq) = forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType (VarName -> Name
varName VarName
n) (forall (m :: * -> *). Quote m => m Bang -> m Type -> m BangType
bangType (forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness forall (m :: * -> *). Quote m => m SourceStrictness
sourceStrict) m Type
tq)
[Name]
derives1 <- if (''Generic forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
derives)
then do String -> Q ()
reportWarning String
"HRR needs Generic instance, please add ''Generic manually."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ''Generic forall a. a -> [a] -> [a]
: [Name]
derives
else forall (m :: * -> *) a. Monad m => a -> m a
return [Name]
derives
Dec
rec' <- CxtQ -> Name -> [TyVarBndr ()] -> [ConQ] -> [Name] -> DecQ
dataD' (forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) Name
typeName [] [forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
recC Name
typeName (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *}. Quote m => (VarName, m Type) -> m VarBangType
fld [(VarName, TypeQ)]
columns)] [Name]
derives1
[Dec]
offs <- ConName -> Q [Dec]
defineColumnOffsets ConName
typeName'
[Dec]
pw <- TypeQ -> [Name] -> Q [Dec]
definePersistableWidthInstance (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
typeName) []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dec
rec' forall a. a -> [a] -> [a]
: [Dec]
offs 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 NameConfig
config String
schema String
table [(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) | (String
n, TypeQ
t) <- [(String, TypeQ)]
columns ]
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType TypeQ
typeCon =
[d| instance PersistableWidth $typeCon where
persistableWidth = Persistable.unsafeValueWidth
instance HasColumnConstraint NotNull $typeCon where
columnConstraint = unsafeSpecifyNotNullValue
|]