Move TH functions to construct and to decompose records.

DB-record/src/Database/Record/TH.hs

@@ -11,19 +11,26 @@ module Database.Record.TH (
 
   derivingEq, derivingShow, derivingRead, derivingData, derivingTypable,
 
-  defineRecordType
+  defineRecordType,
+  defineRecordConstructFunction,
+  defineRecordDecomposeFunction
   ) where
 
 import Language.Haskell.TH.Name.CamelCase
   (ConName(conName), VarName(varName), conCamelcaseName, toTypeCon)
 import Language.Haskell.TH.Name.Extra (integralE)
 import Language.Haskell.TH
-  (Q, TypeQ, Dec, DecQ, dataD,
-   recC, cxt, varStrictType, strictType, isStrict)
+  (Q, mkName,
+   TypeQ, conT,
+   Dec, DecQ, dataD, sigD, funD,
+   appsE, conE, varE, listE, stringE,
+   listP, varP, wildP,
+   clause, normalB, recC, cxt, varStrictType, strictType, isStrict)
 
 import Database.Record.KeyConstraint
   (HasKeyConstraint(constraintKey), specifyKeyConstraint, Primary, NotNull)
-
+import Database.Record.Persistable
+  (fromSql, toSql)
 
 defineHasKeyConstraintInstance :: TypeQ -> TypeQ -> Int -> Q [Dec]
 defineHasKeyConstraintInstance constraint typeCon index =
@@ -68,3 +75,44 @@ defineRecordType typeName' fields derives = do
   dataD (cxt []) typeName [] [recC typeName (map fld fields)] (map conName derives)
   where
     fld (n, tq) = varStrictType (varName n) (strictType isStrict tq)
+
+defineRecordConstructFunction :: TypeQ     -- ^ SQL value type.
+                              -> VarName   -- ^ Name of record construct function.
+                              -> ConName   -- ^ Name of record type.
+                              -> Int       -- ^ Count of record fields.
+                              -> Q [Dec]   -- ^ Declaration of record construct function from SqlValues.
+defineRecordConstructFunction sqlValType funName' typeName' width = do
+  let funName = varName funName'
+      typeName = conName typeName'
+      names = map (mkName . ('f':) . show) [1 .. width]
+      fromSqlE n = [| fromSql $(varE n) |]
+  sig <- sigD funName [t| [$(sqlValType)] -> $(conT typeName) |]
+  var <- funD funName
+         [ clause
+           [listP (map varP names)]
+            (normalB . appsE $ conE typeName : map fromSqlE names)
+            [],
+            clause [wildP]
+            (normalB
+             [| error
+                $(stringE
+                  $ "Generated code of 'defineRecordConstructFunction': Fail to pattern match in: "
+                  ++ show funName
+                  ++ ", count of fields is " ++ show width) |])
+            [] ]
+  return [sig, var]
+
+defineRecordDecomposeFunction :: TypeQ     -- ^ SQL value type.
+                              -> VarName   -- ^ Name of record decompose function.
+                              -> TypeQ     -- ^ Name of record type.
+                              -> [VarName] -- ^ List of field names of record.
+                              -> Q [Dec]   -- ^ Declaration of record construct function from SqlValues.
+defineRecordDecomposeFunction sqlValType funName' typeCon fields = do
+  let funName = varName funName'
+      accessors = map (varE . varName) fields
+      recVar = mkName "rec"
+  sig <- sigD funName [t| $typeCon -> [$(sqlValType)] |]
+  var <- funD funName [ clause [varP recVar]
+                        (normalB . listE $ map (\a -> [| toSql ($a $(varE recVar)) |]) accessors)
+                        [] ]
+  return [sig, var]

schema-th/src/Database/HDBC/TH.hs

@@ -45,29 +45,28 @@ import Data.List (elemIndex)
 import Database.HDBC (IConnection, SqlValue)
 
 import Language.Haskell.TH.Name.CamelCase
-  (ConName (conName), VarName (varName),
+  (ConName, VarName (varName),
    varCamelcaseName,
    varNameWithPrefix,
    toTypeCon)
 import Language.Haskell.TH.Name.Extra
   (integralE, simpleValD, compileError)
 import Language.Haskell.TH
-  (Q, mkName, runIO,
+  (Q, runIO,
    TypeQ, Dec,
-   appsE, conE, varE, listE, stringE,
-   listP, varP, wildP,
-   conT,
-   sigD, funD, valD,
-   clause, normalB)
+   varE, listE, stringE,
+   varP,
+   sigD, valD,
+   normalB)
 
 import Database.HDBC.Session (withConnectionIO)
 import Database.Record.Persistable
-  (fromSql, toSql, persistableRecord, Persistable, persistable,
+  (persistableRecord, Persistable, persistable,
    persistableRecordWidth, PersistableWidth, persistableWidth)
 import Database.Record.TH
   (recordTypeNameDefault, recordTypeDefault,
    defineHasPrimaryKeyInstanceDefault, defineHasNotNullKeyInstanceDefault,
-   defineRecordType)
+   defineRecordType, defineRecordConstructFunction, defineRecordDecomposeFunction)
 import Database.Record.FromSql (FromSql(recordFromSql), recordFromSql')
 import Database.Record.ToSql (ToSql(recordToSql), recordToSql')
 import Database.Relational.Query.Type (unsafeTypedQuery)
@@ -92,32 +91,6 @@ fieldInfo n t = ((varCamelcaseName n, t), n)
 mayDeclare :: (a -> Q [Dec]) -> Maybe a -> Q [Dec]
 mayDeclare =  maybe (return [])
 
-defineRecordConstructFunction :: TypeQ     -- ^ SQL value type.
-                              -> VarName   -- ^ Name of record construct function.
-                              -> ConName   -- ^ Name of record type.
-                              -> Int       -- ^ Count of record fields.
-                              -> Q [Dec]   -- ^ Declaration of record construct function from SqlValues.
-defineRecordConstructFunction sqlValType funName' typeName' width = do
-  let funName = varName funName'
-      typeName = conName typeName'
-      names = map (mkName . ('f':) . show) [1 .. width]
-      fromSqlE n = [| fromSql $(varE n) |]
-  sig <- sigD funName [t| [$(sqlValType)] -> $(conT typeName) |]
-  var <- funD funName
-         [ clause
-           [listP (map varP names)]
-            (normalB . appsE $ conE typeName : map fromSqlE names)
-            [],
-            clause [wildP]
-            (normalB
-             [| error
-                $(stringE
-                  $ "Generated code of 'defineRecordConstructFunction': Fail to pattern match in: "
-                  ++ show funName
-                  ++ ", count of fields is " ++ show width) |])
-            [] ]
-  return [sig, var]
-
 defineTableInfo :: VarName -> String
                 -> VarName -> [String]
                 -> VarName -> Int
@@ -149,21 +122,6 @@ definePersistableInstance widthVar' typeCon consFunName' decompFunName' width =
         recordToSql = recordToSql'
     |]
 
-defineRecordDecomposeFunction :: TypeQ     -- ^ SQL value type.
-                              -> VarName   -- ^ Name of record decompose function.
-                              -> TypeQ     -- ^ Name of record type.
-                              -> [VarName] -- ^ List of field names of record.
-                              -> Q [Dec]   -- ^ Declaration of record construct function from SqlValues.
-defineRecordDecomposeFunction sqlValType funName' typeCon fields = do
-  let funName = varName funName'
-      accessors = map (varE . varName) fields
-      recVar = mkName "rec"
-  sig <- sigD funName [t| $typeCon -> [$(sqlValType)] |]
-  var <- funD funName [ clause [varP recVar]
-                        (normalB . listE $ map (\a -> [| toSql ($a $(varE recVar)) |]) accessors)
-                        [] ]
-  return [sig, var]
-
 defineRecord :: (VarName, VarName)
             -> (String, ConName)
             -> (VarName, VarName, VarName)