From 872d09c58d0b472e8456da8adfe640c32529c08b Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Mon, 27 Mar 2017 17:02:45 +0900 Subject: [PATCH] relational-query: move ProductConstructor template. --- .../Database/Relational/Query/Internal/TH.hs | 17 +++++++++++++++-- .../src/Database/Relational/Query/TH.hs | 13 +++---------- 2 files changed, 18 insertions(+), 12 deletions(-) diff --git a/relational-query/src/Database/Relational/Query/Internal/TH.hs b/relational-query/src/Database/Relational/Query/Internal/TH.hs index 74fb5d02..370acfa1 100644 --- a/relational-query/src/Database/Relational/Query/Internal/TH.hs +++ b/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 ++ "'" diff --git a/relational-query/src/Database/Relational/Query/TH.hs b/relational-query/src/Database/Relational/Query/TH.hs index f563aeb6..a103a760 100644 --- a/relational-query/src/Database/Relational/Query/TH.hs +++ b/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