{-# 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
{ recordTypeName :: String -> String -> ConName
, columnName :: String -> String -> VarName
}
instance Show NameConfig where
show = const "<nameConfig>"
defaultNameConfig :: NameConfig
defaultNameConfig =
NameConfig
{ recordTypeName = const conCamelcaseName
, columnName = const varCamelcaseName
}
recordTemplate :: NameConfig
-> String
-> String
-> (TypeQ, ExpQ)
recordTemplate config scm = (toTypeCon &&& toDataCon) . recordTypeName config scm
columnOffsetsVarNameDefault :: Name
-> VarName
columnOffsetsVarNameDefault = varCamelcaseName . ("column_offsets_" ++) . nameBase
defineHasColumnConstraintInstance :: TypeQ
-> TypeQ
-> Int
-> Q [Dec]
defineHasColumnConstraintInstance constraint typeCon index =
[d| instance HasColumnConstraint $constraint $typeCon where
columnConstraint = unsafeSpecifyColumnConstraint $(integralE index) |]
defineHasPrimaryConstraintInstanceDerived ::TypeQ
-> Q [Dec]
defineHasPrimaryConstraintInstanceDerived typeCon =
[d| instance HasKeyConstraint Primary $typeCon where
keyConstraint = derivedCompositePrimary |]
defineHasPrimaryKeyInstance :: TypeQ
-> [Int]
-> Q [Dec]
defineHasPrimaryKeyInstance typeCon = d where
d [] = return []
d [ix] = do
col <- defineHasColumnConstraintInstance [t| Primary |] typeCon ix
comp <- defineHasPrimaryConstraintInstanceDerived typeCon
return $ col ++ comp
d ixs =
[d| instance HasKeyConstraint Primary $typeCon where
keyConstraint = unsafeSpecifyKeyConstraint
$(listE [integralE ix | ix <- ixs ])
|]
defineHasNotNullKeyInstance :: TypeQ
-> Int
-> Q [Dec]
defineHasNotNullKeyInstance =
defineHasColumnConstraintInstance [t| NotNull |]
recordWidthTemplate :: TypeQ
-> ExpQ
recordWidthTemplate ty =
[| runPersistableRecordWidth
$(sigE [| persistableWidth |] [t| PersistableRecordWidth $(ty) |])
|]
defineColumnOffsets :: ConName
-> Q [Dec]
defineColumnOffsets typeName' = do
let ofsVar = columnOffsetsVarNameDefault $ conName typeName'
simpleValD (varName ofsVar) [t| Array Int Int |]
[| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |]
defineRecordType :: ConName
-> [(VarName, TypeQ)]
-> [Name]
-> Q [Dec]
defineRecordType typeName' columns derives = do
let typeName = conName typeName'
fld (n, tq) = varBangType (varName n) (bangType (bang noSourceUnpackedness sourceStrict) tq)
derives1 <- if (''Generic `notElem` derives)
then do reportWarning "HRR needs Generic instance, please add ''Generic manually."
return $ ''Generic : derives
else return derives
rec' <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives1
offs <- defineColumnOffsets typeName'
pw <- definePersistableWidthInstance (conT typeName) []
return $ rec' : offs ++ pw
defineRecordTypeWithConfig :: NameConfig -> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineRecordTypeWithConfig config schema table columns =
defineRecordType
(recordTypeName config schema table)
[ (columnName config table n, t) | (n, t) <- columns ]
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType typeCon =
[d| instance PersistableWidth $typeCon where
persistableWidth = Persistable.unsafeValueWidth
instance HasColumnConstraint NotNull $typeCon where
columnConstraint = unsafeSpecifyNotNullValue
|]