relational-query: move ProductConstructor template.

relational-query/src/Database/Relational/Query/Internal/TH.hs

@@ -1,23 +1,36 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module Database.Relational.Query.Internal.TH (
-  defineTuplePi
+  defineProductConstructorInstance,
+  defineTuplePi,
   ) where
 
 import Control.Applicative ((<$>))
 import Data.List (foldl')
 import Language.Haskell.TH
   (Q, mkName, normalB, classP, varP,
-   forallT, varT, tupleT, appT,
+   Exp,
+   Type, forallT, varT, tupleT, appT, arrowT,
    Dec, sigD, valD,
    TyVarBndr (PlainTV), )
 import Database.Record.Persistable
   (PersistableWidth, persistableWidth,
    PersistableRecordWidth, runPersistableRecordWidth)
 
+import Database.Relational.Query.Internal.ProjectableClass (ProductConstructor (..))
+
 import Database.Relational.Query.Pi.Unsafe (Pi, definePi)
 
 
+-- | Make template for 'ProductConstructor' instance.
+defineProductConstructorInstance :: Q Type -> Q Exp -> [Q Type] -> Q [Dec]
+defineProductConstructorInstance recTypeQ recData colTypes =
+  [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where
+        productConstructor = $(recData)
+    |]
+
+-- | xxx
 tuplePi :: Int -> Int -> Q [Dec]
 tuplePi n i = do
   let selN = mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'"

relational-query/src/Database/Relational/Query/TH.hs

@@ -70,7 +70,7 @@ import Data.Array.IArray ((!))
 
 import Language.Haskell.TH
   (Name, nameBase, Q, reify, TypeQ, Type (AppT, ConT), ExpQ,
-   tupleT, appT, arrowT, Dec, stringE, listE)
+   tupleT, appT, Dec, stringE, listE)
 import Language.Haskell.TH.Compat.Reify (unVarI)
 import Language.Haskell.TH.Name.CamelCase
   (VarName, varName, ConName (ConName), conName, varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon, toDataCon)
@@ -82,14 +82,14 @@ import Database.Record.TH
 import qualified Database.Record.TH as Record
 
 import Database.Relational.Query
-  (Table, Pi, id', Relation, ProductConstructor (..),
+  (Table, Pi, id', Relation,
    NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..),
    Config (normalizedTableName, schemaNameMode, nameConfig, identifierQuotation),
    relationalQuerySQL, Query, relationalQuery, KeyUpdate,
    Insert, derivedInsert, InsertQuery, derivedInsertQuery,
    HasConstraintKey(constraintKey), Primary, NotNull, primary, primaryUpdate)
 
-import Database.Relational.Query.Internal.TH (defineTuplePi)
+import Database.Relational.Query.Internal.TH (defineProductConstructorInstance, defineTuplePi)
 import Database.Relational.Query.Scalar (defineScalarDegree)
 import Database.Relational.Query.Constraint (Key, unsafeDefineConstraintKey)
 import Database.Relational.Query.Table (TableDerivable (..))
@@ -280,13 +280,6 @@ relationVarExp :: Config -- ^ Configuration which has  naming rules of templates
                          -> ExpQ   -- ^ Result var Exp
 relationVarExp config scm = toVarExp . relationVarName (nameConfig config) scm
 
--- | Make template for 'ProductConstructor' instance.
-defineProductConstructorInstance :: TypeQ -> ExpQ -> [TypeQ] -> Q [Dec]
-defineProductConstructorInstance recTypeQ recData colTypes =
-  [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where
-        productConstructor = $(recData)
-    |]
-
 -- | Make template for record 'ProductConstructor' instance using specified naming rule.
 defineProductConstructorInstanceWithConfig :: Config -> String -> String -> [TypeQ] -> Q [Dec]
 defineProductConstructorInstanceWithConfig config schema table colTypes = do