{-# 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 = 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) -> VarBangTypeQ
fld (n :: VarName
n, tq :: TypeQ
tq) = Name -> BangTypeQ -> VarBangTypeQ
varBangType (VarName -> Name
varName VarName
n) (BangQ -> TypeQ -> BangTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
sourceStrict) 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 -> [VarBangTypeQ] -> ConQ
recC Name
typeName (((VarName, TypeQ) -> VarBangTypeQ)
-> [(VarName, TypeQ)] -> [VarBangTypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (VarName, TypeQ) -> VarBangTypeQ
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
|]