summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeiHibino <>2017-07-17 04:38:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-07-17 04:38:00 (GMT)
commitde0a8ad19ae587db6d8f6b1cc11e0cc5795f3d0e (patch)
tree67e83f11fdedf03868473bfb406bd020ae4182a4
parentcda76f7fcf5edf4520e24ddc6ddc37165a679c59 (diff)
version 0.8.5.10.8.5.1
-rw-r--r--ChangeLog.md32
-rw-r--r--relational-query.cabal20
-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, 226 insertions, 353 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index c313177..d8d4aff 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,25 +1,24 @@
<!-- -*- Markdown -*- -->
-## 0.9.2.0
+## 0.8.5.1
+
+- add tested-with 8.2.1.
+
+## 0.8.5.0
- Add derivedInsertValue definitions to arrow interface.
- Apply chunked-insert to derivedInsertValue.
-## 0.9.1.0
+## 0.8.4.0
- Fix of unsafeValueNull. ( https://github.com/khibino/haskell-relational-record/issues/55 )
-## 0.9.0.2
+## 0.8.3.8
- Bugfix of case projected record. ( https://github.com/khibino/haskell-relational-record/issues/54 )
-## 0.9.0.1
-
-- Use Haskell implementation test instead of flag test in .cabal
+## 0.8.3.7
-## 0.9.0.0
-
-- Add HRR instances of tuple types derived by generic programming.
-- Add generic instances of ShowConstantTermsSQL.
+- Add version constraint for LTS-8.
## 0.8.3.6
@@ -174,16 +173,3 @@
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 0f05c97..1f0b0c7 100644
--- a/relational-query.cabal
+++ b/relational-query.cabal
@@ -1,5 +1,5 @@
name: relational-query
-version: 0.9.2.0
+version: 0.8.5.1
synopsis: Typeful, Modular, Relational, algebraic query engine
description: This package contiains typeful relation structure and
relational-algebraic query building DSL which can
@@ -18,7 +18,8 @@ copyright: Copyright (c) 2013-2017 Kei Hibino
category: Database
build-type: Simple
cabal-version: >=1.10
-tested-with: GHC == 8.0.1, GHC == 8.0.2
+tested-with: GHC == 8.2.1
+ , GHC == 8.0.1, GHC == 8.0.2
, GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3
, GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4
, GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3
@@ -37,13 +38,11 @@ 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
@@ -64,7 +63,6 @@ library
Database.Relational.Query.Scalar
Database.Relational.Query.Type
Database.Relational.Query.Derives
- Database.Relational.Query.BaseTH
Database.Relational.Query.TH
other-modules:
@@ -92,9 +90,7 @@ library
, th-reify-compat
, sql-words >=0.1.4
, names-th
- , persistable-record >= 0.5
- if impl(ghc == 7.4.*)
- build-depends: ghc-prim == 0.2.*
+ , persistable-record >=0.3 && <0.5
hs-source-dirs: src
ghc-options: -Wall -fsimpl-tick-factor=200
@@ -107,8 +103,6 @@ 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
@@ -127,8 +121,6 @@ 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 602e780..264b3bb 100644
--- a/src/Database/Relational/Query.hs
+++ b/src/Database/Relational/Query.hs
@@ -1,6 +1,6 @@
-- |
-- Module : Database.Relational.Query
--- Copyright : 2013-2017 Kei Hibino
+-- Copyright : 2013 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
@@ -11,21 +11,20 @@
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.Ordering,
module Database.Relational.Query.Monad.Trans.Aggregating,
+ module Database.Relational.Query.Monad.Trans.Ordering,
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,
@@ -42,7 +41,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,
@@ -57,11 +56,8 @@ 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,
@@ -69,10 +65,11 @@ 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
deleted file mode 100644
index 861ffac..0000000
--- a/src/Database/Relational/Query/BaseTH.hs
+++ /dev/null
@@ -1,85 +0,0 @@
-{-# 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 c94ac38..1fd4373 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-2017 Kei Hibino
+-- Copyright : 2013 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
@@ -36,9 +36,7 @@ import Database.Record.Persistable
(PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, (<&>),
PersistableWidth (persistableWidth), maybeWidth)
-import Database.Relational.Query.ProjectableClass
- (ProductConstructor (..), ProjectableFunctor (..), ProjectableApplicative (..), )
-
+import Database.Relational.Query.Pure (ProductConstructor (..))
-- | Projection path primary structure type.
data Pi' r0 r1 = Leftest Int
@@ -90,14 +88,6 @@ 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 2c4aa85..cdaf168 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',
- unsafeProjectSql,
+ SqlProjectable (unsafeProjectSqlTerms'), unsafeProjectSql',
+ unsafeProjectSqlTerms, unsafeProjectSql,
-- * Projections of values
value,
@@ -59,6 +59,9 @@ module Database.Relational.Query.Projectable (
-- * 'Maybe' type projecitoins
ProjectableMaybe (just, flattenMaybe),
+
+ -- * ProjectableFunctor and ProjectableApplicative
+ ProjectableFunctor (..), ProjectableApplicative (..), ipfmap
) where
import Prelude hiding (pi)
@@ -76,12 +79,11 @@ 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.TupleInstances ()
-import Database.Relational.Query.ProjectableClass
- (ShowConstantTermsSQL, showConstantTermsSQL, )
+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.Projection
(Projection, ListProjection)
import qualified Database.Relational.Query.Projection as Projection
@@ -90,20 +92,26 @@ 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
+ 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
-- | 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)
@@ -111,7 +119,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
@@ -123,7 +131,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.
@@ -133,7 +141,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)
@@ -485,7 +493,8 @@ 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)
@@ -534,6 +543,21 @@ 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
@@ -542,9 +566,26 @@ 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
deleted file mode 100644
index 9965c37..0000000
--- a/src/Database/Relational/Query/ProjectableClass.hs
+++ /dev/null
@@ -1,102 +0,0 @@
-{-# 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 9023f7e..dda9bea 100644
--- a/src/Database/Relational/Query/Projection.hs
+++ b/src/Database/Relational/Query/Projection.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
-- |
@@ -54,11 +53,10 @@ 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
@@ -169,14 +167,6 @@ _ `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 8084f9a..acdae28 100644
--- a/src/Database/Relational/Query/Pure.hs
+++ b/src/Database/Relational/Query/Pure.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
-- |
@@ -12,10 +11,16 @@
--
-- This module defines interfaces between haskell pure values
-- and query internal projection values.
-module Database.Relational.Query.Pure () where
+module Database.Relational.Query.Pure (
-import Control.Applicative (pure)
-import Data.Monoid ((<>))
+ -- * Interface to specify record constructors.
+ ProductConstructor (..),
+
+ -- * Constant SQL Terms
+ ShowConstantTermsSQL (..), showConstantTermsSQL
+ ) where
+
+import Data.Monoid (mconcat)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
@@ -27,7 +32,6 @@ 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
@@ -35,14 +39,25 @@ import Database.Record
import Database.Record.Persistable
(runPersistableRecordWidth)
-import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL)
+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.ProjectableClass (ShowConstantTermsSQL (..))
+-- | ProductConstructor instance of pair.
+instance ProductConstructor (a -> b -> (a, b)) where
+ productConstructor = (,)
--- | Constant integral SQL terms.
-intTermsSQL :: (Show a, Integral a) => a -> DList StringSQL
-intTermsSQL = pure . stringSQL . show
+-- | Constant integral SQL expression.
+intExprSQL :: (Show a, Integral a) => a -> StringSQL
+intExprSQL = stringSQL . show
+
+intTermsSQL :: (Show a, Integral a) => a -> [StringSQL]
+intTermsSQL = (:[]) . intExprSQL
-- | Escape 'String' for constant SQL string expression.
escapeStringToSqlExpr :: String -> String
@@ -55,8 +70,16 @@ escapeStringToSqlExpr = rec where
stringExprSQL :: String -> StringSQL
stringExprSQL = stringSQL . ('\'':) . (++ "'") . escapeStringToSqlExpr
-stringTermsSQL :: String -> DList StringSQL
-stringTermsSQL = pure . stringExprSQL
+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'
-- | Constant SQL terms of 'Int8'.
instance ShowConstantTermsSQL Int8 where
@@ -105,12 +128,12 @@ instance ShowConstantTermsSQL Char where
-- | Constant SQL terms of 'Bool'.
instance ShowConstantTermsSQL Bool where
- showConstantTermsSQL' = pure . stringSQL . d where
+ showConstantTermsSQL' = (:[]) . stringSQL . d where
d True = "(0=0)"
d False = "(0=1)"
-floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> DList StringSQL
-floatTerms f = pure . stringSQL $ printf fmt f where
+floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> [StringSQL]
+floatTerms f = (:[]) . stringSQL $ printf fmt f where
fmt
| f >= 0 = "%f"
| otherwise = "(%f)"
@@ -123,8 +146,9 @@ instance ShowConstantTermsSQL Float where
instance ShowConstantTermsSQL Double where
showConstantTermsSQL' = floatTerms
-constantTimeTerms :: FormatTime t => Keyword -> String -> t -> DList StringSQL
-constantTimeTerms kw fmt t = pure $ kw <> stringExprSQL (formatTime defaultTimeLocale fmt t)
+constantTimeTerms :: FormatTime t => Keyword -> String -> t -> [StringSQL]
+constantTimeTerms kw fmt t = [mconcat [kw,
+ stringExprSQL $ formatTime defaultTimeLocale fmt t]]
-- | Constant SQL terms of 'Day'.
instance ShowConstantTermsSQL Day where
@@ -148,12 +172,17 @@ 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 -> DList StringSQL
+showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> [StringSQL]
showMaybeTerms wa = d where
d (Just a) = showConstantTermsSQL' a
- d Nothing = fromList . replicate (runPersistableRecordWidth wa) $ stringSQL "NULL"
+ d Nothing = 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 0b421e2..d5e4860 100644
--- a/src/Database/Relational/Query/Sub.hs
+++ b/src/Database/Relational/Query/Sub.hs
@@ -70,8 +70,7 @@ 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.ProjectableClass (showConstantTermsSQL)
-import Database.Relational.Query.Pure ()
+import Database.Relational.Query.Pure (showConstantTermsSQL')
showsSetOp' :: SetOp -> StringSQL
@@ -303,7 +302,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 59af751..83df0b3 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-2017 Kei Hibino
+-- Copyright : 2013-2016 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
@@ -20,6 +20,7 @@
module Database.Relational.Query.TH (
-- * All templates about table
defineTable,
+ defineTableDefault,
-- * Inlining typed 'Query'
unsafeInlineQuery,
@@ -27,21 +28,22 @@ 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,
+ defineTableTypes, defineTableTypesWithConfig, defineTableTypesDefault,
-- * Basic SQL templates generate rules
definePrimaryQuery,
@@ -51,6 +53,7 @@ module Database.Relational.Query.TH (
derivationExpDefault,
tableVarExpDefault,
relationVarExp,
+ relationVarExpDefault,
-- * Derived SQL templates from table definitions
defineSqlsWithPrimaryKey,
@@ -70,26 +73,25 @@ import Data.Array.IArray ((!))
import Language.Haskell.TH
(Name, nameBase, Q, reify, TypeQ, Type (AppT, ConT), ExpQ,
- tupleT, appT, Dec, stringE, listE)
+ tupleT, appT, arrowT, 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)
+ (VarName, varName, ConName (ConName), conName, varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon, toDataCon)
import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE)
import Database.Record.TH
- (columnOffsetsVarNameDefault, recordTypeName, recordTemplate,
+ (columnOffsetsVarNameDefault, recordTypeName, recordType,
defineRecordTypeWithConfig, defineHasColumnConstraintInstance)
import qualified Database.Record.TH as Record
import Database.Relational.Query
- (Table, Pi, id', Relation, ShowConstantTermsSQL,
+ (Table, Pi, id', Relation, ProductConstructor (..),
NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..),
- Config (normalizedTableName, schemaNameMode, nameConfig, identifierQuotation),
+ Config (normalizedTableName, schemaNameMode, nameConfig, identifierQuotation), defaultConfig,
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 (..))
@@ -131,7 +133,17 @@ defineHasPrimaryKeyInstanceWithConfig :: Config -- ^ configuration parameters
-> [Int] -- ^ Primary key index
-> Q [Dec] -- ^ Declarations of primary constraint key
defineHasPrimaryKeyInstanceWithConfig config scm =
- defineHasPrimaryKeyInstance . fst . recordTemplate (recordConfig $ nameConfig 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
-- | Rule template to infer not-null key.
defineHasNotNullKeyInstance :: TypeQ -- ^ Record type
@@ -147,7 +159,16 @@ defineHasNotNullKeyInstanceWithConfig :: Config -- ^ configuration parameters
-> Int -- ^ NotNull key index
-> Q [Dec] -- ^ Declaration of not-null constraint key
defineHasNotNullKeyInstanceWithConfig config scm =
- defineHasNotNullKeyInstance . fst . recordTemplate (recordConfig $ nameConfig 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
-- | Column projection path 'Pi' template.
@@ -280,11 +301,28 @@ 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 tp = recordTemplate (recordConfig $ nameConfig config) schema table
- uncurry defineProductConstructorInstance tp colTypes
+ let typeName = recordTypeName (recordConfig $ nameConfig config) schema table
+ defineProductConstructorInstance
+ (toTypeCon typeName)
+ (toDataCon typeName)
+ colTypes
-- | Make templates about table and column metadatas using specified naming rule.
defineTableTypesWithConfig :: Config -- ^ Configuration to generate query with
@@ -300,12 +338,21 @@ defineTableTypesWithConfig config schema table columns = do
(relationVarName nmconfig schema table)
(table `varNameWithPrefix` "insert")
(table `varNameWithPrefix` "insertQuery")
- (fst $ recordTemplate recConfig schema table)
+ (recordType 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
@@ -314,12 +361,20 @@ defineTableTypesAndRecord :: Config -- ^ Configuration to generate qu
-> [Name] -- ^ Record derivings
-> Q [Dec] -- ^ Result declarations
defineTableTypesAndRecord config schema table columns derives = do
- let recConfig = recordConfig $ nameConfig config
- recD <- defineRecordTypeWithConfig recConfig schema table columns derives
+ recD <- defineRecordTypeWithConfig (recordConfig $ nameConfig config) 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 ++ ctD ++ tableDs
+ 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
-- | Template of derived primary 'Query'.
definePrimaryQuery :: VarName -- ^ Variable name of result declaration
@@ -381,7 +436,7 @@ defineWithPrimaryKey :: Config
-> Q [Dec] -- ^ Result declarations
defineWithPrimaryKey config schema table keyType ixs = do
instD <- defineHasPrimaryKeyInstanceWithConfig config schema table keyType ixs
- let recType = fst $ recordTemplate (recordConfig $ nameConfig config) schema table
+ let recType = recordType (recordConfig $ nameConfig config) schema table
tableE = tableVarExpDefault table
relE = relationVarExp config schema table
sqlsD <- defineSqlsWithPrimaryKeyDefault table keyType recType relE tableE
@@ -410,6 +465,18 @@ 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
@@ -460,5 +527,4 @@ makeRelationalRecordDefault recTypeName = do
[ ((nameBase n, ct), Nothing) | n <- ns | ct <- cts ])
mayNs
pc <- defineProductConstructorInstance tyCon dataCon cts
- ct <- [d| instance ShowConstantTermsSQL $tyCon |]
- return $ concat [pw, cs, pc, ct]
+ return $ concat [pw, cs, pc]
diff --git a/src/Database/Relational/Query/TupleInstances.hs b/src/Database/Relational/Query/TupleInstances.hs
deleted file mode 100644
index 23521bf..0000000
--- a/src/Database/Relational/Query/TupleInstances.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# 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 6909114..b1762e6 100644
--- a/test/Model.hs
+++ b/test/Model.hs
@@ -2,11 +2,9 @@
{-# 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)
@@ -17,14 +15,14 @@ $(defineTable defaultConfig "TEST" "set_a"
[ ("int_a0" , [t| Int32 |])
, ("str_a1" , [t| String |])
, ("str_a2" , [t| String |]) ]
- [''Generic] [0] $ Just 0)
+ [] [0] $ Just 0)
$(defineTable defaultConfig "TEST" "set_b"
[ ("int_b0" , [t| Int32 |])
, ("may_str_b1" , [t| Maybe String |])
, ("str_b2" , [t| String |]) ]
- [''Generic] [0] $ Just 0)
+ [] [0] $ Just 0)
$(defineTable defaultConfig "TEST" "set_c"
@@ -32,19 +30,19 @@ $(defineTable defaultConfig "TEST" "set_c"
, ("str_c1" , [t| String |])
, ("int_c2" , [t| Int64 |])
, ("may_str_c3" , [t| Maybe String |]) ]
- [''Generic] [0] $ Just 0)
+ [] [0] $ Just 0)
$(defineTable defaultConfig "TEST" "set_i"
[ ("int_i0" , [t| Int32 |]) ]
- [''Generic] [0] $ Just 0)
+ [] [0] $ Just 0)
data ABC =
ABC
{ xJustA :: SetA
, xJustB :: SetB
, xJustC :: SetC
- } deriving Generic
+ }
$(makeRelationalRecordDefault ''ABC)
@@ -53,7 +51,7 @@ data Abc =
{ yJustA :: SetA
, yMayB :: Maybe SetB
, yMayC :: Maybe SetC
- } deriving Generic
+ }
$(makeRelationalRecordDefault ''Abc)