summaryrefslogtreecommitdiff
path: root/src/Database/Record/TH.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Database/Record/TH.hs')
-rw-r--r--src/Database/Record/TH.hs129
1 files changed, 24 insertions, 105 deletions
diff --git a/src/Database/Record/TH.hs b/src/Database/Record/TH.hs
index b8865a3..0c63d19 100644
--- a/src/Database/Record/TH.hs
+++ b/src/Database/Record/TH.hs
@@ -14,10 +14,6 @@
-- This module defines templates for Haskell record type and
-- type class instances to map between list of untyped SQL type and Haskell record type.
module Database.Record.TH (
- -- * Generate all templates about record
- defineRecord,
- defineRecordWithConfig,
-
-- * Table constraint specified by key
defineHasColumnConstraintInstance,
defineHasPrimaryConstraintInstanceDerived,
@@ -30,11 +26,11 @@ module Database.Record.TH (
-- * Function declarations against defined record types
defineColumnOffsets,
-
recordWidthTemplate,
- -- * Reify
- reifyRecordType,
+ -- * Instance definitions against defined record types
+ definePersistableWidthInstance,
+ defineSqlPersistableInstances,
-- * Templates about record name
NameConfig, defaultNameConfig,
@@ -58,22 +54,17 @@ import Language.Haskell.TH.Name.CamelCase
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.Compat.Data (dataD')
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)
+ (Q, nameBase, Name, Dec, TypeQ, conT, ExpQ, 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, )
+ PersistableRecordWidth, PersistableWidth(persistableWidth), )
import Database.Record.KeyConstraint
(unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint)
@@ -81,7 +72,8 @@ import Database.Record.Persistable
(runPersistableRecordWidth,
ProductConst, getProductConst, genericFieldOffsets)
import qualified Database.Record.Persistable as Persistable
-import Database.Record.InternalTH (defineTupleInstances)
+import Database.Record.InternalTH
+ (definePersistableWidthInstance, defineSqlPersistableInstances, defineTupleInstances)
-- | 'NameConfig' type to customize names of expanded record templates.
@@ -122,14 +114,14 @@ columnOffsetsVarNameDefault = (`varNameWithPrefix` "columnOffsets") . nameBase
defineHasColumnConstraintInstance :: TypeQ -- ^ Type which represent constraint type
-> TypeQ -- ^ Type constructor of record
-> Int -- ^ Key index which specifies this constraint
- -> Q [Dec] -- ^ Result declaration template
+ -> Q [Dec] -- ^ Result definition template
defineHasColumnConstraintInstance constraint typeCon index =
[d| instance HasColumnConstraint $constraint $typeCon where
columnConstraint = unsafeSpecifyColumnConstraint $(integralE index) |]
-- | Template of 'HasKeyConstraint' instance.
defineHasPrimaryConstraintInstanceDerived ::TypeQ -- ^ Type constructor of record
- -> Q [Dec] -- ^ Result declaration template
+ -> Q [Dec] -- ^ Result definition template
defineHasPrimaryConstraintInstanceDerived typeCon =
[d| instance HasKeyConstraint Primary $typeCon where
keyConstraint = derivedCompositePrimary |]
@@ -137,7 +129,7 @@ defineHasPrimaryConstraintInstanceDerived typeCon =
-- | Template of 'HasColumnConstraint' 'Primary' instance.
defineHasPrimaryKeyInstance :: TypeQ -- ^ Type constructor of record
-> [Int] -- ^ Key index which specifies this constraint
- -> Q [Dec] -- ^ Declaration of primary key constraint instance
+ -> Q [Dec] -- ^ Definition of primary key constraint instance
defineHasPrimaryKeyInstance typeCon = d where
d [] = return []
d [ix] = do
@@ -153,7 +145,7 @@ defineHasPrimaryKeyInstance typeCon = d where
-- | Template of 'HasColumnConstraint' 'NotNull' instance.
defineHasNotNullKeyInstance :: TypeQ -- ^ Type constructor of record
-> Int -- ^ Key index which specifies this constraint
- -> Q [Dec] -- ^ Declaration of not null key constraint instance
+ -> Q [Dec] -- ^ Definition of not null key constraint instance
defineHasNotNullKeyInstance =
defineHasColumnConstraintInstance [t| NotNull |]
@@ -165,24 +157,19 @@ recordWidthTemplate ty =
$(sigE [| persistableWidth |] [t| PersistableRecordWidth $(ty) |])
|]
--- | Column offset array and 'PersistableWidth' instance declaration.
+-- | Column offset array definition.
defineColumnOffsets :: ConName -- ^ Record type constructor.
- -> [TypeQ] -- ^ Types of record columns.
- -> Q [Dec] -- ^ Declaration of 'PersistableWidth' instance.
-defineColumnOffsets typeName' tys = do
+ -> Q [Dec] -- ^ Result column offset array declaration.
+defineColumnOffsets typeName' = 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
+ simpleValD (varName ofsVar) [t| Array Int Int |]
+ [| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |]
--- | Record type declaration template.
+-- | Record type definition template.
defineRecordType :: ConName -- ^ Name of the data type of table record type.
-> [(VarName, TypeQ)] -- ^ List of columns in the table. Must be legal, properly cased record columns.
-> [Name] -- ^ Deriving type class names.
- -> Q [Dec] -- ^ The data type record declaration.
+ -> Q [Dec] -- ^ The data type record definition
defineRecordType typeName' columns derives = do
let typeName = conName typeName'
fld (n, tq) = varStrictType (varName n) (strictType isStrict tq)
@@ -192,85 +179,17 @@ defineRecordType typeName' columns derives = do
{- DROP this hack in future version ups. -}
else return derives
rec' <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives1
- offs <- defineColumnOffsets typeName' [ty | (_, ty) <- columns]
- return $ rec' : offs
+ offs <- defineColumnOffsets typeName'
+ pw <- definePersistableWidthInstance (conT typeName) []
+ return $ rec' : offs ++ pw
--- | Record type declaration template with configured names.
+-- | Record type definition template with configured names.
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 ]
-
--- | Default name of record construction function from SQL table name.
-fromSqlNameDefault :: String -> VarName
-fromSqlNameDefault = (`varNameWithPrefix` "fromSqlOf")
-
--- | Default name of record decomposition function from SQL table name.
-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
-
--- | Low-level reify interface for record type name.
-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)
-
--- | Record parser and printer instance templates for converting
--- between list of SQL type and Haskell record type.
-definePersistableInstance :: TypeQ -- ^ SQL value type.
- -> TypeQ -- ^ Record type constructor.
- -> Q [Dec] -- ^ Instance declarations.
-definePersistableInstance sqlType typeCon = do
- [d| instance FromSql $sqlType $typeCon
- instance ToSql $sqlType $typeCon
- |]
-
--- | All templates for record type.
-defineRecord :: TypeQ -- ^ SQL value type
- -> ConName -- ^ Record type name
- -> [(VarName, TypeQ)] -- ^ Column schema
- -> [Name] -- ^ Record derivings
- -> Q [Dec] -- ^ Result declarations
-defineRecord
- sqlValueType
- tyC
- columns drvs = do
-
- typ <- defineRecordType tyC columns drvs
- withSql <- definePersistableInstance sqlValueType $ toTypeCon tyC
- return $ typ ++ withSql
-
--- | All templates for record type with configured names.
-defineRecordWithConfig :: TypeQ -- ^ SQL value type
- -> NameConfig -- ^ name rule config
- -> String -- ^ Schema name
- -> String -- ^ Table name
- -> [(String, TypeQ)] -- ^ Column names and types
- -> [Name] -- ^ Record derivings
- -> Q [Dec] -- ^ Result declarations
-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
-
-
-- | Templates for single column value type.
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType typeCon =