summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeiHibino <>2017-07-17 10:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-07-17 10:29:00 (GMT)
commit316c72487c155c2bef56ff5c337086269d99ad09 (patch)
treed82630e88bc621de114b73ff0c34c564a9b45695
parentde0a8ad19ae587db6d8f6b1cc11e0cc5795f3d0e (diff)
version 0.9.2.10.9.2.1
-rw-r--r--ChangeLog.md31
-rw-r--r--relational-query.cabal17
-rw-r--r--src/Database/Relational/Query.hs17
-rw-r--r--src/Database/Relational/Query/BaseTH.hs85
-rw-r--r--src/Database/Relational/Query/Pi/Unsafe.hs14
-rw-r--r--src/Database/Relational/Query/Projectable.hs73
-rw-r--r--src/Database/Relational/Query/ProjectableClass.hs102
-rw-r--r--src/Database/Relational/Query/Projection.hs12
-rw-r--r--src/Database/Relational/Query/Pure.hs67
-rw-r--r--src/Database/Relational/Query/Sub.hs5
-rw-r--r--src/Database/Relational/Query/TH.hs110
-rw-r--r--src/Database/Relational/Query/TupleInstances.hs28
-rw-r--r--test/Model.hs14
13 files changed, 354 insertions, 221 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index d8d4aff..998a46a 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,24 +1,30 @@
<!-- -*- Markdown -*- -->
-## 0.8.5.1
+## 0.9.2.1
- add tested-with 8.2.1.
-## 0.8.5.0
+## 0.9.2.0
+
- Add derivedInsertValue definitions to arrow interface.
- Apply chunked-insert to derivedInsertValue.
-## 0.8.4.0
+## 0.9.1.0
- Fix of unsafeValueNull. ( https://github.com/khibino/haskell-relational-record/issues/55 )
-## 0.8.3.8
+## 0.9.0.2
- Bugfix of case projected record. ( https://github.com/khibino/haskell-relational-record/issues/54 )
-## 0.8.3.7
+## 0.9.0.1
+
+- Use Haskell implementation test instead of flag test in .cabal
+
+## 0.9.0.0
-- Add version constraint for LTS-8.
+- Add HRR instances of tuple types derived by generic programming.
+- Add generic instances of ShowConstantTermsSQL.
## 0.8.3.6
@@ -173,3 +179,16 @@
https://github.com/khibino/haskell-relational-record/pull/15
- Fix for "invalid single-column insert syntax".
https://github.com/khibino/haskell-relational-record/issues/16
+
+## 0.4.0.0
+
+- Extend derivedInsert.
+
+## 0.3.0.0
+
+- Add generalized restrict.
+- Pass configuration to DELETE and UPDATE.
+
+## 0.2.0.0
+
+- Update structure of query with placeholders.
diff --git a/relational-query.cabal b/relational-query.cabal
index 1f0b0c7..56fb3d2 100644
--- a/relational-query.cabal
+++ b/relational-query.cabal
@@ -1,5 +1,5 @@
name: relational-query
-version: 0.8.5.1
+version: 0.9.2.1
synopsis: Typeful, Modular, Relational, algebraic query engine
description: This package contiains typeful relation structure and
relational-algebraic query building DSL which can
@@ -38,11 +38,13 @@ library
Database.Relational.Query.Pi.Unsafe
Database.Relational.Query.Constraint
Database.Relational.Query.Context
- Database.Relational.Query.Projectable
- Database.Relational.Query.ProjectableExtended
Database.Relational.Query.Component
Database.Relational.Query.Sub
Database.Relational.Query.Projection
+ Database.Relational.Query.ProjectableClass
+ Database.Relational.Query.Projectable
+ Database.Relational.Query.ProjectableExtended
+ Database.Relational.Query.TupleInstances
Database.Relational.Query.Monad.BaseType
Database.Relational.Query.Monad.Class
Database.Relational.Query.Monad.Trans.Ordering
@@ -63,6 +65,7 @@ library
Database.Relational.Query.Scalar
Database.Relational.Query.Type
Database.Relational.Query.Derives
+ Database.Relational.Query.BaseTH
Database.Relational.Query.TH
other-modules:
@@ -90,7 +93,9 @@ library
, th-reify-compat
, sql-words >=0.1.4
, names-th
- , persistable-record >=0.3 && <0.5
+ , persistable-record >= 0.5
+ if impl(ghc == 7.4.*)
+ build-depends: ghc-prim == 0.2.*
hs-source-dirs: src
ghc-options: -Wall -fsimpl-tick-factor=200
@@ -103,6 +108,8 @@ test-suite sqls
, relational-query
, containers
, transformers
+ if impl(ghc == 7.4.*)
+ build-depends: ghc-prim == 0.2.*
type: exitcode-stdio-1.0
main-is: sqlsEq.hs
@@ -121,6 +128,8 @@ test-suite sqlsArrow
, relational-query
, containers
, transformers
+ if impl(ghc == 7.4.*)
+ build-depends: ghc-prim == 0.2.*
type: exitcode-stdio-1.0
main-is: sqlsEqArrow.hs
diff --git a/src/Database/Relational/Query.hs b/src/Database/Relational/Query.hs
index 264b3bb..602e780 100644
--- a/src/Database/Relational/Query.hs
+++ b/src/Database/Relational/Query.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Database.Relational.Query
--- Copyright : 2013 Kei Hibino
+-- Copyright : 2013-2017 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
@@ -11,20 +11,21 @@
module Database.Relational.Query (
module Database.Relational.Query.Table,
module Database.Relational.Query.SQL,
- module Database.Relational.Query.Pure,
module Database.Relational.Query.Pi,
module Database.Relational.Query.Constraint,
module Database.Relational.Query.Context,
module Database.Relational.Query.Component,
module Database.Relational.Query.Sub,
module Database.Relational.Query.Projection,
+ module Database.Relational.Query.ProjectableClass,
module Database.Relational.Query.Projectable,
module Database.Relational.Query.ProjectableExtended,
+ module Database.Relational.Query.TupleInstances,
+ module Database.Relational.Query.Monad.BaseType,
module Database.Relational.Query.Monad.Class,
- module Database.Relational.Query.Monad.Trans.Aggregating,
module Database.Relational.Query.Monad.Trans.Ordering,
+ module Database.Relational.Query.Monad.Trans.Aggregating,
module Database.Relational.Query.Monad.Trans.Assigning,
- module Database.Relational.Query.Monad.BaseType,
module Database.Relational.Query.Monad.Type,
module Database.Relational.Query.Monad.Simple,
module Database.Relational.Query.Monad.Aggregate,
@@ -41,7 +42,7 @@ module Database.Relational.Query (
import Database.Relational.Query.Table (Table, TableDerivable (..))
import Database.Relational.Query.SQL (updateOtherThanKeySQL, insertSQL)
-import Database.Relational.Query.Pure
+import Database.Relational.Query.Pure ()
import Database.Relational.Query.Pi
import Database.Relational.Query.Constraint
(Key, tableConstraint, projectionKey,
@@ -56,8 +57,11 @@ import Database.Relational.Query.Component
AggregateKey, Order (..))
import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth)
import Database.Relational.Query.Projection (Projection, list)
+import Database.Relational.Query.ProjectableClass
import Database.Relational.Query.Projectable
import Database.Relational.Query.ProjectableExtended
+import Database.Relational.Query.TupleInstances
+import Database.Relational.Query.Monad.BaseType
import Database.Relational.Query.Monad.Class
(MonadQualify,
MonadRestrict, wheres, having, restrict,
@@ -65,11 +69,10 @@ import Database.Relational.Query.Monad.Class
MonadQuery, query', queryMaybe',
MonadPartition, partitionBy,
distinct, all', on)
+import Database.Relational.Query.Monad.Trans.Ordering (orderBy, asc, desc)
import Database.Relational.Query.Monad.Trans.Aggregating
(key, key', set, bkey, rollup, cube, groupingSets)
-import Database.Relational.Query.Monad.Trans.Ordering (orderBy, asc, desc)
import Database.Relational.Query.Monad.Trans.Assigning (assignTo, (<-#))
-import Database.Relational.Query.Monad.BaseType
import Database.Relational.Query.Monad.Type
import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery)
import Database.Relational.Query.Monad.Aggregate
diff --git a/src/Database/Relational/Query/BaseTH.hs b/src/Database/Relational/Query/BaseTH.hs
new file mode 100644
index 0000000..861ffac
--- /dev/null
+++ b/src/Database/Relational/Query/BaseTH.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+-- |
+-- Module : Database.Relational.Query.BaseTH
+-- Copyright : 2017 Kei Hibino
+-- License : BSD3
+--
+-- Maintainer : ex8k.hibino@gmail.com
+-- Stability : experimental
+-- Portability : unknown
+--
+-- This module defines templates for internally using.
+module Database.Relational.Query.BaseTH (
+ defineProductConstructorInstance,
+ defineTupleProductConstructor,
+ defineTupleShowConstantInstance,
+ defineTuplePi,
+ ) where
+
+import Control.Applicative ((<$>))
+import Data.List (foldl')
+import Language.Haskell.TH
+ (Q, Name, mkName, tupleDataName, normalB, classP, varP,
+ TypeQ, forallT, arrowT, varT, tupleT, appT,
+ Dec, sigD, valD, instanceD, ExpQ, conE,
+ TyVarBndr (PlainTV), )
+import Database.Record.Persistable
+ (PersistableWidth, persistableWidth,
+ PersistableRecordWidth, runPersistableRecordWidth)
+
+import Database.Relational.Query.ProjectableClass
+ (ProductConstructor (..), ShowConstantTermsSQL (..), )
+import Database.Relational.Query.Pi.Unsafe (Pi, definePi)
+
+
+-- | 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)
+ |]
+
+tupleN :: Int -> (([Name], [TypeQ]), TypeQ)
+tupleN n = ((ns, vs), foldl' appT (tupleT n) vs)
+ where
+ ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ]
+ vs = map varT ns
+
+-- | Make template of ProductConstructor instance of tuple type.
+defineTupleProductConstructor :: Int -> Q [Dec]
+defineTupleProductConstructor n = do
+ let ((_, vs), tty) = tupleN n
+ defineProductConstructorInstance tty (conE $ tupleDataName n) vs
+
+-- | Make template of 'ShowConstantTermsSQL' instance of tuple type.
+defineTupleShowConstantInstance :: Int -> Q [Dec]
+defineTupleShowConstantInstance n = do
+ let ((_, vs), tty) = tupleN n
+ (:[]) <$> instanceD
+ -- in template-haskell 2.8 or older, Pred is not Type
+ (mapM (classP ''ShowConstantTermsSQL . (:[])) vs)
+ [t| ShowConstantTermsSQL $tty |]
+ []
+
+tuplePi :: Int -> Int -> Q [Dec]
+tuplePi n i = do
+ let selN = mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'"
+ ((ns, vs), tty) = tupleN n
+ sig <- sigD selN $
+ forallT (map PlainTV ns)
+ (mapM (classP ''PersistableWidth . (:[])) vs)
+ [t| Pi $tty $(vs !! i) |]
+ val <- valD (varP selN)
+ (normalB [| definePi $(foldl'
+ (\e t -> [| $e + runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |])
+ [| 0 :: Int |] $ take i vs) |])
+ []
+ return [sig, val]
+
+-- | Make templates of projection paths for tuple types.
+defineTuplePi :: Int -> Q [Dec]
+defineTuplePi n =
+ concat <$> mapM (tuplePi n) [0 .. n - 1]
diff --git a/src/Database/Relational/Query/Pi/Unsafe.hs b/src/Database/Relational/Query/Pi/Unsafe.hs
index 1fd4373..c94ac38 100644
--- a/src/Database/Relational/Query/Pi/Unsafe.hs
+++ b/src/Database/Relational/Query/Pi/Unsafe.hs
@@ -3,7 +3,7 @@
-- |
-- Module : Database.Relational.Query.Pi.Unsafe
--- Copyright : 2013 Kei Hibino
+-- Copyright : 2013-2017 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
@@ -36,7 +36,9 @@ import Database.Record.Persistable
(PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, (<&>),
PersistableWidth (persistableWidth), maybeWidth)
-import Database.Relational.Query.Pure (ProductConstructor (..))
+import Database.Relational.Query.ProjectableClass
+ (ProductConstructor (..), ProjectableFunctor (..), ProjectableApplicative (..), )
+
-- | Projection path primary structure type.
data Pi' r0 r1 = Leftest Int
@@ -88,6 +90,14 @@ pap b@(Pi _ wb) c@(Pi _ wc) =
(Map $ unsafeExpandIndexes b ++ unsafeExpandIndexes c)
(unsafeCastRecordWidth $ wb <&> wc)
+-- | Compose seed of projection path 'Pi' which has record result type.
+instance ProjectableFunctor (Pi a) where
+ (|$|) = pfmap
+
+-- | Compose projection path 'Pi' which has record result type using applicative style.
+instance ProjectableApplicative (Pi a) where
+ (|*|) = pap
+
-- | Get record width proof object.
width' :: Pi r ct -> PersistableRecordWidth ct
width' (Pi _ w) = w
diff --git a/src/Database/Relational/Query/Projectable.hs b/src/Database/Relational/Query/Projectable.hs
index cdaf168..2c4aa85 100644
--- a/src/Database/Relational/Query/Projectable.hs
+++ b/src/Database/Relational/Query/Projectable.hs
@@ -14,8 +14,8 @@
-- This module defines operators on various polymorphic projections.
module Database.Relational.Query.Projectable (
-- * Projectable from SQL strings
- SqlProjectable (unsafeProjectSqlTerms'), unsafeProjectSql',
- unsafeProjectSqlTerms, unsafeProjectSql,
+ SqlProjectable (unsafeProjectSqlTerms), unsafeProjectSql',
+ unsafeProjectSql,
-- * Projections of values
value,
@@ -59,9 +59,6 @@ module Database.Relational.Query.Projectable (
-- * 'Maybe' type projecitoins
ProjectableMaybe (just, flattenMaybe),
-
- -- * ProjectableFunctor and ProjectableApplicative
- ProjectableFunctor (..), ProjectableApplicative (..), ipfmap
) where
import Prelude hiding (pi)
@@ -79,11 +76,12 @@ import Database.Record.Persistable (runPersistableRecordWidth)
import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)
import qualified Database.Relational.Query.Internal.Sub as Internal
+import Database.Relational.Query.ProjectableClass
+ (ProjectableFunctor (..), ProjectableApplicative (..), )
import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow)
-import Database.Relational.Query.Pure
- (ShowConstantTermsSQL, showConstantTermsSQL', ProductConstructor (..))
-import Database.Relational.Query.Pi (Pi)
-import qualified Database.Relational.Query.Pi as Pi
+import Database.Relational.Query.TupleInstances ()
+import Database.Relational.Query.ProjectableClass
+ (ShowConstantTermsSQL, showConstantTermsSQL, )
import Database.Relational.Query.Projection
(Projection, ListProjection)
import qualified Database.Relational.Query.Projection as Projection
@@ -92,26 +90,20 @@ import qualified Database.Relational.Query.Projection as Projection
-- | Interface to project SQL terms unsafely.
class SqlProjectable p where
-- | Unsafely project from SQL expression terms.
- unsafeProjectSqlTerms' :: [StringSQL] -- ^ SQL expression strings
- -> p t -- ^ Result projection object
-
--- | Unsafely project from SQL strings. String interface of 'unsafeProjectSqlTerms''.
-unsafeProjectSqlTerms :: SqlProjectable p
- => [String] -- ^ SQL expression strings
- -> p t -- ^ Result projection object
-unsafeProjectSqlTerms = unsafeProjectSqlTerms' . map stringSQL
+ unsafeProjectSqlTerms :: [StringSQL] -- ^ SQL expression strings
+ -> p t -- ^ Result projection object
-- | Unsafely make 'Projection' from SQL terms.
instance SqlProjectable (Projection Flat) where
- unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms
+ unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms
-- | Unsafely make 'Projection' from SQL terms.
instance SqlProjectable (Projection Aggregated) where
- unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms
+ unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms
-- | Unsafely make 'Projection' from SQL terms.
instance SqlProjectable (Projection OverWindow) where
- unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms
+ unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms
class SqlProjectable p => OperatorProjectable p
instance OperatorProjectable (Projection Flat)
@@ -119,7 +111,7 @@ instance OperatorProjectable (Projection Aggregated)
-- | Unsafely Project single SQL term.
unsafeProjectSql' :: SqlProjectable p => StringSQL -> p t
-unsafeProjectSql' = unsafeProjectSqlTerms' . (:[])
+unsafeProjectSql' = unsafeProjectSqlTerms . (:[])
-- | Unsafely Project single SQL string. String interface of 'unsafeProjectSql''.
unsafeProjectSql :: SqlProjectable p => String -> p t
@@ -131,7 +123,7 @@ nothing :: (OperatorProjectable (Projection c), SqlProjectable (Projection c), P
nothing = proxyWidth persistableWidth
where
proxyWidth :: SqlProjectable (Projection c) => PersistableRecordWidth a -> Projection c (Maybe a)
- proxyWidth w = unsafeProjectSqlTerms' $ replicate (runPersistableRecordWidth w) SQL.NULL
+ proxyWidth w = unsafeProjectSqlTerms $ replicate (runPersistableRecordWidth w) SQL.NULL
{-# DEPRECATED unsafeValueNull "Use `nothing' instead of this." #-}
-- | Deprecated. Polymorphic projection of SQL null value.
@@ -141,7 +133,7 @@ unsafeValueNull = nothing
-- | Generate polymorphic projection of SQL constant values from Haskell value.
value :: (ShowConstantTermsSQL t, OperatorProjectable p) => t -> p t
-value = unsafeProjectSqlTerms' . showConstantTermsSQL'
+value = unsafeProjectSqlTerms . showConstantTermsSQL
-- | Polymorphic proejction of SQL true value.
valueTrue :: (OperatorProjectable p, ProjectableMaybe p) => p (Maybe Bool)
@@ -493,8 +485,7 @@ pwPlaceholder pw f = (PlaceHolders, f $ projectPlaceHolder pw)
projectPlaceHolder :: SqlProjectable p
=> PersistableRecordWidth a
-> p a
- projectPlaceHolder = unsafeProjectSqlTerms' . (`replicate` "?") . runPersistableRecordWidth
-
+ projectPlaceHolder = unsafeProjectSqlTerms . (`replicate` "?") . runPersistableRecordWidth
-- | Provide scoped placeholder and return its parameter object.
placeholder' :: (PersistableWidth t, SqlProjectable p) => (p t -> a) -> (PlaceHolders t, a)
@@ -543,21 +534,6 @@ instance ProjectableIdZip PlaceHolders where
leftId = unsafeCastPlaceHolders
rightId = unsafeCastPlaceHolders
--- | Weaken functor on projections.
-class ProjectableFunctor p where
- -- | Method like 'fmap'.
- (|$|) :: ProductConstructor (a -> b) => (a -> b) -> p a -> p b
-
--- | Same as '|$|' other than using inferred record constructor.
-ipfmap :: (ProjectableFunctor p, ProductConstructor (a -> b))
- => p a -> p b
-ipfmap = (|$|) productConstructor
-
--- | Weaken applicative functor on projections.
-class ProjectableFunctor p => ProjectableApplicative p where
- -- | Method like '<*>'.
- (|*|) :: p (a -> b) -> p a -> p b
-
-- | Compose seed of record type 'PlaceHolders'.
instance ProjectableFunctor PlaceHolders where
_ |$| PlaceHolders = PlaceHolders
@@ -566,26 +542,9 @@ instance ProjectableFunctor PlaceHolders where
instance ProjectableApplicative PlaceHolders where
pf |*| pa = unsafeCastPlaceHolders (pf >< pa)
--- | Compose seed of record type 'Projection'.
-instance ProjectableFunctor (Projection c) where
- (|$|) = Projection.pfmap
-
--- | Compose record type 'Projection' using applicative style.
-instance ProjectableApplicative (Projection c) where
- (|*|) = Projection.pap
-
--- | Compose seed of projection path 'Pi' which has record result type.
-instance ProjectableFunctor (Pi a) where
- (|$|) = Pi.pfmap
-
--- | Compose projection path 'Pi' which has record result type using applicative style.
-instance ProjectableApplicative (Pi a) where
- (|*|) = Pi.pap
-
infixl 7 .*., ./., ?*?, ?/?
infixl 6 .+., .-., ?+?, ?-?
infixl 5 .||., ?||?
-infixl 4 |$|, |*|
infix 4 .=., .<>., .>., .>=., .<., .<=., `in'`, `like`, `likeMaybe`, `like'`, `likeMaybe'`
infixr 3 `and'`
infixr 2 `or'`
diff --git a/src/Database/Relational/Query/ProjectableClass.hs b/src/Database/Relational/Query/ProjectableClass.hs
new file mode 100644
index 0000000..9965c37
--- /dev/null
+++ b/src/Database/Relational/Query/ProjectableClass.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DefaultSignatures #-}
+
+-- |
+-- Module : Database.Relational.Query.ProjectableClass
+-- Copyright : 2017 Kei Hibino
+-- License : BSD3
+--
+-- Maintainer : ex8k.hibino@gmail.com
+-- Stability : experimental
+-- Portability : unknown
+--
+-- This module provides interfaces to preserve constraints of
+-- direct product projections.
+module Database.Relational.Query.ProjectableClass (
+ -- * Interface to specify record constructors.
+ ProductConstructor (..),
+
+ -- * ProjectableFunctor and ProjectableApplicative
+ ProjectableFunctor (..), ProjectableApplicative (..), ipfmap,
+
+ -- * Literal SQL terms
+ ShowConstantTermsSQL (..), showConstantTermsSQL,
+ StringSQL,
+
+ ) where
+
+import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from)
+import Data.Monoid (mempty, (<>))
+import Data.DList (DList, toList)
+
+import Database.Relational.Query.Internal.SQL (StringSQL)
+
+
+-- | Specify tuple like record constructors which are allowed to define 'ProjectableFunctor'.
+class ProductConstructor r where
+ -- | The constructor which has type 'r'.
+ productConstructor :: r
+
+-- | Weaken functor on projections.
+class ProjectableFunctor p where
+ -- | Method like 'fmap'.
+ (|$|) :: ProductConstructor (a -> b) => (a -> b) -> p a -> p b
+
+-- | Same as '|$|' other than using inferred record constructor.
+ipfmap :: (ProjectableFunctor p, ProductConstructor (a -> b))
+ => p a -> p b
+ipfmap = (|$|) productConstructor
+
+-- | Weaken applicative functor on projections.
+class ProjectableFunctor p => ProjectableApplicative p where
+ -- | Method like '<*>'.
+ (|*|) :: p (a -> b) -> p a -> p b
+
+infixl 4 |$|, |*|
+
+
+-- | Convert from haskell record to SQL terms list.
+showConstantTermsSQL :: ShowConstantTermsSQL a
+ => a
+ -> [StringSQL]
+showConstantTermsSQL = toList . showConstantTermsSQL'
+
+{- |
+'ShowConstantTermsSQL' 'a' is implicit rule to derive function to convert
+from haskell record type 'a' into constant SQL terms.
+
+Generic programming (<https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#generic-programming>)
+with default signature is available for 'ShowConstantTermsSQL' class,
+so you can make instance like below:
+
+@
+ \{\-\# LANGUAGE DeriveGeneric \#\-\}
+ import GHC.Generics (Generic)
+ --
+ data Foo = Foo { ... } deriving Generic
+ instance ShowConstantTermsSQL Foo
+@
+
+-}
+class ShowConstantTermsSQL a where
+ showConstantTermsSQL' :: a -> DList StringSQL
+
+ default showConstantTermsSQL' :: (Generic a, GShowConstantTermsSQL (Rep a)) => a -> DList StringSQL
+ showConstantTermsSQL' = gShowConstantTermsSQL . from
+
+class GShowConstantTermsSQL f where
+ gShowConstantTermsSQL :: f a -> DList StringSQL
+
+instance GShowConstantTermsSQL U1 where
+ gShowConstantTermsSQL U1 = mempty
+
+instance (GShowConstantTermsSQL a, GShowConstantTermsSQL b) =>
+ GShowConstantTermsSQL (a :*: b) where
+ gShowConstantTermsSQL (a :*: b) = gShowConstantTermsSQL a <> gShowConstantTermsSQL b
+
+instance GShowConstantTermsSQL a => GShowConstantTermsSQL (M1 i c a) where
+ gShowConstantTermsSQL (M1 a) = gShowConstantTermsSQL a
+
+instance ShowConstantTermsSQL a => GShowConstantTermsSQL (K1 i a) where
+ gShowConstantTermsSQL (K1 a) = showConstantTermsSQL' a
diff --git a/src/Database/Relational/Query/Projection.hs b/src/Database/Relational/Query/Projection.hs
index dda9bea..9023f7e 100644
--- a/src/Database/Relational/Query/Projection.hs
+++ b/src/Database/Relational/Query/Projection.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
-- |
@@ -53,10 +54,11 @@ import Database.Relational.Query.Internal.Sub
Projection, untypeProjection, typedProjection, projectionWidth)
import qualified Database.Relational.Query.Internal.Sub as Internal
+import Database.Relational.Query.ProjectableClass
+ (ProductConstructor (..), ProjectableFunctor (..), ProjectableApplicative (..), )
import Database.Relational.Query.Context (Aggregated, Flat)
import Database.Relational.Query.Table (Table)
import qualified Database.Relational.Query.Table as Table
-import Database.Relational.Query.Pure (ProductConstructor (..))
import Database.Relational.Query.Pi (Pi)
import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi
import Database.Relational.Query.Sub
@@ -167,6 +169,14 @@ _ `pfmap` p = unsafeCast p
pap :: Projection c (a -> b) -> Projection c a -> Projection c b
pf `pap` pa = typedProjection $ untypeProjection pf ++ untypeProjection pa
+-- | Compose seed of record type 'Projection'.
+instance ProjectableFunctor (Projection c) where
+ (|$|) = pfmap
+
+-- | Compose record type 'Projection' using applicative style.
+instance ProjectableApplicative (Projection c) where
+ (|*|) = pap
+
-- | Projection type for row list.
data ListProjection p t = List [p t]
| Sub SubQuery
diff --git a/src/Database/Relational/Query/Pure.hs b/src/Database/Relational/Query/Pure.hs
index acdae28..8084f9a 100644
--- a/src/Database/Relational/Query/Pure.hs
+++ b/src/Database/Relational/Query/Pure.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
-- |
@@ -11,16 +12,10 @@
--
-- This module defines interfaces between haskell pure values
-- and query internal projection values.
-module Database.Relational.Query.Pure (
+module Database.Relational.Query.Pure () where
- -- * Interface to specify record constructors.
- ProductConstructor (..),
-
- -- * Constant SQL Terms
- ShowConstantTermsSQL (..), showConstantTermsSQL
- ) where
-
-import Data.Monoid (mconcat)
+import Control.Applicative (pure)
+import Data.Monoid ((<>))
import Data.Int (Int8, Int16, Int32, Int64)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
@@ -32,6 +27,7 @@ import qualified Data.Text.Lazy.Encoding as LT
import Text.Printf (PrintfArg, printf)
import Data.Time (FormatTime, Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
+import Data.DList (DList, fromList)
import Language.SQL.Keyword (Keyword (..))
import Database.Record
@@ -39,25 +35,14 @@ import Database.Record
import Database.Record.Persistable
(runPersistableRecordWidth)
-import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)
-
-
--- | Specify tuple like record constructors which are allowed to define 'ProjectableFunctor'.
-class ProductConstructor r where
- -- | The constructor which has type 'r'.
- productConstructor :: r
+import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL)
--- | ProductConstructor instance of pair.
-instance ProductConstructor (a -> b -> (a, b)) where
- productConstructor = (,)
+import Database.Relational.Query.ProjectableClass (ShowConstantTermsSQL (..))
--- | Constant integral SQL expression.
-intExprSQL :: (Show a, Integral a) => a -> StringSQL
-intExprSQL = stringSQL . show
-
-intTermsSQL :: (Show a, Integral a) => a -> [StringSQL]
-intTermsSQL = (:[]) . intExprSQL
+-- | Constant integral SQL terms.
+intTermsSQL :: (Show a, Integral a) => a -> DList StringSQL
+intTermsSQL = pure . stringSQL . show
-- | Escape 'String' for constant SQL string expression.
escapeStringToSqlExpr :: String -> String
@@ -70,16 +55,8 @@ escapeStringToSqlExpr = rec where
stringExprSQL :: String -> StringSQL
stringExprSQL = stringSQL . ('\'':) . (++ "'") . escapeStringToSqlExpr
-stringTermsSQL :: String -> [StringSQL]
-stringTermsSQL = (:[]) . stringExprSQL
-
--- | Interface for constant SQL term list.
-class ShowConstantTermsSQL a where
- showConstantTermsSQL' :: a -> [StringSQL]
-
--- | String interface of 'showConstantTermsSQL''.
-showConstantTermsSQL :: ShowConstantTermsSQL a => a -> [String]
-showConstantTermsSQL = map showStringSQL . showConstantTermsSQL'
+stringTermsSQL :: String -> DList StringSQL
+stringTermsSQL = pure . stringExprSQL
-- | Constant SQL terms of 'Int8'.
instance ShowConstantTermsSQL Int8 where
@@ -128,12 +105,12 @@ instance ShowConstantTermsSQL Char where
-- | Constant SQL terms of 'Bool'.
instance ShowConstantTermsSQL Bool where
- showConstantTermsSQL' = (:[]) . stringSQL . d where
+ showConstantTermsSQL' = pure . stringSQL . d where
d True = "(0=0)"
d False = "(0=1)"
-floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> [StringSQL]
-floatTerms f = (:[]) . stringSQL $ printf fmt f where
+floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> DList StringSQL
+floatTerms f = pure . stringSQL $ printf fmt f where
fmt
| f >= 0 = "%f"
| otherwise = "(%f)"
@@ -146,9 +123,8 @@ instance ShowConstantTermsSQL Float where
instance ShowConstantTermsSQL Double where
showConstantTermsSQL' = floatTerms
-constantTimeTerms :: FormatTime t => Keyword -> String -> t -> [StringSQL]
-constantTimeTerms kw fmt t = [mconcat [kw,
- stringExprSQL $ formatTime defaultTimeLocale fmt t]]
+constantTimeTerms :: FormatTime t => Keyword -> String -> t -> DList StringSQL
+constantTimeTerms kw fmt t = pure $ kw <> stringExprSQL (formatTime defaultTimeLocale fmt t)
-- | Constant SQL terms of 'Day'.
instance ShowConstantTermsSQL Day where
@@ -172,17 +148,12 @@ instance ShowConstantTermsSQL ZonedTime where
instance ShowConstantTermsSQL UTCTime where
showConstantTermsSQL' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z"
-showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> [StringSQL]
+showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> DList StringSQL
showMaybeTerms wa = d where
d (Just a) = showConstantTermsSQL' a
- d Nothing = replicate (runPersistableRecordWidth wa) $ stringSQL "NULL"
+ d Nothing = fromList . replicate (runPersistableRecordWidth wa) $ stringSQL "NULL"
-- | Constant SQL terms of 'Maybe' type. Width inference is required.
instance (PersistableWidth a, ShowConstantTermsSQL a)
=> ShowConstantTermsSQL (Maybe a) where
showConstantTermsSQL' = showMaybeTerms persistableWidth
-
--- | Constant SQL terms of '(a, b)' type.
-instance (ShowConstantTermsSQL a, ShowConstantTermsSQL b)
- => ShowConstantTermsSQL (a, b) where
- showConstantTermsSQL' (a, b) = showConstantTermsSQL' a ++ showConstantTermsSQL' b
diff --git a/src/Database/Relational/Query/Sub.hs b/src/Database/Relational/Query/Sub.hs
index d5e4860..0b421e2 100644
--- a/src/Database/Relational/Query/Sub.hs
+++ b/src/Database/Relational/Query/Sub.hs
@@ -70,7 +70,8 @@ import qualified Database.Relational.Query.Internal.UntypedTable as UntypedTable
import Database.Relational.Query.Table (Table)
import qualified Database.Relational.Query.Table as Table
-import Database.Relational.Query.Pure (showConstantTermsSQL')
+import Database.Relational.Query.ProjectableClass (showConstantTermsSQL)
+import Database.Relational.Query.Pure ()
showsSetOp' :: SetOp -> StringSQL
@@ -302,7 +303,7 @@ showsQueryProduct = rec where
[urec left',
joinType (Internal.nodeAttr left') (Internal.nodeAttr right'), JOIN,
urec right',
- ON, foldr1 SQL.and $ ps ++ concat [ showConstantTermsSQL' True | null ps ] ]
+ ON, foldr1 SQL.and $ ps ++ concat [ showConstantTermsSQL True | null ps ] ]
where ps = [ unsafeProjectionStringSql p | p <- rs ]
-- | Shows join product of query.
diff --git a/src/Database/Relational/Query/TH.hs b/src/Database/Relational/Query/TH.hs
index 83df0b3..59af751 100644
--- a/src/Database/Relational/Query/TH.hs
+++ b/src/Database/Relational/Query/TH.hs
@@ -6,7 +6,7 @@
-- |
-- Module : Database.Relational.Query.TH
--- Copyright : 2013-2016 Kei Hibino
+-- Copyright : 2013-2017 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
@@ -20,7 +20,6 @@
module Database.Relational.Query.TH (
-- * All templates about table
defineTable,
- defineTableDefault,
-- * Inlining typed 'Query'
unsafeInlineQuery,
@@ -28,22 +27,21 @@ module Database.Relational.Query.TH (
-- * Column projections and basic 'Relation' for Haskell record
defineTableTypesAndRecord,
- defineTableTypesAndRecordDefault,
-- * Constraint key templates
defineHasPrimaryKeyInstance,
defineHasPrimaryKeyInstanceWithConfig,
- defineHasPrimaryKeyInstanceDefault,
defineHasNotNullKeyInstance,
defineHasNotNullKeyInstanceWithConfig,
- defineHasNotNullKeyInstanceDefault,
defineScalarDegree,
-- * Column projections
defineColumns, defineColumnsDefault,
+ defineTuplePi,
+
-- * Table metadata type and basic 'Relation'
- defineTableTypes, defineTableTypesWithConfig, defineTableTypesDefault,
+ defineTableTypes, defineTableTypesWithConfig,
-- * Basic SQL templates generate rules
definePrimaryQuery,
@@ -53,7 +51,6 @@ module Database.Relational.Query.TH (
derivationExpDefault,
tableVarExpDefault,
relationVarExp,
- relationVarExpDefault,
-- * Derived SQL templates from table definitions
defineSqlsWithPrimaryKey,
@@ -73,25 +70,26 @@ 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)
+ (VarName, varName, ConName (ConName), conName, varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon)
import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE)
import Database.Record.TH
- (columnOffsetsVarNameDefault, recordTypeName, recordType,
+ (columnOffsetsVarNameDefault, recordTypeName, recordTemplate,
defineRecordTypeWithConfig, defineHasColumnConstraintInstance)
import qualified Database.Record.TH as Record
import Database.Relational.Query
- (Table, Pi, id', Relation, ProductConstructor (..),
+ (Table, Pi, id', Relation, ShowConstantTermsSQL,
NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..),
- Config (normalizedTableName, schemaNameMode, nameConfig, identifierQuotation), defaultConfig,
+ Config (normalizedTableName, schemaNameMode, nameConfig, identifierQuotation),
relationalQuerySQL, Query, relationalQuery, KeyUpdate,
Insert, derivedInsert, InsertQuery, derivedInsertQuery,
HasConstraintKey(constraintKey), Primary, NotNull, primary, primaryUpdate)
+import Database.Relational.Query.BaseTH (defineProductConstructorInstance, defineTuplePi)
import Database.Relational.Query.Scalar (defineScalarDegree)
import Database.Relational.Query.Constraint (Key, unsafeDefineConstraintKey)
import Database.Relational.Query.Table (TableDerivable (..))
@@ -133,17 +131,7 @@ defineHasPrimaryKeyInstanceWithConfig :: Config -- ^ configuration parameters
-> [Int] -- ^ Primary key index
-> Q [Dec] -- ^ Declarations of primary constraint key
defineHasPrimaryKeyInstanceWithConfig config scm =
- defineHasPrimaryKeyInstance . recordType (recordConfig $ nameConfig config) scm
-
-{-# DEPRECATED defineHasPrimaryKeyInstanceDefault "Use ' defineHasPrimaryKeyInstanceWithConfig defaultConfig ' instead of this." #-}
--- | Rule template to infer primary key.
-defineHasPrimaryKeyInstanceDefault :: String -- ^ Schema name
- -> String -- ^ Table name
- -> TypeQ -- ^ Column type
- -> [Int] -- ^ Primary key index
- -> Q [Dec] -- ^ Declarations of primary constraint key
-defineHasPrimaryKeyInstanceDefault =
- defineHasPrimaryKeyInstanceWithConfig defaultConfig
+ defineHasPrimaryKeyInstance . fst . recordTemplate (recordConfig $ nameConfig config) scm
-- | Rule template to infer not-null key.
defineHasNotNullKeyInstance :: TypeQ -- ^ Record type
@@ -159,16 +147,7 @@ defineHasNotNullKeyInstanceWithConfig :: Config -- ^ configuration parameters
-> Int -- ^ NotNull key index
-> Q [Dec] -- ^ Declaration of not-null constraint key
defineHasNotNullKeyInstanceWithConfig config scm =
- defineHasNotNullKeyInstance . recordType (recordConfig $ nameConfig config) scm
-
-{-# DEPRECATED defineHasNotNullKeyInstanceDefault "Use ' defineHasNotNullKeyInstanceWithConfig defaultConfig ' instead of this." #-}
--- | Rule template to infer not-null key.
-defineHasNotNullKeyInstanceDefault :: String -- ^ Schema name
- -> String -- ^ Table name
- -> Int -- ^ NotNull key index
- -> Q [Dec] -- ^ Declaration of not-null constraint key
-defineHasNotNullKeyInstanceDefault =
- defineHasNotNullKeyInstanceWithConfig defaultConfig
+ defineHasNotNullKeyInstance . fst . recordTemplate (recordConfig $ nameConfig config) scm
-- | Column projection path 'Pi' template.
@@ -301,28 +280,11 @@ relationVarExp :: Config -- ^ Configuration which has naming rules of templates
-> ExpQ -- ^ Result var Exp
relationVarExp config scm = toVarExp . relationVarName (nameConfig config) scm
-{-# DEPRECATED relationVarExpDefault "Use ' relationVarExp defaultConfig ' instead of this." #-}
--- | Make 'Relation' variable expression template from table name using default naming rule.
-relationVarExpDefault :: String -- ^ Schema name string
- -> String -- ^ Table name string
- -> ExpQ -- ^ Result var Exp
-relationVarExpDefault = relationVarExp defaultConfig
-
--- | 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
- let typeName = recordTypeName (recordConfig $ nameConfig config) schema table
- defineProductConstructorInstance
- (toTypeCon typeName)
- (toDataCon typeName)
- colTypes
+ let tp = recordTemplate (recordConfig $ nameConfig config) schema table
+ uncurry defineProductConstructorInstance tp colTypes
-- | Make templates about table and column metadatas using specified naming rule.
defineTableTypesWithConfig :: Config -- ^ Configuration to generate query with
@@ -338,21 +300,12 @@ defineTableTypesWithConfig config schema table columns = do
(relationVarName nmconfig schema table)
(table `varNameWithPrefix` "insert")
(table `varNameWithPrefix` "insertQuery")
- (recordType recConfig schema table)
+ (fst $ recordTemplate recConfig schema table)
(tableSQL (normalizedTableName config) (schemaNameMode config) (identifierQuotation config) schema table)
(map ((quote (identifierQuotation config)) . fst . fst) columns)
colsDs <- defineColumnsDefault (recordTypeName recConfig schema table) columns
return $ tableDs ++ colsDs
-{-# DEPRECATED defineTableTypesDefault "Use defineTableTypesWithConfig instead of this." #-}
--- | Make templates about table and column metadatas using default naming rule.
-defineTableTypesDefault :: Config -- ^ Configuration to generate query with
- -> String -- ^ Schema name
- -> String -- ^ Table name
- -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type
- -> Q [Dec] -- ^ Result declarations
-defineTableTypesDefault = defineTableTypesWithConfig
-
-- | Make templates about table, column and haskell record using specified naming rule.
defineTableTypesAndRecord :: Config -- ^ Configuration to generate query with
-> String -- ^ Schema name
@@ -361,20 +314,12 @@ defineTableTypesAndRecord :: Config -- ^ Configuration to generate qu
-> [Name] -- ^ Record derivings
-> Q [Dec] -- ^ Result declarations
defineTableTypesAndRecord config schema table columns derives = do
- recD <- defineRecordTypeWithConfig (recordConfig $ nameConfig config) schema table columns derives
+ let recConfig = recordConfig $ nameConfig config
+ recD <- defineRecordTypeWithConfig recConfig schema table columns derives
rconD <- defineProductConstructorInstanceWithConfig config schema table [t | (_, t) <- columns]
+ ctD <- [d| instance ShowConstantTermsSQL $(fst $ recordTemplate recConfig schema table) |]
tableDs <- defineTableTypesWithConfig config schema table [(c, Nothing) | c <- columns ]
- return $ recD ++ rconD ++ tableDs
-
-{-# DEPRECATED defineTableTypesAndRecordDefault "Use defineTableTypesAndRecord instead of this." #-}
--- | Make templates about table, column and haskell record using default naming rule.
-defineTableTypesAndRecordDefault :: Config -- ^ Configuration to generate query with
- -> String -- ^ Schema name
- -> String -- ^ Table name
- -> [(String, TypeQ)] -- ^ Column names and types
- -> [Name] -- ^ Record derivings
- -> Q [Dec] -- ^ Result declarations
-defineTableTypesAndRecordDefault = defineTableTypesAndRecord
+ return $ recD ++ rconD ++ ctD ++ tableDs
-- | Template of derived primary 'Query'.
definePrimaryQuery :: VarName -- ^ Variable name of result declaration
@@ -436,7 +381,7 @@ defineWithPrimaryKey :: Config
-> Q [Dec] -- ^ Result declarations
defineWithPrimaryKey config schema table keyType ixs = do
instD <- defineHasPrimaryKeyInstanceWithConfig config schema table keyType ixs
- let recType = recordType (recordConfig $ nameConfig config) schema table
+ let recType = fst $ recordTemplate (recordConfig $ nameConfig config) schema table
tableE = tableVarExpDefault table
relE = relationVarExp config schema table
sqlsD <- defineSqlsWithPrimaryKeyDefault table keyType recType relE tableE
@@ -465,18 +410,6 @@ defineTable config schema table columns derives primaryIxs mayNotNullIdx = do
nnD <- maybeD (\i -> defineWithNotNullKeyWithConfig config schema table i) mayNotNullIdx
return $ tblD ++ primD ++ nnD
-{-# DEPRECATED defineTableDefault "Use defineTable instead of this." #-}
--- | Generate all templtes about table using default naming rule.
-defineTableDefault :: Config -- ^ Configuration to generate query with
- -> String -- ^ Schema name string of Database
- -> String -- ^ Table name string of Database
- -> [(String, TypeQ)] -- ^ Column names and types
- -> [Name] -- ^ derivings for Record type
- -> [Int] -- ^ Primary key index
- -> Maybe Int -- ^ Not null key index
- -> Q [Dec] -- ^ Result declarations
-defineTableDefault = defineTable
-
-- | Unsafely inlining SQL string 'Query' in compile type.
unsafeInlineQuery :: TypeQ -- ^ Query parameter type
@@ -527,4 +460,5 @@ makeRelationalRecordDefault recTypeName = do
[ ((nameBase n, ct), Nothing) | n <- ns | ct <- cts ])
mayNs
pc <- defineProductConstructorInstance tyCon dataCon cts
- return $ concat [pw, cs, pc]
+ ct <- [d| instance ShowConstantTermsSQL $tyCon |]
+ return $ concat [pw, cs, pc, ct]
diff --git a/src/Database/Relational/Query/TupleInstances.hs b/src/Database/Relational/Query/TupleInstances.hs
new file mode 100644
index 0000000..23521bf
--- /dev/null
+++ b/src/Database/Relational/Query/TupleInstances.hs
@@ -0,0 +1,28 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- |
+-- Module : Database.Relational.Query.TupleInstances
+-- Copyright : 2017 Kei Hibino
+-- License : BSD3
+--
+-- Maintainer : ex8k.hibino@gmail.com
+-- Stability : experimental
+-- Portability : unknown
+--
+-- This module defines ProductConstructor instances and projection path objects of tuple types.
+module Database.Relational.Query.TupleInstances where
+
+import Control.Applicative ((<$>))
+
+import Database.Relational.Query.BaseTH
+ (defineTuplePi, defineTupleProductConstructor, defineTupleShowConstantInstance,)
+
+
+$(concat <$> mapM defineTupleProductConstructor [2..7])
+$(concat <$> mapM defineTuplePi [2..7])
+$(concat <$> mapM defineTupleShowConstantInstance [2..7])
+-- Generic instances of tuple types are generated from 2 to 7 in GHC.Generics.
diff --git a/test/Model.hs b/test/Model.hs
index b1762e6..6909114 100644
--- a/test/Model.hs
+++ b/test/Model.hs
@@ -2,9 +2,11 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveGeneric #-}
module Model where
+import GHC.Generics (Generic)
import Data.Int (Int32, Int64)
import Database.Relational.Query (defaultConfig)
@@ -15,14 +17,14 @@ $(defineTable defaultConfig "TEST" "set_a"
[ ("int_a0" , [t| Int32 |])
, ("str_a1" , [t| String |])
, ("str_a2" , [t| String |]) ]
- [] [0] $ Just 0)
+ [''Generic] [0] $ Just 0)
$(defineTable defaultConfig "TEST" "set_b"
[ ("int_b0" , [t| Int32 |])
, ("may_str_b1" , [t| Maybe String |])
, ("str_b2" , [t| String |]) ]
- [] [0] $ Just 0)
+ [''Generic] [0] $ Just 0)
$(defineTable defaultConfig "TEST" "set_c"
@@ -30,19 +32,19 @@ $(defineTable defaultConfig "TEST" "set_c"
, ("str_c1" , [t| String |])
, ("int_c2" , [t| Int64 |])
, ("may_str_c3" , [t| Maybe String |]) ]
- [] [0] $ Just 0)
+ [''Generic] [0] $ Just 0)
$(defineTable defaultConfig "TEST" "set_i"
[ ("int_i0" , [t| Int32 |]) ]
- [] [0] $ Just 0)
+ [''Generic] [0] $ Just 0)
data ABC =
ABC
{ xJustA :: SetA
, xJustB :: SetB
, xJustC :: SetC
- }
+ } deriving Generic
$(makeRelationalRecordDefault ''ABC)
@@ -51,7 +53,7 @@ data Abc =
{ yJustA :: SetA
, yMayB :: Maybe SetB
, yMayC :: Maybe SetC
- }
+ } deriving Generic
$(makeRelationalRecordDefault ''Abc)