module Database.Record.TH (
defineRecord,
defineRecordWithConfig,
defineHasColumnConstraintInstance,
defineHasPrimaryConstraintInstanceDerived,
defineHasPrimaryKeyInstance,
defineHasNotNullKeyInstance,
defineRecordType,
defineRecordTypeWithConfig,
defineColumnOffsets,
recordWidthTemplate,
reifyRecordType,
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, varNameWithPrefix,
toTypeCon, toDataCon, )
import Language.Haskell.TH.Lib.Extra (integralE, simpleValD, reportWarning)
import Language.Haskell.TH.Compat.Data (dataD', unDataD)
import Language.Haskell.TH
(Q, nameBase, reify, Info(TyConI), Name,
TypeQ, conT, Con (NormalC, RecC),
Dec,
ExpQ, conE, listE, sigE,
recC,
cxt, varStrictType, strictType, isStrict)
import Control.Arrow ((&&&))
import Database.Record
(HasColumnConstraint(columnConstraint), Primary, NotNull,
HasKeyConstraint(keyConstraint), derivedCompositePrimary,
PersistableRecordWidth, PersistableWidth(persistableWidth),
FromSql, ToSql, )
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 (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 = (`varNameWithPrefix` "columnOffsets") . 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
-> [TypeQ]
-> Q [Dec]
defineColumnOffsets typeName' tys = do
let ofsVar = columnOffsetsVarNameDefault $ conName typeName'
widthIxE = integralE $ length tys
ar <- simpleValD (varName ofsVar) [t| Array Int Int |]
[| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |]
pw <- [d| instance PersistableWidth $(toTypeCon typeName')
|]
return $ ar ++ pw
defineRecordType :: ConName
-> [(VarName, TypeQ)]
-> [Name]
-> Q [Dec]
defineRecordType typeName' columns derives = do
let typeName = conName typeName'
fld (n, tq) = varStrictType (varName n) (strictType isStrict 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' [ty | (_, ty) <- columns]
return $ rec' : offs
defineRecordTypeWithConfig :: NameConfig -> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineRecordTypeWithConfig config schema table columns =
defineRecordType
(recordTypeName config schema table)
[ (columnName config schema n, t) | (n, t) <- columns ]
fromSqlNameDefault :: String -> VarName
fromSqlNameDefault = (`varNameWithPrefix` "fromSqlOf")
toSqlNameDefault :: String -> VarName
toSqlNameDefault = (`varNameWithPrefix` "toSqlOf")
recordInfo' :: Info -> Maybe ((TypeQ, ExpQ), (Maybe [Name], [TypeQ]))
recordInfo' = d where
d (TyConI tcon) = do
(_cxt, tcn, _bs, _mk, [r], _ds) <- unDataD tcon
case r of
NormalC dcn ts -> Just ((conT tcn, conE dcn), (Nothing, [return t | (_, t) <- ts]))
RecC dcn vts -> Just ((conT tcn, conE dcn), (Just ns, ts))
where (ns, ts) = unzip [(n, return t) | (n, _, t) <- vts]
_ -> Nothing
d _ = Nothing
reifyRecordType :: Name -> Q ((TypeQ, ExpQ), (Maybe [Name], [TypeQ]))
reifyRecordType recTypeName = do
tyConInfo <- reify recTypeName
maybe
(fail $ "Defined record type constructor not found: " ++ show recTypeName)
return
(recordInfo' tyConInfo)
definePersistableInstance :: TypeQ
-> TypeQ
-> Q [Dec]
definePersistableInstance sqlType typeCon = do
[d| instance FromSql $sqlType $typeCon
instance ToSql $sqlType $typeCon
|]
defineRecord :: TypeQ
-> ConName
-> [(VarName, TypeQ)]
-> [Name]
-> Q [Dec]
defineRecord
sqlValueType
tyC
columns drvs = do
typ <- defineRecordType tyC columns drvs
withSql <- definePersistableInstance sqlValueType $ toTypeCon tyC
return $ typ ++ withSql
defineRecordWithConfig :: TypeQ
-> NameConfig
-> String
-> String
-> [(String, TypeQ)]
-> [Name]
-> Q [Dec]
defineRecordWithConfig sqlValueType config schema table columns derives = do
typ <- defineRecordTypeWithConfig config schema table columns derives
withSql <- definePersistableInstance sqlValueType . fst $ recordTemplate config schema table
return $ typ ++ withSql
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType typeCon =
[d| instance PersistableWidth $typeCon where
persistableWidth = Persistable.unsafeValueWidth
instance HasColumnConstraint NotNull $typeCon where
columnConstraint = unsafeSpecifyNotNullValue
|]