diff --git a/DB-record/DB-record.cabal b/DB-record/DB-record.cabal index ab45e677..c93a19a6 100644 --- a/DB-record/DB-record.cabal +++ b/DB-record/DB-record.cabal @@ -19,6 +19,9 @@ library Database.Record.ToSql Database.Record.Persistable Database.Record.KeyConstraint + Database.Record.TH build-depends: base <5 + , template-haskell + , names-th hs-source-dirs: src diff --git a/DB-record/src/Database/Record/TH.hs b/DB-record/src/Database/Record/TH.hs new file mode 100644 index 00000000..35fe2572 --- /dev/null +++ b/DB-record/src/Database/Record/TH.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Database.Record.TH ( + recordTypeNameDefault, recordTypeDefault, + defineHasNotNullKeyInstance, + defineHasPrimaryKeyInstance, + defineHasPrimaryKeyInstanceDefault, + defineHasNotNullKeyInstanceDefault + ) where + +import Language.Haskell.TH.Name.CamelCase + (ConName, conCamelcaseName, toTypeCon) +import Language.Haskell.TH.Name.Extra (integralE) +import Language.Haskell.TH (Q, TypeQ, Dec) + +import Database.Record.KeyConstraint + (HasKeyConstraint(constraintKey), specifyKeyConstraint, Primary, NotNull) + +defineHasKeyConstraintInstance :: TypeQ -> TypeQ -> Int -> Q [Dec] +defineHasKeyConstraintInstance constraint typeCon index = + [d| instance HasKeyConstraint $constraint $typeCon where + constraintKey = specifyKeyConstraint $(integralE index) |] + +recordTypeNameDefault :: String -> ConName +recordTypeNameDefault = conCamelcaseName + +recordTypeDefault :: String -> TypeQ +recordTypeDefault = toTypeCon . recordTypeNameDefault + +defineHasNotNullKeyInstance :: TypeQ -> Int -> Q [Dec] +defineHasNotNullKeyInstance = + defineHasKeyConstraintInstance [t| NotNull |] + +defineHasPrimaryKeyInstance :: TypeQ -> Int -> Q [Dec] +defineHasPrimaryKeyInstance = + defineHasKeyConstraintInstance [t| Primary |] + +defineHasPrimaryKeyInstanceDefault :: String -> Int -> Q [Dec] +defineHasPrimaryKeyInstanceDefault = + defineHasPrimaryKeyInstance . recordTypeDefault + +defineHasNotNullKeyInstanceDefault :: String -> Int -> Q [Dec] +defineHasNotNullKeyInstanceDefault = + defineHasNotNullKeyInstance . recordTypeDefault diff --git a/schema-th/src/Database/HDBC/TH.hs b/schema-th/src/Database/HDBC/TH.hs index 04885e90..bd43bb91 100644 --- a/schema-th/src/Database/HDBC/TH.hs +++ b/schema-th/src/Database/HDBC/TH.hs @@ -68,8 +68,9 @@ import Database.HDBC.Session (withConnectionIO) import Database.Record.Persistable (persistableRecord, Persistable, persistable, persistableRecordWidth, PersistableWidth, persistableWidth) -import Database.Record.KeyConstraint - (HasKeyConstraint(constraintKey), specifyKeyConstraint, Primary, NotNull) +import Database.Record.TH + (recordTypeNameDefault, recordTypeDefault, + defineHasPrimaryKeyInstanceDefault, defineHasNotNullKeyInstanceDefault) import Database.Record.FromSql (FromSql(recordFromSql), recordFromSql') import Database.Record.ToSql (ToSql(recordToSql), recordToSql') import Database.Relational.Query.Type (unsafeTypedQuery) @@ -84,12 +85,6 @@ import Database.HDBC.Schema.Driver (Driver, getFields, getPrimaryKey) nameOfTableSQL :: String -> String -> String nameOfTableSQL schema table = map toUpper schema ++ '.' : map toLower table -recordTypeNameDefault :: String -> ConName -recordTypeNameDefault = conCamelcaseName - -recordTypeDefault :: String -> TypeQ -recordTypeDefault = toTypeCon . recordTypeNameDefault - fieldInfo :: String -> TypeQ @@ -188,19 +183,6 @@ definePersistableInstance widthVar' typeCon consFunName' decompFunName' width = recordToSql = recordToSql' |] -defineHasKeyConstraintInstance :: TypeQ -> TypeQ -> Int -> Q [Dec] -defineHasKeyConstraintInstance constraint typeCon index = - [d| instance HasKeyConstraint $constraint $typeCon where - constraintKey = specifyKeyConstraint $(integralE index) |] - -defineHasNotNullKeyInstance :: TypeQ -> Int -> Q [Dec] -defineHasNotNullKeyInstance = - defineHasKeyConstraintInstance [t| NotNull |] - -defineHasPrimaryKeyInstance :: TypeQ -> Int -> Q [Dec] -defineHasPrimaryKeyInstance = - defineHasKeyConstraintInstance [t| Primary |] - defineRecordDecomposeFunction :: VarName -- ^ Name of record decompose function. -> TypeQ -- ^ Name of record type. -> [VarName] -- ^ List of field names of record. @@ -256,15 +238,6 @@ defineRecordDefault schema table fields drives = do fields' drives -defineHasPrimaryKeyInstanceDefault :: String -> Int -> Q [Dec] -defineHasPrimaryKeyInstanceDefault = - defineHasPrimaryKeyInstance . recordTypeDefault - -defineHasNotNullKeyInstanceDefault :: String -> Int -> Q [Dec] -defineHasNotNullKeyInstanceDefault = - defineHasNotNullKeyInstance . recordTypeDefault - - defineConstantSql :: VarName -> String -> Q [Dec] defineConstantSql name' sqlStr = do let name = varName name'