module Database.Record.TH (
defineRecord,
defineRecordWithConfig,
derivingEq, derivingShow, derivingRead, derivingData, derivingTypeable,
defineHasColumnConstraintInstance,
defineHasPrimaryConstraintInstanceDerived,
defineHasPrimaryKeyInstance,
defineHasNotNullKeyInstance,
defineRecordType,
defineRecordTypeWithConfig,
makeRecordPersistableWithSqlType,
makeRecordPersistableWithSqlTypeWithConfig,
makeRecordPersistableWithSqlTypeDefault,
makeRecordPersistableWithSqlTypeFromDefined,
makeRecordPersistableWithSqlTypeDefaultFromDefined,
defineColumnOffsets,
recordWidthTemplate,
defineRecordParser,
defineRecordPrinter,
definePersistableInstance,
reifyRecordType,
NameConfig, defaultNameConfig,
recordTypeName, columnName,
recordType,
columnOffsetsVarNameDefault,
persistableFunctionNamesDefault,
deriveNotNullType
) where
import Control.Applicative (pure, (<*>))
import Data.List (foldl')
import Data.Array (Array, listArray, (!))
import Data.Data (Data, Typeable)
import Language.Haskell.TH.Name.CamelCase
(ConName(conName), VarName(varName),
conCamelcaseName, varCamelcaseName, varNameWithPrefix,
toTypeCon, toDataCon, toVarExp)
import Language.Haskell.TH.Lib.Extra (integralE, simpleValD)
import Language.Haskell.TH.Compat.Data (dataD', unDataD)
import Language.Haskell.TH
(Q, newName, nameBase, reify, Info(TyConI), Name,
TypeQ, conT, Con (NormalC, RecC),
Dec, sigD, valD,
ExpQ, Exp(ConE), conE, varE, lamE, listE, sigE,
varP, conP, normalB, recC,
cxt, varStrictType, strictType, isStrict)
import Database.Record
(HasColumnConstraint(columnConstraint), Primary, NotNull,
HasKeyConstraint(keyConstraint), derivedCompositePrimary,
PersistableRecordWidth, PersistableWidth(persistableWidth),
FromSql(recordFromSql), RecordFromSql,
ToSql(recordToSql), RecordToSql, wrapToSql, putRecord, putEmpty)
import Database.Record.KeyConstraint
(unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint)
import Database.Record.Persistable (unsafePersistableRecordWidth, runPersistableRecordWidth)
import qualified Database.Record.Persistable as Persistable
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
}
recordType :: NameConfig
-> String
-> String
-> TypeQ
recordType config scm = toTypeCon . 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 |]
derivingEq :: Name
derivingEq = ''Eq
derivingShow :: Name
derivingShow = ''Show
derivingRead :: Name
derivingRead = ''Read
derivingData :: Name
derivingData = ''Data
derivingTypeable :: Name
derivingTypeable = ''Typeable
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 |]
[| listArray (0 :: Int, $widthIxE) $
scanl (+) (0 :: Int) $(listE $ map recordWidthTemplate tys) |]
pw <- [d| instance PersistableWidth $(toTypeCon typeName') where
persistableWidth = unsafePersistableRecordWidth $ $(toVarExp ofsVar) ! $widthIxE
|]
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)
rec <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives
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 ]
defineRecordParser :: TypeQ
-> VarName
-> (TypeQ, ExpQ)
-> Int
-> Q [Dec]
defineRecordParser sqlValType name' (tyCon, dataCon) width = do
let name = varName name'
sig <- sigD name [t| RecordFromSql $sqlValType $tyCon |]
var <- valD (varP name)
(normalB
(foldl' (\a x -> [| $a <*> $x |]) [| pure $dataCon |]
$ replicate width [| recordFromSql |])
)
[]
return [sig, var]
dataConInfo :: Exp -> Q Name
dataConInfo = d where
d (ConE n) = return n
d e = fail $ "Not record data constructor: " ++ show e
defineRecordPrinter :: TypeQ
-> VarName
-> (TypeQ, ExpQ)
-> Int
-> Q [Dec]
defineRecordPrinter sqlValType name' (tyCon, dataCon) width = do
let name = varName name'
sig <- sigD name [t| RecordToSql $sqlValType $tyCon |]
names <- mapM (newName . ('f':) . show) [1 .. width]
dcn <- dataCon >>= dataConInfo
var <- valD (varP name)
(normalB [| wrapToSql
$(lamE
[ conP dcn [ varP n | n <- names ] ]
(foldr (\a x -> [| $a >> $x |]) [| putEmpty () |]
[ [| putRecord $(varE n) |] | n <- names ])) |])
[]
return [sig, var]
definePersistableInstance :: TypeQ
-> TypeQ
-> VarName
-> VarName
-> Int
-> Q [Dec]
definePersistableInstance sqlType typeCon parserName printerName _width = do
[d| instance FromSql $sqlType $typeCon where
recordFromSql = $(toVarExp parserName)
instance ToSql $sqlType $typeCon where
recordToSql = $(toVarExp printerName)
|]
makeRecordPersistableWithSqlType :: TypeQ
-> (VarName, VarName)
-> (TypeQ, ExpQ)
-> Int
-> Q [Dec]
makeRecordPersistableWithSqlType
sqlValueType
(cF, dF) conPair@(tyCon, _)
width = do
fromSQL <- defineRecordParser sqlValueType cF conPair width
toSQL <- defineRecordPrinter sqlValueType dF conPair width
instSQL <- definePersistableInstance sqlValueType tyCon cF dF width
return $ fromSQL ++ toSQL ++ instSQL
fromSqlNameDefault :: String -> VarName
fromSqlNameDefault = (`varNameWithPrefix` "fromSqlOf")
toSqlNameDefault :: String -> VarName
toSqlNameDefault = (`varNameWithPrefix` "toSqlOf")
makeRecordPersistableWithSqlTypeWithConfig :: TypeQ
-> NameConfig
-> String
-> String
-> Int
-> Q [Dec]
makeRecordPersistableWithSqlTypeWithConfig sqlValueType config schema table width =
makeRecordPersistableWithSqlType
sqlValueType
(persistableFunctionNamesDefault . conName . conCamelcaseName $ table)
(recordType config schema table, toDataCon . recordTypeName config schema $ table)
width
makeRecordPersistableWithSqlTypeDefault :: TypeQ
-> String
-> String
-> Int
-> Q [Dec]
makeRecordPersistableWithSqlTypeDefault sqlValueType =
makeRecordPersistableWithSqlTypeWithConfig sqlValueType defaultNameConfig
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)
persistableFunctionNamesDefault :: Name -> (VarName, VarName)
persistableFunctionNamesDefault recTypeName = (fromSqlNameDefault bn, toSqlNameDefault bn) where
bn = nameBase recTypeName
makeRecordPersistableWithSqlTypeFromDefined :: TypeQ
-> (VarName, VarName)
-> Name
-> Q [Dec]
makeRecordPersistableWithSqlTypeFromDefined sqlValueType fnames recTypeName = do
(conPair, (_, cts)) <- reifyRecordType recTypeName
makeRecordPersistableWithSqlType sqlValueType fnames conPair $ length cts
makeRecordPersistableWithSqlTypeDefaultFromDefined :: TypeQ
-> Name
-> Q [Dec]
makeRecordPersistableWithSqlTypeDefaultFromDefined sqlValueType recTypeName =
makeRecordPersistableWithSqlTypeFromDefined sqlValueType (persistableFunctionNamesDefault recTypeName) recTypeName
defineRecord :: TypeQ
-> (VarName, VarName)
-> ConName
-> [(VarName, TypeQ)]
-> [Name]
-> Q [Dec]
defineRecord
sqlValueType
fnames tyC
columns drvs = do
typ <- defineRecordType tyC columns drvs
withSql <- makeRecordPersistableWithSqlType sqlValueType fnames (toTypeCon tyC, toDataCon tyC) $ length columns
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 <- makeRecordPersistableWithSqlTypeWithConfig sqlValueType config schema table $ length columns
return $ typ ++ withSql
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType typeCon =
[d| instance PersistableWidth $typeCon where
persistableWidth = Persistable.unsafeValueWidth
instance HasColumnConstraint NotNull $typeCon where
columnConstraint = unsafeSpecifyNotNullValue
|]