module Database.Record.TH (
defineRecord,
defineRecordDefault,
derivingEq, derivingShow, derivingRead, derivingData, derivingTypable,
defineHasColumnConstraintInstance,
defineHasPrimaryConstraintInstanceDerived,
defineHasNotNullKeyInstance,
defineHasPrimaryKeyInstance,
defineHasPrimaryKeyInstanceDefault,
defineHasNotNullKeyInstanceDefault,
defineRecordType, defineRecordTypeDefault,
makeRecordPersistableWithSqlType,
makeRecordPersistableWithSqlTypeDefault,
makeRecordPersistableWithSqlTypeFromDefined,
makeRecordPersistableWithSqlTypeDefaultFromDefined,
defineColumnOffsets,
recordWidthTemplate,
defineRecordParser,
defineRecordPrinter,
definePersistableInstance,
reifyRecordType,
recordTypeNameDefault, recordTypeDefault,
columnOffsetsVarNameDefault,
persistableFunctionNamesDefault,
deriveNotNullType
) where
import Control.Applicative (pure, (<*>))
import Data.List (foldl')
import Data.Array (Array, listArray, (!))
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
(Q, newName, nameBase, reify, Info(TyConI), Name,
TypeQ, conT, Con (NormalC, RecC),
Dec(DataD), dataD, 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
recordTypeNameDefault :: String
-> ConName
recordTypeNameDefault = conCamelcaseName
recordTypeDefault :: String
-> TypeQ
recordTypeDefault = toTypeCon . recordTypeNameDefault
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 |]
defineHasPrimaryKeyInstanceDefault :: String
-> [Int]
-> Q [Dec]
defineHasPrimaryKeyInstanceDefault =
defineHasPrimaryKeyInstance . recordTypeDefault
defineHasNotNullKeyInstanceDefault :: String
-> Int
-> Q [Dec]
defineHasNotNullKeyInstanceDefault =
defineHasNotNullKeyInstance . recordTypeDefault
derivingEq :: ConName
derivingEq = conCamelcaseName "Eq"
derivingShow :: ConName
derivingShow = conCamelcaseName "Show"
derivingRead :: ConName
derivingRead = conCamelcaseName "Read"
derivingData :: ConName
derivingData = conCamelcaseName "Data"
derivingTypable :: ConName
derivingTypable = conCamelcaseName "Typable"
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)]
-> [ConName]
-> 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)] (map conName derives)
offs <- defineColumnOffsets typeName' [ty | (_, ty) <- columns]
return $ rec : offs
columnDefault :: String -> TypeQ -> (VarName, TypeQ)
columnDefault n t = (varCamelcaseName n, t)
defineRecordTypeDefault :: String -> [(String, TypeQ)] -> [ConName] -> Q [Dec]
defineRecordTypeDefault table columns =
defineRecordType
(recordTypeNameDefault table)
[ columnDefault 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")
makeRecordPersistableWithSqlTypeDefault :: TypeQ
-> String
-> Int
-> Q [Dec]
makeRecordPersistableWithSqlTypeDefault sqlValueType table width = do
makeRecordPersistableWithSqlType
sqlValueType
(persistableFunctionNamesDefault . conName . conCamelcaseName $ table)
(recordTypeDefault table, toDataCon . recordTypeNameDefault $ table)
width
recordInfo' :: Info -> Maybe ((TypeQ, ExpQ), (Maybe [Name], [TypeQ]))
recordInfo' = d where
d (TyConI (DataD _cxt tcn _bs [r] _ds)) = 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)]
-> [ConName]
-> 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
defineRecordDefault :: TypeQ
-> String
-> [(String, TypeQ)]
-> [ConName]
-> Q [Dec]
defineRecordDefault sqlValueType table columns derives = do
typ <- defineRecordTypeDefault table columns derives
withSql <- makeRecordPersistableWithSqlTypeDefault sqlValueType 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
|]