khibino/haskell-relational-record
1
1
Fork 0
mirror of https://github.com/khibino/haskell-relational-record.git synced 2025-01-07 13:46:41 +03:00
Code Issues Projects Releases Wiki Activity

Use TypeQ instead of ConName.

Browse Source
This commit is contained in:
Kei Hibino 2013-03-26 21:05:46 +09:00
parent d77636060f
commit e18c8f508c
1 changed files with 14 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
schema-th/src/Database/HDBC/TH.hs
View File

@ -124,11 +124,14 @@ varNameWithPrefix n p = toVarName $ p ++ camelcaseUpper n
nameOfTableSQL :: String -> String -> String nameOfTableSQL :: String -> String -> String
nameOfTableSQL schema table = map toUpper schema ++ '.' : map toLower table nameOfTableSQL schema table = map toUpper schema ++ '.' : map toLower table
typeOfName :: ConName -> TypeQ
typeOfName = conT . conName
recordTypeNameDefault :: String -> ConName recordTypeNameDefault :: String -> ConName
recordTypeNameDefault = conCamelcaseName recordTypeNameDefault = conCamelcaseName
recordTypeDefault :: String -> TypeQ recordTypeDefault :: String -> TypeQ
recordTypeDefault = conT . conName . recordTypeNameDefault recordTypeDefault = typeOfName . recordTypeNameDefault
pprQ :: (Functor m, TH.Quasi m, Ppr a) => Q a -> m TH.Doc pprQ :: (Functor m, TH.Quasi m, Ppr a) => Q a -> m TH.Doc
@ -213,9 +216,8 @@ defineTableInfo tableVar' table fieldsVar' fields widthVar' width = do
widthQ <- simpleValD widthVar [t| Int |] [| $(integralE $ width) |] widthQ <- simpleValD widthVar [t| Int |] [| $(integralE $ width) |]
return $ concat [tableQ, fieldsQ, widthQ] return $ concat [tableQ, fieldsQ, widthQ]
definePersistableInstance :: VarName -> ConName -> VarName -> VarName -> Int -> Q [Dec] definePersistableInstance :: VarName -> TypeQ -> VarName -> VarName -> Int -> Q [Dec]
definePersistableInstance widthVar' typeName' consFunName' decompFunName' width = do definePersistableInstance widthVar' typeCon consFunName' decompFunName' width = do
let typeCon = conT $ conName typeName'
[d| instance Persistable $typeCon where [d| instance Persistable $typeCon where
persistable = persistableRecord persistable = persistableRecord
$(varE $ varName consFunName') $(varE $ varName consFunName')
@ -230,8 +232,8 @@ definePersistableInstance widthVar' typeName' consFunName' decompFunName' width
|] |]
defineHasKeyConstraintInstance :: TypeQ -> TypeQ -> Int -> Q [Dec] defineHasKeyConstraintInstance :: TypeQ -> TypeQ -> Int -> Q [Dec]
defineHasKeyConstraintInstance constraint type' index = defineHasKeyConstraintInstance constraint typeCon index =
[d| instance HasKeyConstraint $constraint $type' where [d| instance HasKeyConstraint $constraint $typeCon where
constraintKey = specifyKeyConstraint $(integralE index) |] constraintKey = specifyKeyConstraint $(integralE index) |]
defineHasNotNullKeyInstance :: TypeQ -> Int -> Q [Dec] defineHasNotNullKeyInstance :: TypeQ -> Int -> Q [Dec]
@ -243,15 +245,14 @@ defineHasPrimaryKeyInstance =
defineHasKeyConstraintInstance [t| Primary |] defineHasKeyConstraintInstance [t| Primary |]
defineRecordDecomposeFunction :: VarName -- ^ Name of record decompose function. defineRecordDecomposeFunction :: VarName -- ^ Name of record decompose function.
-> ConName -- ^ Name of record type. -> TypeQ -- ^ Name of record type.
-> [VarName] -- ^ List of field names of record. -> [VarName] -- ^ List of field names of record.
-> Q [Dec] -- ^ Declaration of record construct function from SqlValues. -> Q [Dec] -- ^ Declaration of record construct function from SqlValues.
defineRecordDecomposeFunction funName' typeName' fields = do defineRecordDecomposeFunction funName' typeCon fields = do
let funName = varName funName' let funName = varName funName'
typeName = conName typeName'
accessors = map (varE . varName) fields accessors = map (varE . varName) fields
recVar = mkName "rec" recVar = mkName "rec"
sig <- sigD funName [t| $(conT typeName) -> [SqlValue] |] sig <- sigD funName [t| $typeCon -> [SqlValue] |]
var <- funD funName [ clause [varP recVar] var <- funD funName [ clause [varP recVar]
(normalB . listE $ map (\a -> [| toSql ($a $(varE recVar)) |]) accessors) (normalB . listE $ map (\a -> [| toSql ($a $(varE recVar)) |]) accessors)
[] ] [] ]
@ -271,12 +272,13 @@ defineTable
let schemas = map fst schemas' let schemas = map fst schemas'
typ <- defineRecordType tyC schemas drvs typ <- defineRecordType tyC schemas drvs
let width = length schemas' let width = length schemas'
typeCon = typeOfName tyC
fromSQL <- defineRecordConstructFunction cF tyC width fromSQL <- defineRecordConstructFunction cF tyC width
toSQL <- defineRecordDecomposeFunction dF tyC (map fst schemas) toSQL <- defineRecordDecomposeFunction dF typeCon (map fst schemas)
tableI <- defineTableInfo tableI <- defineTableInfo
tableN tableSQL tableN tableSQL
fldsN (map snd schemas') widthN width fldsN (map snd schemas') widthN width
instSQL <- definePersistableInstance widthN tyC cF dF width instSQL <- definePersistableInstance widthN typeCon cF dF width
return $ typ : fromSQL ++ toSQL ++ tableI ++ instSQL return $ typ : fromSQL ++ toSQL ++ tableI ++ instSQL
defineTableDefault' :: String defineTableDefault' :: String