Rename package name from relational-join into relational-query.

--HG--
rename : relational-join/GNUmakefile => relational-query/GNUmakefile
rename : relational-join/LICENSE => relational-query/LICENSE
rename : relational-join/Setup.hs => relational-query/Setup.hs
rename : relational-join/debian/changelog => relational-query/debian/changelog
rename : relational-join/debian/compat => relational-query/debian/compat
rename : relational-join/debian/control => relational-query/debian/control
rename : relational-join/debian/copyright => relational-query/debian/copyright
rename : relational-join/debian/rules => relational-query/debian/rules
rename : relational-join/debian/source/format => relational-query/debian/source/format
rename : relational-join/debian/watch => relational-query/debian/watch
rename : relational-join/relational-join.cabal => relational-query/relational-query.cabal
rename : relational-join/src/Database/Relational/Query.hs => relational-query/src/Database/Relational/Query.hs
rename : relational-join/src/Database/Relational/Query/Component.hs => relational-query/src/Database/Relational/Query/Component.hs
rename : relational-join/src/Database/Relational/Query/Constraint.hs => relational-query/src/Database/Relational/Query/Constraint.hs
rename : relational-join/src/Database/Relational/Query/Context.hs => relational-query/src/Database/Relational/Query/Context.hs
rename : relational-join/src/Database/Relational/Query/Derives.hs => relational-query/src/Database/Relational/Query/Derives.hs
rename : relational-join/src/Database/Relational/Query/Expr.hs => relational-query/src/Database/Relational/Query/Expr.hs
rename : relational-join/src/Database/Relational/Query/Expr/Unsafe.hs => relational-query/src/Database/Relational/Query/Expr/Unsafe.hs
rename : relational-join/src/Database/Relational/Query/Internal/AliasId.hs => relational-query/src/Database/Relational/Query/Internal/AliasId.hs
rename : relational-join/src/Database/Relational/Query/Internal/Product.hs => relational-query/src/Database/Relational/Query/Internal/Product.hs
rename : relational-join/src/Database/Relational/Query/Internal/String.hs => relational-query/src/Database/Relational/Query/Internal/String.hs
rename : relational-join/src/Database/Relational/Query/Monad/Aggregate.hs => relational-query/src/Database/Relational/Query/Monad/Aggregate.hs
rename : relational-join/src/Database/Relational/Query/Monad/Class.hs => relational-query/src/Database/Relational/Query/Monad/Class.hs
rename : relational-join/src/Database/Relational/Query/Monad/Qualify.hs => relational-query/src/Database/Relational/Query/Monad/Qualify.hs
rename : relational-join/src/Database/Relational/Query/Monad/Restrict.hs => relational-query/src/Database/Relational/Query/Monad/Restrict.hs
rename : relational-join/src/Database/Relational/Query/Monad/Simple.hs => relational-query/src/Database/Relational/Query/Monad/Simple.hs
rename : relational-join/src/Database/Relational/Query/Monad/Target.hs => relational-query/src/Database/Relational/Query/Monad/Target.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/Aggregating.hs => relational-query/src/Database/Relational/Query/Monad/Trans/Aggregating.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/Assigning.hs => relational-query/src/Database/Relational/Query/Monad/Trans/Assigning.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/AssigningState.hs => relational-query/src/Database/Relational/Query/Monad/Trans/AssigningState.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/Config.hs => relational-query/src/Database/Relational/Query/Monad/Trans/Config.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/Join.hs => relational-query/src/Database/Relational/Query/Monad/Trans/Join.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/JoinState.hs => relational-query/src/Database/Relational/Query/Monad/Trans/JoinState.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/ListState.hs => relational-query/src/Database/Relational/Query/Monad/Trans/ListState.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/Ordering.hs => relational-query/src/Database/Relational/Query/Monad/Trans/Ordering.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/OrderingState.hs => relational-query/src/Database/Relational/Query/Monad/Trans/OrderingState.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/Restricting.hs => relational-query/src/Database/Relational/Query/Monad/Trans/Restricting.hs
rename : relational-join/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs => relational-query/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs
rename : relational-join/src/Database/Relational/Query/Monad/Type.hs => relational-query/src/Database/Relational/Query/Monad/Type.hs
rename : relational-join/src/Database/Relational/Query/Pi.hs => relational-query/src/Database/Relational/Query/Pi.hs
rename : relational-join/src/Database/Relational/Query/Pi/Unsafe.hs => relational-query/src/Database/Relational/Query/Pi/Unsafe.hs
rename : relational-join/src/Database/Relational/Query/Projectable.hs => relational-query/src/Database/Relational/Query/Projectable.hs
rename : relational-join/src/Database/Relational/Query/ProjectableExtended.hs => relational-query/src/Database/Relational/Query/ProjectableExtended.hs
rename : relational-join/src/Database/Relational/Query/Projection.hs => relational-query/src/Database/Relational/Query/Projection.hs
rename : relational-join/src/Database/Relational/Query/Relation.hs => relational-query/src/Database/Relational/Query/Relation.hs
rename : relational-join/src/Database/Relational/Query/Restriction.hs => relational-query/src/Database/Relational/Query/Restriction.hs
rename : relational-join/src/Database/Relational/Query/SQL.hs => relational-query/src/Database/Relational/Query/SQL.hs
rename : relational-join/src/Database/Relational/Query/Sub.hs => relational-query/src/Database/Relational/Query/Sub.hs
rename : relational-join/src/Database/Relational/Query/TH.hs => relational-query/src/Database/Relational/Query/TH.hs
rename : relational-join/src/Database/Relational/Query/Table.hs => relational-query/src/Database/Relational/Query/Table.hs
rename : relational-join/src/Database/Relational/Query/Type.hs => relational-query/src/Database/Relational/Query/Type.hs
rename : relational-join/src/Database/Relational/Schema/DB2Syscat/Columns.hs => relational-query/src/Database/Relational/Schema/DB2Syscat/Columns.hs
rename : relational-join/src/Database/Relational/Schema/DB2Syscat/Keycoluse.hs => relational-query/src/Database/Relational/Schema/DB2Syscat/Keycoluse.hs
rename : relational-join/src/Database/Relational/Schema/DB2Syscat/Tabconst.hs => relational-query/src/Database/Relational/Schema/DB2Syscat/Tabconst.hs
rename : relational-join/src/Database/Relational/Schema/IBMDB2.hs => relational-query/src/Database/Relational/Schema/IBMDB2.hs
rename : relational-join/src/Database/Relational/Schema/PgCatalog/PgAttribute.hs => relational-query/src/Database/Relational/Schema/PgCatalog/PgAttribute.hs
rename : relational-join/src/Database/Relational/Schema/PgCatalog/PgClass.hs => relational-query/src/Database/Relational/Schema/PgCatalog/PgClass.hs
rename : relational-join/src/Database/Relational/Schema/PgCatalog/PgConstraint.hs => relational-query/src/Database/Relational/Schema/PgCatalog/PgConstraint.hs
rename : relational-join/src/Database/Relational/Schema/PgCatalog/PgNamespace.hs => relational-query/src/Database/Relational/Schema/PgCatalog/PgNamespace.hs
rename : relational-join/src/Database/Relational/Schema/PgCatalog/PgType.hs => relational-query/src/Database/Relational/Schema/PgCatalog/PgType.hs
rename : relational-join/src/Database/Relational/Schema/PostgreSQL.hs => relational-query/src/Database/Relational/Schema/PostgreSQL.hs

relational-query/GNUmakefile

@@ -0,0 +1 @@
+../devel/GNUmakefile

relational-query/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2013, Kei Hibino
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Kei Hibino nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

relational-query/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

relational-query/debian/changelog

@@ -0,0 +1,5 @@
+haskell-relational-query (0.0.1.0-1~hackage1) unstable; urgency=low
+
+  * Debianization generated by cabal-debian
+
+ -- Kei Hibino <ex8k.hibino@gmail.com>  Fri, 20 Dec 2013 01:46:25 +0900

relational-query/debian/compat

@@ -0,0 +1 @@
+9

relational-query/debian/control

@@ -0,0 +1,132 @@
+Source: haskell-relational-query
+Maintainer: Kei Hibino <ex8k.hibino@gmail.com>
+Priority: optional
+Section: haskell
+Build-Depends: debhelper (>= 7.0)
+               , haskell-devscripts (>= 0.8)
+               , cdbs
+               , ghc
+               , ghc-prof
+               , libghc-array-dev | ghc
+               , libghc-array-prof | ghc-prof
+               , libghc-base-dev (<< 5) | ghc
+               , libghc-base-prof (<< 5) | ghc-prof
+               , libghc-bytestring-dev | ghc
+               , libghc-bytestring-prof | ghc-prof
+               , libghc-containers-dev | ghc
+               , libghc-containers-prof | ghc-prof
+               , libghc-dlist-dev
+               , libghc-dlist-prof
+               , libghc-names-th-dev
+               , libghc-names-th-prof
+               , libghc-persistable-record-dev
+               , libghc-persistable-record-prof
+               , libghc-sql-words-dev
+               , libghc-sql-words-prof
+               , libghc-template-haskell-dev | ghc
+               , libghc-template-haskell-prof | ghc-prof
+               , libghc-text-dev
+               , libghc-text-prof
+               , libghc-time-dev | ghc
+               , libghc-time-prof | ghc-prof
+               , libghc-transformers-dev
+               , libghc-transformers-prof
+Build-Depends-Indep: ghc-doc
+                     , libghc-array-doc | ghc-doc
+                     , libghc-base-doc (<< 5) | ghc-doc
+                     , libghc-bytestring-doc | ghc-doc
+                     , libghc-containers-doc | ghc-doc
+                     , libghc-dlist-doc
+                     , libghc-names-th-doc
+                     , libghc-persistable-record-doc
+                     , libghc-sql-words-doc
+                     , libghc-template-haskell-doc | ghc-doc
+                     , libghc-text-doc
+                     , libghc-time-doc | ghc-doc
+                     , libghc-transformers-doc
+
+Package: libghc-relational-query-dev
+Architecture: any
+Depends: ${shlibs:Depends}
+         , ${haskell:Depends}
+         , ${misc:Depends}
+Recommends: ${haskell:Recommends}
+Suggests: ${haskell:Suggests}
+Conflicts: ${haskell:Conflicts}
+Provides: ${haskell:Provides}
+Replaces: ${haskell:Replaces}
+Description: Typeful, Modular, Relational, algebraic query engine
+ This package contiains typeful relation structure,
+ SQL query generator and some RDBMSs' schema templates.
+ Supported query features are below:
+ - Type safe query building
+ - Restriction, Join, Aggregation
+ - Modularized relations
+ - Typed placeholders
+ Supported RDBMS schemas are below:
+ - IBM DB2
+ - PostgreSQL
+ .
+  Author: Kei Hibino
+  Upstream-Maintainer: ex8k.hibino@gmail.com
+ .
+ This package provides a library for the Haskell programming language.
+ See http:///www.haskell.org/ for more information on Haskell.
+
+Package: libghc-relational-query-prof
+Architecture: any
+Depends: ${shlibs:Depends}
+         , ${haskell:Depends}
+         , ${misc:Depends}
+Recommends: ${haskell:Recommends}
+Suggests: ${haskell:Suggests}
+Conflicts: ${haskell:Conflicts}
+Provides: ${haskell:Provides}
+Replaces: ${haskell:Replaces}
+Description: Typeful, Modular, Relational, algebraic query engine
+ This package contiains typeful relation structure,
+ SQL query generator and some RDBMSs' schema templates.
+ Supported query features are below:
+ - Type safe query building
+ - Restriction, Join, Aggregation
+ - Modularized relations
+ - Typed placeholders
+ Supported RDBMS schemas are below:
+ - IBM DB2
+ - PostgreSQL
+ .
+  Author: Kei Hibino
+  Upstream-Maintainer: ex8k.hibino@gmail.com
+ .
+ This package provides a library for the Haskell programming language, compiled
+ for profiling.  See http:///www.haskell.org/ for more information on Haskell.
+
+Package: libghc-relational-query-doc
+Architecture: all
+Section: doc
+Depends: ${shlibs:Depends}
+         , ${haskell:Depends}
+         , ${misc:Depends}
+Recommends: ${haskell:Recommends}
+Suggests: ${haskell:Suggests}
+Conflicts: ${haskell:Conflicts}
+Provides: ${haskell:Provides}
+Replaces: ${haskell:Replaces}
+Description: Typeful, Modular, Relational, algebraic query engine
+ This package contiains typeful relation structure,
+ SQL query generator and some RDBMSs' schema templates.
+ Supported query features are below:
+ - Type safe query building
+ - Restriction, Join, Aggregation
+ - Modularized relations
+ - Typed placeholders
+ Supported RDBMS schemas are below:
+ - IBM DB2
+ - PostgreSQL
+ .
+  Author: Kei Hibino
+  Upstream-Maintainer: ex8k.hibino@gmail.com
+ .
+ This package provides the documentation for a library for the Haskell
+ programming language.
+ See http:///www.haskell.org/ for more information on Haskell.

relational-query/debian/copyright

@@ -0,0 +1,30 @@
+Copyright (c) 2013, Kei Hibino
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Kei Hibino nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

relational-query/debian/rules

@@ -0,0 +1,7 @@
+#!/usr/bin/make -f
+
+DEB_CABAL_PACKAGE = relational-query
+
+include /usr/share/cdbs/1/rules/debhelper.mk
+include /usr/share/cdbs/1/class/hlibrary.mk
+

relational-query/debian/source/format

@@ -0,0 +1 @@
+3.0 (quilt)

relational-query/debian/watch

@@ -0,0 +1,5 @@
+version=3
+opts="downloadurlmangle=s|archive/([\w\d_-]+)/([\d\.]+)/|archive/$1/$2/$1-$2.tar.gz|,\
+filenamemangle=s|(.*)/$|relational-query-$1.tar.gz|" \
+    http://hackage.haskell.org/package/relational-query \
+    ([\d\.]*\d)/

relational-query/relational-query.cabal

@@ -0,0 +1,96 @@
+name:                relational-query
+version:             0.0.1.0
+synopsis:            Typeful, Modular, Relational, algebraic query engine
+description:         This package contiains typeful relation structure,
+                     SQL query generator and some RDBMSs' schema templates.
+                     Supported query features are below:
+                     - Type safe query building
+                     - Restriction, Join, Aggregation
+                     - Modularized relations
+                     - Typed placeholders
+                     Supported RDBMS schemas are below:
+                     - IBM DB2
+                     - PostgreSQL
+homepage:            http://twitter.com/khibino
+license:             BSD3
+license-file:        LICENSE
+author:              Kei Hibino
+maintainer:          ex8k.hibino@gmail.com
+copyright:           Copyright (c) 2013 Kei Hibino
+category:            Database
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:
+                       Database.Relational.Query
+                       Database.Relational.Query.Table
+                       Database.Relational.Query.SQL
+                       Database.Relational.Query.Pi
+                       Database.Relational.Query.Pi.Unsafe
+                       Database.Relational.Query.Constraint
+                       Database.Relational.Query.Context
+                       Database.Relational.Query.Projectable
+                       Database.Relational.Query.ProjectableExtended
+                       Database.Relational.Query.Expr
+                       Database.Relational.Query.Expr.Unsafe
+                       Database.Relational.Query.Component
+                       Database.Relational.Query.Sub
+                       Database.Relational.Query.Projection
+                       Database.Relational.Query.Monad.Class
+                       Database.Relational.Query.Monad.Trans.Ordering
+                       Database.Relational.Query.Monad.Trans.Aggregating
+                       Database.Relational.Query.Monad.Trans.Restricting
+                       Database.Relational.Query.Monad.Trans.Join
+                       Database.Relational.Query.Monad.Trans.Config
+                       Database.Relational.Query.Monad.Trans.Assigning
+                       Database.Relational.Query.Monad.Type
+                       Database.Relational.Query.Monad.Simple
+                       Database.Relational.Query.Monad.Aggregate
+                       Database.Relational.Query.Monad.Restrict
+                       Database.Relational.Query.Monad.Target
+                       Database.Relational.Query.Relation
+                       Database.Relational.Query.Restriction
+                       Database.Relational.Query.Type
+                       Database.Relational.Query.Derives
+                       Database.Relational.Query.TH
+
+                       Database.Relational.Schema.DB2Syscat.Columns
+                       Database.Relational.Schema.IBMDB2
+
+                       Database.Relational.Schema.PgCatalog.PgAttribute
+                       Database.Relational.Schema.PgCatalog.PgType
+                       Database.Relational.Schema.PostgreSQL
+
+  other-modules:
+                       Database.Relational.Query.Internal.AliasId
+                       Database.Relational.Query.Internal.String
+                       Database.Relational.Query.Internal.Product
+                       Database.Relational.Query.Monad.Trans.ListState
+                       Database.Relational.Query.Monad.Trans.AssigningState
+                       Database.Relational.Query.Monad.Trans.JoinState
+                       Database.Relational.Query.Monad.Trans.RestrictingState
+                       Database.Relational.Query.Monad.Trans.OrderingState
+                       Database.Relational.Query.Monad.Qualify
+
+                       Database.Relational.Schema.DB2Syscat.Tabconst
+                       Database.Relational.Schema.DB2Syscat.Keycoluse
+
+                       Database.Relational.Schema.PgCatalog.PgNamespace
+                       Database.Relational.Schema.PgCatalog.PgClass
+                       Database.Relational.Schema.PgCatalog.PgConstraint
+
+  build-depends:         base <5
+                       , array
+                       , containers
+                       , transformers
+                       , time
+                       , bytestring
+                       , text
+                       , dlist
+                       , template-haskell
+                       , sql-words
+                       , names-th
+                       , persistable-record
+  hs-source-dirs:      src
+  ghc-options:         -Wall

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

@@ -0,0 +1,75 @@
+-- |
+-- Module      : Database.Relational.Query
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module is integrated module of Query.
+module Database.Relational.Query (
+  module Database.Relational.Query.Table,
+  module Database.Relational.Query.SQL,
+  module Database.Relational.Query.Pi,
+  module Database.Relational.Query.Constraint,
+  module Database.Relational.Query.Context,
+  module Database.Relational.Query.Expr,
+  module Database.Relational.Query.Component,
+  module Database.Relational.Query.Sub,
+  module Database.Relational.Query.Projection,
+  module Database.Relational.Query.Projectable,
+  module Database.Relational.Query.ProjectableExtended,
+  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.Assigning,
+  module Database.Relational.Query.Monad.Type,
+  module Database.Relational.Query.Monad.Simple,
+  module Database.Relational.Query.Monad.Aggregate,
+  module Database.Relational.Query.Monad.Restrict,
+  module Database.Relational.Query.Monad.Target,
+  module Database.Relational.Query.Relation,
+  module Database.Relational.Query.Type,
+  module Database.Relational.Query.Restriction,
+  module Database.Relational.Query.Derives
+  ) where
+
+import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.SQL (updateOtherThanKeySQL, insertSQL)
+import Database.Relational.Query.Pi
+import Database.Relational.Query.Constraint
+  (Key, tableConstraint, projectionKey,
+   uniqueKey, -- notNullKey,
+   HasConstraintKey(constraintKey),
+   derivedUniqueKey, -- derivedNotNullKey,
+   Primary, Unique, NotNull)
+import Database.Relational.Query.Context
+import Database.Relational.Query.Expr hiding (fromJust, just)
+import Database.Relational.Query.Component (Config, defaultConfig, UnitProductSupport (..))
+import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth)
+import Database.Relational.Query.Projection (Projection, list)
+import Database.Relational.Query.Projectable
+import Database.Relational.Query.ProjectableExtended
+import Database.Relational.Query.Monad.Class
+  (on, wheres, groupBy, having, onE, wheresE, havingE)
+import Database.Relational.Query.Monad.Trans.Aggregating (groupBy', key, key', set, bkey, rollup, cube, groupingSets)
+import Database.Relational.Query.Monad.Trans.Ordering (asc, desc)
+import Database.Relational.Query.Monad.Trans.Assigning (assignTo, (!#), (<-#))
+import Database.Relational.Query.Monad.Type
+import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery)
+import Database.Relational.Query.Monad.Aggregate
+  (QueryAggregate, AggregatedQuery)
+import Database.Relational.Query.Monad.Restrict (Restrict)
+import Database.Relational.Query.Monad.Target (Target)
+import Database.Relational.Query.Relation
+import Database.Relational.Query.Type
+  (Query, untypeQuery, relationalQuery', relationalQuery,
+   KeyUpdate, updateKey, untypeKeyUpdate, typedKeyUpdate,
+   Update, untypeUpdate, typedUpdate, targetUpdate,
+   typedUpdateAllColumn, restricredUpdateAllColumn,
+   Insert, untypeInsert, typedInsert,
+   Delete, untypeDelete, typedDelete, restrictedDelete)
+import Database.Relational.Query.Restriction
+import Database.Relational.Query.Derives
+  hiding (specifyTableDerivation', specifyTableDerivation)

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

@@ -0,0 +1,201 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module      : Database.Relational.Query.Component
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module provides untyped components for query.
+module Database.Relational.Query.Component (
+  -- * Type for column SQL string
+  ColumnSQL, columnSQL, sqlWordFromColumn, stringFromColumnSQL,
+
+  -- * Configuration type for query
+  Config, defaultConfig,
+  UnitProductSupport (..),
+
+  -- * Query restriction
+  QueryRestriction, composeWhere, composeHaving,
+
+  -- * Types for aggregation
+  AggregateColumnRef,
+
+  AggregateBitKey, AggregateSet, AggregateElem,
+
+  aggregateColumnRef, aggregateEmpty,
+  aggregatePowerKey, aggregateGroupingSet,
+  aggregateRollup, aggregateCube, aggregateSets,
+
+  composeGroupBy,
+
+  -- * Types for ordering
+  Order (..), OrderColumn, OrderingTerm, OrderingTerms,
+
+  -- * Types for assignments
+  AssignColumn, AssignTerm, Assignment, Assignments, composeSets
+  ) where
+
+import qualified Database.Relational.Query.Context as Context
+import Database.Relational.Query.Expr (Expr)
+import Database.Relational.Query.Expr.Unsafe (showExpr)
+
+import Database.Relational.Query.Internal.String
+  (showUnwordsSQL, showWordSQL', showSpace, showParen', showSepBy)
+import Language.SQL.Keyword (Keyword(..))
+
+import qualified Language.SQL.Keyword as SQL
+
+-- | Column SQL string type
+newtype ColumnSQL = ColumnSQL String
+
+-- | 'ColumnSQL' from string
+columnSQL :: String -> ColumnSQL
+columnSQL =  ColumnSQL
+
+-- | String from ColumnSQL
+stringFromColumnSQL :: ColumnSQL -> String
+stringFromColumnSQL (ColumnSQL s) = s
+
+-- | SQL word from 'ColumnSQL'
+sqlWordFromColumn :: ColumnSQL -> SQL.Keyword
+sqlWordFromColumn =  SQL.word . stringFromColumnSQL
+
+instance Show ColumnSQL where
+  show = stringFromColumnSQL
+
+
+-- | Configuration type.
+type Config = UnitProductSupport
+
+-- | Default configuration.
+defaultConfig :: Config
+defaultConfig =  UPSupported
+
+-- | Unit product is supported or not.
+data UnitProductSupport = UPSupported | UPNotSupported  deriving Show
+
+
+-- | Type for restriction of query.
+type QueryRestriction c = Maybe (Expr c Bool)
+
+-- | Compose SQL String from 'QueryRestriction'.
+composeRestrict :: Keyword -> QueryRestriction c -> ShowS
+composeRestrict k = maybe id (\e -> showSpace . showUnwordsSQL [k, SQL.word . showExpr $ e])
+
+-- | Compose WHERE clause from 'QueryRestriction'.
+composeWhere :: QueryRestriction Context.Flat -> ShowS
+composeWhere =  composeRestrict WHERE
+
+-- | Compose HAVING clause from 'QueryRestriction'.
+composeHaving :: QueryRestriction Context.Aggregated -> ShowS
+composeHaving =  composeRestrict HAVING
+
+
+-- | Type for group-by term
+type AggregateColumnRef = ColumnSQL
+
+-- | Type for group key.
+newtype AggregateBitKey = AggregateBitKey [AggregateColumnRef] deriving Show
+
+-- | Type for grouping set
+newtype AggregateSet = AggregateSet [AggregateElem] deriving Show
+
+-- | Type for group-by tree
+data AggregateElem = ColumnRef AggregateColumnRef
+                   | Rollup [AggregateBitKey]
+                   | Cube   [AggregateBitKey]
+                   | GroupingSets [AggregateSet]
+                   deriving Show
+
+-- | Single term aggregation element.
+aggregateColumnRef :: AggregateColumnRef -> AggregateElem
+aggregateColumnRef =  ColumnRef
+
+-- | Key of aggregation power set.
+aggregatePowerKey :: [AggregateColumnRef] -> AggregateBitKey
+aggregatePowerKey =  AggregateBitKey
+
+-- | Single grouping set.
+aggregateGroupingSet :: [AggregateElem] -> AggregateSet
+aggregateGroupingSet =  AggregateSet
+
+-- | Rollup aggregation element.
+aggregateRollup :: [AggregateBitKey] -> AggregateElem
+aggregateRollup =  Rollup
+
+-- | Cube aggregation element.
+aggregateCube :: [AggregateBitKey] -> AggregateElem
+aggregateCube =  Cube
+
+-- | Grouping sets aggregation.
+aggregateSets :: [AggregateSet] -> AggregateElem
+aggregateSets =  GroupingSets
+
+-- | Empty aggregation.
+aggregateEmpty :: [AggregateElem]
+aggregateEmpty =  []
+
+comma :: ShowS
+comma =  showString ", "
+
+showsAggregateColumnRef :: AggregateColumnRef -> ShowS
+showsAggregateColumnRef =  showString . stringFromColumnSQL
+
+parenSepByComma :: (a -> ShowS) -> [a] -> ShowS
+parenSepByComma shows' = showParen' . (`showSepBy` comma) . map shows'
+
+showsAggregateBitKey :: AggregateBitKey -> ShowS
+showsAggregateBitKey (AggregateBitKey ts) = parenSepByComma showsAggregateColumnRef ts
+
+-- | Compose GROUP BY clause from AggregateElem list.
+composeGroupBy :: [AggregateElem] -> ShowS
+composeGroupBy =  d where
+  d []       = id
+  d es@(_:_) = showSpace . showUnwordsSQL [GROUP, BY] . showSpace . rec es
+  keyList op ss = showWordSQL' op . parenSepByComma showsAggregateBitKey ss
+  rec = (`showSepBy` comma) . map showsE
+  showsGs (AggregateSet s) = showParen' $ rec s
+  showsE (ColumnRef t)     = showsAggregateColumnRef t
+  showsE (Rollup ss)       = keyList ROLLUP ss
+  showsE (Cube   ss)       = keyList CUBE   ss
+  showsE (GroupingSets ss) = showUnwordsSQL [GROUPING, SETS] . showSpace
+                             . parenSepByComma showsGs ss
+
+
+-- | Order direction. Ascendant or Descendant.
+data Order = Asc | Desc  deriving Show
+
+-- | Type for order-by column
+type OrderColumn = ColumnSQL
+
+-- | Type for order-by term
+type OrderingTerm = (Order, OrderColumn)
+
+-- | Type for order-by terms
+type OrderingTerms = [OrderingTerm]
+
+
+-- | Column SQL String
+type AssignColumn = ColumnSQL
+
+-- | Value SQL String
+type AssignTerm   = ColumnSQL
+
+-- | Assignment pair
+type Assignment = (AssignColumn, AssignTerm)
+
+-- | Assignment pair list.
+type Assignments = [Assignment]
+
+-- | Compose SET clause from 'Assignments'.
+composeSets :: Assignments -> ShowS
+composeSets as = assigns  where
+  assignList = foldr (\ (col, term) r ->
+                       [sqlWordFromColumn col, sqlWordFromColumn term] `SQL.sepBy` " = "  : r)
+               [] as
+  assigns | null assignList = error "Update assignment list is null!"
+          | otherwise       = showSpace . showUnwordsSQL [SET, assignList `SQL.sepBy` ", "]

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

@@ -0,0 +1,114 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- |
+-- Module      : Database.Relational.Query.Constraint
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module provides proof object definitions of constraint key.
+-- Difference between this module and "Database.Record.KeyConstraint" is
+-- typed constraint key column definition is included in this module.
+module Database.Relational.Query.Constraint (
+  -- * Constraint Key proof object
+  Key, indexes, unsafeDefineConstraintKey,
+  tableConstraint, projectionKey,
+
+  -- unsafeReturnKey, -- unsafeAppendConstraint,
+
+  -- * Derivation rules
+  uniqueKey, -- notNullKey,
+
+  -- * Inference rules
+  HasConstraintKey (..),
+  derivedUniqueKey, -- derivedNotNullKey,
+
+  -- * Constraint types
+  Primary, Unique, NotNull
+  ) where
+
+
+import Database.Relational.Query.Pi (Pi)
+import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi
+import Database.Record.KeyConstraint
+  (KeyConstraint, unsafeSpecifyKeyConstraint,
+   Primary, Unique, NotNull)
+
+import qualified Database.Record.KeyConstraint as C
+import Database.Record (PersistableRecordWidth, PersistableWidth (persistableWidth))
+
+
+-- | Constraint Key proof object. Constraint type 'c', record type 'r' and columns type 'ct'.
+data Key c r ct = Key [Int] (PersistableRecordWidth ct)
+
+-- | Index of key which specifies constraint key.
+indexes :: Key c r ct -> [Int]
+indexes (Key is _) = is
+
+-- | Width of key.
+width :: Key c r ct -> PersistableRecordWidth ct
+width (Key _ w) = w
+
+-- | Unsafely generate constraint 'Key' proof object using specified key index.
+unsafeDefineConstraintKey :: PersistableWidth ct
+                          => [Int]      -- ^ Key indexes which specify this constraint key
+                          -> Key c r ct -- ^ Result constraint key proof object
+unsafeDefineConstraintKey ixs = Key ixs persistableWidth
+
+-- | Get table constraint 'KeyConstraint' proof object from constraint 'Key'.
+tableConstraint :: Key c r ct -> KeyConstraint c r
+tableConstraint =  unsafeSpecifyKeyConstraint . indexes
+
+-- | Get projection path proof object from constraint 'Key'.
+projectionKey :: Key c r ct -> Pi r ct
+projectionKey k =  UnsafePi.defineDirectPi' w ixs  where
+  ixs = indexes k
+  w   = width k
+
+-- | Unsafe. Make constraint key to add column phantom type
+unsafeReturnKey :: PersistableWidth ct
+                => KeyConstraint c r -> Key c r ct
+unsafeReturnKey =  unsafeDefineConstraintKey . C.indexes
+
+-- -- | Unsafe. Make constraint key to add constraint phantom type
+-- unsafeAppendConstraint :: Pi r ct -> Key c r ct
+-- unsafeAppendConstraint =  unsafeDefineConstraintKey . leafIndex
+
+
+-- | Map from table constraint into constraint 'Key'.
+mapConstraint :: PersistableWidth ct
+              => (KeyConstraint c0 r -> KeyConstraint c1 r)
+              -> Key c0 r ct
+              -> Key c1 r ct
+mapConstraint f = unsafeReturnKey . f . tableConstraint
+
+-- | Derive 'Unique' constraint 'Key' from 'Primary' constraint 'Key'
+uniqueKey :: PersistableWidth ct
+          => Key Primary r ct -> Key Unique r ct
+uniqueKey  = mapConstraint C.unique
+
+-- -- | Derive 'NotNull' constraint 'Key' from 'Primary' constraint 'Key'
+-- notNullKey :: Key Primary r ct -> Key NotNull r ct
+-- notNullKey =  mapConstraint C.notNull
+
+
+-- | Constraint 'Key' inference interface.
+class PersistableWidth ct => HasConstraintKey c r ct  where
+  -- | Infer constraint key.
+  constraintKey :: Key c r ct
+
+-- | Infered 'Unique' constraint 'Key'.
+--   Record type 'r' has unique key which type is 'ct' derived from primay key.
+derivedUniqueKey :: (HasConstraintKey Primary r ct) => Key Unique r ct
+derivedUniqueKey =  uniqueKey constraintKey
+
+-- -- | Infered 'NotNull' constraint 'Key'.
+-- --   Record type 'r' has not-null key which type is 'ct' derived from primay key.
+-- derivedNotNullKey :: HasConstraintKey Primary r ct => Key NotNull r ct
+-- derivedNotNullKey =  notNullKey constraintKey

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

@@ -0,0 +1,39 @@
+{-# LANGUAGE EmptyDataDecls #-}
+
+-- |
+-- Module      : Database.Relational.Query.Context
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines query context tag types.
+module Database.Relational.Query.Context (
+  Flat, Aggregated, Exists,
+
+  Set, SetList, Power, Partition,
+  ) where
+
+-- | Type tag for flat (not-aggregated) query
+data Flat
+
+-- | Type tag for aggregated query
+data Aggregated
+
+-- | Type tag for exists predicate
+data Exists
+
+
+-- | Type tag for normal aggregatings set
+data Set
+
+-- | Type tag for aggregatings GROUPING SETS
+data SetList
+
+-- | Type tag for aggregatings power set
+data Power
+
+-- | Type tag for window
+data Partition

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

@@ -0,0 +1,142 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+-- |
+-- Module      : Database.Relational.Query.Derives
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines typed SQLs derived from type informations.
+module Database.Relational.Query.Derives (
+  -- * Query derivation
+  specifiedKey,
+
+  unique,
+
+  primary', primary,
+
+  -- * Update derivation
+  updateBySpecifiedKey,
+  updateByConstraintKey,
+  primaryUpdate,
+
+  updateValuesWithKey,
+
+  -- * Derived objects from table
+  TableDerivation (..),
+  specifyTableDerivation', specifyTableDerivation,
+
+  TableDerivable (..),
+  derivedTable, derivedRelation, derivedInsert
+  ) where
+
+import Database.Record (PersistableWidth, ToSql (recordToSql))
+import Database.Record.ToSql (unsafeUpdateValuesWithIndexes)
+import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.Pi.Unsafe (Pi, unsafeExpandIndexes)
+import Database.Relational.Query.Projectable (placeholder, (.=.))
+import Database.Relational.Query.ProjectableExtended ((!))
+import Database.Relational.Query.Monad.Class (wheres)
+import Database.Relational.Query.Relation (Relation, relation', query, table)
+import Database.Relational.Query.Constraint
+   (Key, Primary, Unique, projectionKey, uniqueKey,
+    HasConstraintKey(constraintKey))
+import qualified Database.Relational.Query.Constraint as Constraint
+import Database.Relational.Query.Type (KeyUpdate, typedKeyUpdate, Insert, typedInsert)
+
+
+-- | Query restricted with specified key.
+specifiedKey :: PersistableWidth p
+      => Pi a p        -- ^ Unique key proof object which record type is 'a' and key type is 'p'.
+      -> Relation () a -- ^ 'Relation' to add restriction.
+      -> Relation p a  -- ^ Result restricted 'Relation'
+specifiedKey key rel = relation' $ do
+  q <- query rel
+  (param, ()) <- placeholder (\ph -> wheres $ q ! key .=. ph)
+  return (param, q)
+
+-- | Query restricted with specified unique key.
+unique :: PersistableWidth p
+       => Key Unique a p -- ^ Unique key proof object which record type is 'a' and key type is 'p'.
+       -> Relation () a  -- ^ 'Relation' to add restriction.
+       -> Relation p a   -- ^ Result restricted 'Relation'
+unique =  specifiedKey . projectionKey
+
+-- | Query restricted with specified primary key.
+primary' :: PersistableWidth p
+         => Key Primary a p -- ^ Primary key proof object which record type is 'a' and key type is 'p'.
+         -> Relation () a   -- ^ 'Relation' to add restriction.
+         -> Relation p a    -- ^ Result restricted 'Relation'
+primary' =  specifiedKey . projectionKey
+
+-- | Query restricted with infered primary key.
+primary :: HasConstraintKey Primary a p
+        => Relation () a -- ^ 'Relation' to add restriction.
+        -> Relation p a  -- ^ Result restricted 'Relation'
+primary =  primary' constraintKey
+
+
+-- | Convert from Haskell type `r` into SQL value `q` list expected by update form like
+--
+-- /UPDATE <table> SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... /
+--
+--   using derived 'RecordToSql' proof object.
+updateValuesWithKey :: ToSql q r
+                    => Pi r p
+                    -> r
+                    -> [q]
+updateValuesWithKey =  unsafeUpdateValuesWithIndexes recordToSql . unsafeExpandIndexes
+
+-- | Typed 'KeyUpdate' using specified key.
+updateBySpecifiedKey :: Table r       -- ^ 'Table' to update
+                     -> Pi r p        -- ^ Key with record type 'r' and columns type 'p'
+                     -> KeyUpdate p r -- ^ Result typed 'Update'
+updateBySpecifiedKey table' = typedKeyUpdate table'
+
+-- | Typed 'KeyUpdate' using specified constraint key.
+updateByConstraintKey :: Table r       -- ^ 'Table' to update
+                      -> Key c r p     -- ^ Key with constraint 'c', record type 'r' and columns type 'p'
+                      -> KeyUpdate p r -- ^ Result typed 'Update'
+updateByConstraintKey table' = updateBySpecifiedKey table' . Constraint.projectionKey
+
+-- | Typed 'KeyUpdate' using infered primary key.
+primaryUpdate :: (HasConstraintKey Primary r p)
+              => Table r       -- ^ 'Table' to update
+              -> KeyUpdate p r -- ^ Result typed 'Update'
+primaryUpdate table' = updateByConstraintKey table' (uniqueKey constraintKey)
+
+
+-- | Capabilities derived from table.
+data TableDerivation r =
+  TableDerivation
+  { derivedTable'    :: Table r
+  , derivedRelation' :: Relation () r
+  , derivedInsert'   :: Insert r
+  }
+
+-- | Specify properties derived from table.
+specifyTableDerivation' :: Table r -> Relation () r -> Insert r -> TableDerivation r
+specifyTableDerivation' =  TableDerivation
+
+-- | Specify properties derived from table.
+specifyTableDerivation :: Table r -> TableDerivation r
+specifyTableDerivation t = specifyTableDerivation' t (table t) (typedInsert t)
+
+-- | Inference rule for 'TableDerivation'.
+class TableDerivable r where
+  tableDerivation :: TableDerivation r
+
+-- | Infered 'Table'.
+derivedTable :: TableDerivable r => Table r
+derivedTable =  derivedTable' tableDerivation
+
+-- | Infered 'Relation'.
+derivedRelation :: TableDerivable r => Relation () r
+derivedRelation =  derivedRelation' tableDerivation
+
+-- | Infered 'Insert'.
+derivedInsert :: TableDerivable r => Insert r
+derivedInsert =  derivedInsert' tableDerivation

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

@@ -0,0 +1,124 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+-- |
+-- Module      : Database.Relational.Query.Expr
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines phantom typed SQL expression object.
+-- Contains normal interfaces.
+module Database.Relational.Query.Expr (
+  -- * Typed SQL Expression
+  Expr,
+
+  -- * Constant SQL Expression
+  ShowConstantSQL (showConstantSQL),
+
+  valueExpr,
+
+  -- * Type conversion
+  just, fromJust,
+
+  exprAnd
+  ) where
+
+import Prelude hiding (and, or)
+import Data.Int (Int16, Int32, Int64)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Database.Relational.Query.Expr.Unsafe (Expr(Expr), showExpr)
+
+import Database.Relational.Query.Internal.String (paren)
+import qualified Language.SQL.Keyword as SQL
+import qualified Language.SQL.Keyword.ConcatString as SQLs
+
+
+-- | Constant integral SQL expression.
+intExprSQL :: (Show a, Integral a) => a -> String
+intExprSQL =  show
+
+-- | Escape 'String' for constant SQL string expression.
+escapeStringToSqlExpr :: String -> String
+escapeStringToSqlExpr =  rec  where
+  rec ""        = ""
+  rec ('\'':cs) = '\'' : '\'' : rec cs
+  rec (c:cs)    = c : rec cs
+
+-- | From 'String' into constant SQL string expression.
+stringExprSQL :: String -> String
+stringExprSQL =  ('\'':) . (++ "'") . escapeStringToSqlExpr
+
+-- | Interface for constant SQL expression.
+class ShowConstantSQL a where
+  -- | Make constant SQL expression 'String' from Haskell type 'a'.
+  showConstantSQL :: a -> String
+
+-- | Constant SQL expression of 'Int16'.
+instance ShowConstantSQL Int16 where
+  showConstantSQL = intExprSQL
+
+-- | Constant SQL expression of 'Int32'.
+instance ShowConstantSQL Int32 where
+  showConstantSQL = intExprSQL
+
+-- | Constant SQL expression of 'Int64'.
+instance ShowConstantSQL Int64 where
+  showConstantSQL = intExprSQL
+
+-- | Constant SQL expression of 'String'.
+instance ShowConstantSQL String where
+  showConstantSQL = stringExprSQL
+
+-- | Constant SQL expression of 'ByteString'.
+instance ShowConstantSQL ByteString where
+  showConstantSQL = stringExprSQL . BS.unpack
+
+-- | Constant SQL expression of 'Text'.
+instance ShowConstantSQL Text where
+  showConstantSQL = stringExprSQL . T.unpack
+
+-- | Constant SQL expression of 'Char'.
+instance ShowConstantSQL Char where
+  showConstantSQL = stringExprSQL . (:"")
+
+-- | Constant SQL expression of 'Bool'.
+instance ShowConstantSQL Bool where
+  showConstantSQL = d  where
+    d True  = "(0=0)"
+    d False = "(0=1)"
+
+-- | Inference rule for Constant SQL expression of 'Maybe' type.
+instance ShowConstantSQL a => ShowConstantSQL (Maybe a) where
+  showConstantSQL = d  where
+    d (Just a)  = showConstantSQL a
+    d (Nothing) = "NULL"
+
+
+-- | Typed constant SQL expression from Haskell value.
+valueExpr :: ShowConstantSQL ft => ft -> Expr p ft
+valueExpr =  Expr . showConstantSQL
+
+-- | Unsafely cast phantom type.
+unsafeCastExpr :: Expr p a -> Expr p b
+unsafeCastExpr =  Expr . showExpr
+
+-- | Convert phantom type into 'Maybe'.
+just :: Expr p ft -> Expr p (Maybe ft)
+just =  unsafeCastExpr
+
+-- | Allowed only for having or where 'Expr'.
+--   So NULL expression result will be possible.
+--   Behavior around boolean is strongly dependent on RDBMS impelemetations.
+fromJust :: Expr p (Maybe ft) -> Expr p ft
+fromJust =  unsafeCastExpr
+
+-- | AND operator for 'Expr'.
+exprAnd :: Expr p Bool -> Expr p Bool -> Expr p Bool
+exprAnd a b = Expr . paren $ SQLs.defineBinOp SQL.AND (showExpr a) (showExpr b)

relational-query/src/Database/Relational/Query/Expr/Unsafe.hs

@@ -0,0 +1,26 @@
+-- |
+-- Module      : Database.Relational.Query.Expr.Unsafe
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines phantom typed SQL expression object.
+-- Contains internal structure and unsafe interfaces.
+module Database.Relational.Query.Expr.Unsafe (
+  -- * Typed SQL Expression
+  Expr(Expr), showExpr
+  ) where
+
+-- | Phantom typed SQL expression object. Project from projection type 'p'.
+newtype Expr p a = Expr String
+
+-- | Get SQL expression from typed object.
+showExpr :: Expr p t -> String
+showExpr (Expr s) = s
+
+-- | Show expression.
+instance Show (Expr p a) where
+  show = showExpr

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

@@ -0,0 +1,33 @@
+-- |
+-- Module      : Database.Relational.Query.Internal.AliasId
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines qualifier for SQL table form.
+-- Contains internal structure and unsafe interfaces.
+module Database.Relational.Query.Internal.AliasId (
+  -- * Alias identifier definition
+  AliasId (AliasId), primeAlias, newAliasId,
+
+  unsafeExtractAliasId,
+  ) where
+
+-- | Alias id definition
+newtype AliasId = AliasId Int deriving (Show, Eq)
+
+
+-- | Unsafely get 'AliasId' internal 'Int' value.
+unsafeExtractAliasId :: AliasId -> Int
+unsafeExtractAliasId (AliasId i) = i
+
+-- | Initial value of 'AliasId'
+primeAlias :: AliasId
+primeAlias =  AliasId 0
+
+-- | New unique 'AliasId'.
+newAliasId :: AliasId -> AliasId
+newAliasId (AliasId i) = AliasId $ i + 1

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

@@ -0,0 +1,104 @@
+-- |
+-- Module      : Database.Relational.Query.Internal.Product
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines product structure to compose SQL join.
+module Database.Relational.Query.Internal.Product (
+  -- * Product tree type
+  NodeAttr (..), ProductTree (..),
+  Node, node, nodeAttr, nodeTree,
+  growRight, -- growLeft,
+  growProduct, product, restrictProduct,
+  ) where
+
+import Prelude hiding (and, product)
+import Database.Relational.Query.Context (Flat)
+import Database.Relational.Query.Expr (exprAnd)
+import qualified Database.Relational.Query.Expr as Expr
+import Data.Monoid ((<>))
+import Data.Foldable (Foldable (foldMap))
+
+
+type Expr = Expr.Expr Flat
+
+-- | node attribute for product.
+data NodeAttr = Just' | Maybe deriving Show
+
+-- | Product tree type. Product tree is constructed by left node and right node.
+data ProductTree q = Leaf q
+                   | Join !(Node q) !(Node q) !(Maybe (Expr Bool))
+                   deriving Show
+
+-- | Product node. node attribute and product tree.
+data Node q = Node !NodeAttr !(ProductTree q)  deriving Show
+
+-- | Get node attribute.
+nodeAttr :: Node q -> NodeAttr
+nodeAttr (Node a _) = a  where
+
+-- | Get tree from node.
+nodeTree :: Node q -> ProductTree q
+nodeTree (Node _ t) = t
+
+-- | Foldable instance of ProductTree
+instance Foldable ProductTree where
+  foldMap f pq = rec pq where
+    rec (Leaf q) = f q
+    rec (Join (Node _ lp) (Node _ rp) _ ) = rec lp <> rec rp
+
+-- | Make product node from node attribute and product tree.
+node :: NodeAttr      -- ^ Node attribute
+     -> ProductTree q -- ^ Product tree
+     -> Node q        -- ^ Result node
+node =  Node
+
+-- | Push new tree into product right term.
+growRight :: Maybe (Node q)            -- ^ Current tree
+          -> (NodeAttr, ProductTree q) -- ^ New tree to push into right
+          -> Node q                    -- ^ Result node
+growRight = d  where
+  d Nothing  (naR, q) = node naR q
+  d (Just l) (naR, q) = node Just' $ Join l (node naR q) Nothing
+
+-- -- | Push new tree node into product left term.
+-- growLeft :: Node q         -- ^ New node to push into left
+--          -> NodeAttr       -- ^ Node attribute to replace rigth node attribute.
+--          -> Maybe (Node q) -- ^ Current tree
+--          -> Node q         -- ^ Result node
+-- growLeft =  d  where
+--   d q _naR Nothing  = q -- error is better?
+--   d q naR  (Just r) = node Just' $ Join q (node naR (nodeTree r)) Nothing
+
+-- | Push new leaf node into product right term.
+growProduct :: Maybe (Node q) -- ^ Current tree
+            -> (NodeAttr, q)  -- ^ New leaf to push into right
+            -> Node q         -- ^ Result node
+growProduct =  match  where
+  match t (na, q) =  growRight t (na, Leaf q)
+
+-- | Just make product of two node.
+product :: Node q            -- ^ Left node
+        -> Node q            -- ^ Right node
+        -> Maybe (Expr Bool) -- ^ Join restriction
+        -> ProductTree q     -- ^ Result tree
+product =  Join
+
+-- | Add restriction into top product of product tree.
+restrictProduct' :: ProductTree q -- ^ Product to restrict
+                 -> Expr Bool     -- ^ Restriction to add
+                 -> ProductTree q -- ^ Result product
+restrictProduct' =  d  where
+  d (Join lp rp Nothing)   rs' = Join lp rp (Just rs')
+  d (Join lp rp (Just rs)) rs' = Join lp rp (Just $ rs `exprAnd` rs')
+  d leaf'@(Leaf _)         _   = leaf' -- or error on compile
+
+-- | Add restriction into top product of product tree node.
+restrictProduct :: Node q    -- ^ Target node which has product to restrict
+                -> Expr Bool -- ^ Restriction to add
+                -> Node q    -- ^ Result node
+restrictProduct (Node a t) e = node a (restrictProduct' t e)

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

@@ -0,0 +1,68 @@
+-- |
+-- Module      : Database.Relational.Query.Internal.String
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module provides SQL string concatination functions
+-- which result is ShowS differential lists.
+module Database.Relational.Query.Internal.String (
+  showUnwordsSQL, showWordSQL, showWordSQL',
+  showConcat, showSepBy, showUnwords, showSpace, showParen',
+
+  paren, sqlRowString, sqlRowListString
+  ) where
+
+import Data.List (intersperse, intercalate)
+
+import qualified Language.SQL.Keyword as SQL
+
+-- | Unwords 'SQL.Keyword' list and resturns 'ShowS'.
+showUnwordsSQL :: [SQL.Keyword] -> ShowS
+showUnwordsSQL =  showUnwords . map showWordSQL
+
+-- | From 'SQL.Keyword' into 'ShowS'.
+showWordSQL :: SQL.Keyword -> ShowS
+showWordSQL =  showString . SQL.wordShow
+
+-- | 'ShowS' of whitespace.
+showSpace :: ShowS
+showSpace =  showChar ' '
+
+-- | Paren 'ShowS'.
+showParen' :: ShowS -> ShowS
+showParen' =  showParen True
+
+-- | From 'SQL.Keyword' with white into 'ShowS'.
+showWordSQL' :: SQL.Keyword -> ShowS
+showWordSQL' kw = showWordSQL kw . showSpace
+
+-- | 'ShowS' version of concat function.
+showConcat :: [ShowS] -> ShowS
+showConcat =  foldr (.) id
+
+-- | Separated 'ShowS' with delimitor.
+showSepBy :: [ShowS] -> ShowS -> ShowS
+showSepBy ts d = showConcat $ intersperse d ts
+
+-- | 'ShowS' version of unwords function.
+showUnwords :: [ShowS] -> ShowS
+showUnwords =  (`showSepBy` showSpace)
+
+-- | Parened String.
+paren :: String -> String
+paren =  ('(' :) . (++[')'])
+
+-- | Row String of SQL values.
+sqlRowString :: [String] -> String
+sqlRowString = d where
+  d ([])  = error $ "Projection: no columns."
+  d ([c]) = c
+  d (cs) =  paren $ intercalate ", " cs
+
+-- | Rows String of SQL.
+sqlRowListString :: [String] -> String
+sqlRowListString =  paren . intercalate ", "

relational-query/src/Database/Relational/Query/Monad/Aggregate.hs

@@ -0,0 +1,84 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Aggregate
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module contains definitions about aggregated query type.
+module Database.Relational.Query.Monad.Aggregate (
+  -- * Aggregated Query
+  QueryAggregate,
+  AggregatedQuery,
+
+  toSQL,
+
+  toSubQuery
+  ) where
+
+import Database.Relational.Query.Context (Flat, Aggregated)
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+import Database.Relational.Query.Component
+  (QueryRestriction, OrderingTerms, AggregateElem)
+import Database.Relational.Query.Sub (SubQuery, aggregatedSubQuery, JoinProduct)
+import qualified Database.Relational.Query.Sub as SubQuery
+
+import Database.Relational.Query.Monad.Class (MonadRestrict(..), MonadQualify(..))
+import Database.Relational.Query.Monad.Trans.Config (askConfig)
+import Database.Relational.Query.Monad.Trans.Join (join')
+import Database.Relational.Query.Monad.Trans.Restricting
+  (Restrictings, restrictings, extractRestrict)
+import Database.Relational.Query.Monad.Trans.Aggregating
+  (aggregatings, extractAggregateTerms, AggregatingSetT)
+import Database.Relational.Query.Monad.Trans.Ordering
+  (Orderings, orderings, OrderedQuery, extractOrderingTerms)
+import Database.Relational.Query.Monad.Type (ConfigureQuery, QueryCore, extractCore)
+
+
+-- | Aggregated query monad type.
+type QueryAggregate     = Orderings Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore))
+
+-- | Aggregated query type. AggregatedQuery r == QueryAggregate (Projection Aggregated r).
+type AggregatedQuery  r = OrderedQuery Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) r
+
+-- | Lift from qualified table forms into 'QueryAggregate'.
+aggregatedQuery :: ConfigureQuery a -> QueryAggregate a
+aggregatedQuery =  orderings . restrictings . aggregatings . restrictings . join'
+
+-- | Restricted 'MonadRestrict' instance.
+instance MonadRestrict Flat q => MonadRestrict Flat (Restrictings Aggregated q) where
+  restrictContext = restrictings . restrictContext
+
+-- | Instance to lift from qualified table forms into 'QueryAggregate'.
+instance MonadQualify ConfigureQuery QueryAggregate where
+  liftQualify = aggregatedQuery
+
+extract :: AggregatedQuery r
+        -> ConfigureQuery (((((Projection Aggregated r, OrderingTerms),
+                                 QueryRestriction Aggregated),
+                                [AggregateElem]),
+                               QueryRestriction Flat),
+                              JoinProduct)
+extract =  extractCore . extractAggregateTerms . extractRestrict . extractOrderingTerms
+
+-- | Run 'AggregatedQuery' to get SQL with 'ConfigureQuery' computation.
+toSQL :: AggregatedQuery r     -- ^ 'AggregatedQuery' to run
+      -> ConfigureQuery String -- ^ Result SQL string with 'ConfigureQuery' computation
+toSQL =  fmap SubQuery.toSQL . toSubQuery
+
+-- | Run 'AggregatedQuery' to get 'SubQuery' with 'ConfigureQuery' computation.
+toSubQuery :: AggregatedQuery r       -- ^ 'AggregatedQuery' to run
+           -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'ConfigureQuery' computation
+toSubQuery q = do
+  (((((pj, ot), grs), ag), rs), pd) <- extract q
+  c <- askConfig
+  return $ aggregatedSubQuery c (Projection.untype pj) pd rs ag grs ot

relational-query/src/Database/Relational/Query/Monad/Class.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Class
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines query building interface classes.
+module Database.Relational.Query.Monad.Class (
+  -- * Query interface classes
+  MonadQualify (..), MonadRestrict (..),
+  MonadQuery (..), MonadAggregate (..),
+
+  onE, on, wheresE, wheres,
+  groupBy,
+  havingE, having
+  ) where
+
+import Database.Relational.Query.Context (Flat, Aggregated)
+import Database.Relational.Query.Expr (Expr)
+import Database.Relational.Query.Component (AggregateElem, aggregateColumnRef)
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+import Database.Relational.Query.Projectable (expr)
+import Database.Relational.Query.Sub (SubQuery, Qualified)
+
+import Database.Relational.Query.Internal.Product (NodeAttr)
+
+-- | Restrict context interface
+class (Functor m, Monad m) => MonadRestrict c m where
+  -- | Add restriction to this context.
+  restrictContext :: Expr c (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction
+                  -> m ()                         -- ^ Restricted query context
+
+-- | Query building interface.
+class (Functor m, Monad m) => MonadQuery m where
+  -- | Add restriction to last join.
+  restrictJoin :: Expr Flat (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction
+               -> m ()                   -- ^ Restricted query context
+  -- -- | Add restriction to this query.
+  -- restrictQuery :: Expr Projection (Maybe Bool) -- ^ 'Expr' 'Projection' which represent restriction
+  --               -> m ()                         -- ^ Restricted query context
+  -- | Unsafely join subquery with this query.
+  unsafeSubQuery :: NodeAttr              -- ^ Attribute maybe or just
+                 -> Qualified SubQuery    -- ^ 'SubQuery' to join
+                 -> m (Projection Flat r) -- ^ Result joined context and 'SubQuery' result projection.
+  -- unsafeMergeAnotherQuery :: NodeAttr -> m (Projection r) -> m (Projection r)
+
+-- | Lift interface from base qualify monad.
+class (Functor q, Monad q, MonadQuery m) => MonadQualify q m where
+  -- | Lift from qualify monad 'q' into 'MonadQuery' m.
+  --   Qualify monad qualifies table form 'SubQuery'.
+  liftQualify :: q a -> m a
+
+-- | Aggregated query building interface extends 'MonadQuery'.
+class MonadQuery m => MonadAggregate m where
+  -- | Add /group by/ term into context and get aggregated projection.
+  unsafeAddAggregateElement :: AggregateElem -- ^ Grouping element to add into group by clause
+                            -> m ()          -- ^ Result context
+
+-- | Add restriction to last join.
+onE :: MonadQuery m => Expr Flat (Maybe Bool) -> m ()
+onE =  restrictJoin
+
+-- | Add restriction to last join. Projection type version.
+on :: MonadQuery m => Projection Flat (Maybe Bool) -> m ()
+on =  restrictJoin . expr
+
+-- | Add restriction to this query.
+wheresE :: MonadRestrict Flat m => Expr Flat (Maybe Bool) -> m ()
+wheresE =  restrictContext
+
+-- | Add restriction to this query. Projection type version.
+wheres :: MonadRestrict Flat m => Projection Flat (Maybe Bool) -> m ()
+wheres =  restrictContext . expr
+
+-- | Add /GROUP BY/ term into context and get aggregated projection.
+groupBy :: MonadAggregate m
+        => Projection Flat r           -- ^ Projection to add into group by
+        -> m (Projection Aggregated r) -- ^ Result context and aggregated projection
+groupBy p = do
+  mapM_ unsafeAddAggregateElement [ aggregateColumnRef col | col <- Projection.columns p]
+  return $ Projection.unsafeToAggregated p
+
+-- | Add restriction to this aggregated query.
+havingE :: MonadRestrict Aggregated m => Expr Aggregated (Maybe Bool) -> m ()
+havingE =  restrictContext
+
+-- | Add restriction to this aggregated query. Aggregated Projection type version.
+having :: MonadRestrict Aggregated m => Projection Aggregated (Maybe Bool) -> m ()
+having =  restrictContext . expr

relational-query/src/Database/Relational/Query/Monad/Qualify.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Qualify
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines monad structure to qualify uniquely SQL table forms.
+module Database.Relational.Query.Monad.Qualify (
+  -- * Qualify monad
+  Qualify,
+  evalQualifyPrime, qualifyQuery
+  ) where
+
+import Control.Monad.Trans.State (State, state, runState)
+import Control.Applicative (Applicative)
+
+import Database.Relational.Query.Internal.AliasId (primeAlias, AliasId, newAliasId)
+import qualified Database.Relational.Query.Internal.AliasId as AliasId
+import Database.Relational.Query.Sub (Qualified)
+import qualified Database.Relational.Query.Sub as SubQuery
+
+
+-- | Type for 'Qualify' monad state.
+newtype AliasIdContext = AliasIdContext { currentAliasId :: AliasId }
+
+-- | Initial state.
+primeAliasIdContext :: AliasIdContext
+primeAliasIdContext =  AliasIdContext primeAlias
+
+-- | Update state function.
+nextAlias :: AliasIdContext -> (AliasId, AliasIdContext)
+nextAlias s = (cur, s { currentAliasId =  newAliasId cur })  where
+  cur = currentAliasId s
+
+
+-- | Monad type to qualify SQL table forms.
+newtype Qualify a =
+  Qualify { runQualify' :: State AliasIdContext a }
+  deriving (Monad, Functor, Applicative)
+
+-- | Run qualify monad.
+runQualify :: Qualify a -> AliasIdContext -> (a, AliasIdContext)
+runQualify =  runState . runQualify'
+
+-- | Run qualify monad with initial state.
+runQualifyPrime :: Qualify a -> (a, AliasIdContext)
+runQualifyPrime q = runQualify q primeAliasIdContext
+
+-- | Run qualify monad with initial state to get only result.
+evalQualifyPrime :: Qualify a -> a
+evalQualifyPrime =  fst . runQualifyPrime
+
+-- | Make qualify monad from update state function.
+qualifyState :: (AliasIdContext -> (a, AliasIdContext)) -> Qualify a
+qualifyState =  Qualify . state
+
+-- | Generated new qualifier on internal state.
+newAlias :: Qualify AliasId
+newAlias =  qualifyState nextAlias
+
+unsafeQualifierFromAliasId :: AliasId -> SubQuery.Qualifier
+unsafeQualifierFromAliasId =  SubQuery.Qualifier . AliasId.unsafeExtractAliasId
+
+-- | Get qualifyed table form query.
+qualifyQuery :: query                     -- ^ Query to qualify
+             -> Qualify (Qualified query) -- ^ Result with updated state
+qualifyQuery query =
+  do n <- newAlias
+     return . SubQuery.qualify query $ unsafeQualifierFromAliasId n

relational-query/src/Database/Relational/Query/Monad/Restrict.hs

@@ -0,0 +1,41 @@
+-- |
+-- Module      : Database.Relational.Query.Monad.Restrict
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module contains definitions about simple restrict context monad type.
+module Database.Relational.Query.Monad.Restrict (
+  -- * Monad to restrict target records.
+  Restrict, RestrictedStatement,
+
+  -- restricted,
+  extract
+  ) where
+
+import Data.Functor.Identity (Identity (..), runIdentity)
+
+import Database.Relational.Query.Component (QueryRestriction)
+import Database.Relational.Query.Context (Flat)
+import Database.Relational.Query.Projection (Projection)
+import Database.Relational.Query.Monad.Trans.Restricting (Restrictings, extractRestrict)
+
+
+-- | Restrict only monad type used from update statement and delete statement.
+type Restrict = Restrictings Flat Identity
+
+-- | RestrictedStatement type synonym.
+--   Projection record type 'r' must be
+--   the same as 'Restrictings' type parameter 'r'.
+type RestrictedStatement r a = Projection Flat r -> Restrict a
+
+-- -- | 'return' of 'Restrict'
+-- restricted :: a -> Restrict a
+-- restricted =  restrict . Identity
+
+-- | Run 'Restrict' to get 'QueryRestriction'.
+extract :: Restrict a -> (a, QueryRestriction Flat)
+extract =  runIdentity . extractRestrict

relational-query/src/Database/Relational/Query/Monad/Simple.hs

@@ -0,0 +1,71 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Simple
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module contains definitions about simple (not-aggregated) query type.
+module Database.Relational.Query.Monad.Simple (
+  -- * Simple query
+  QuerySimple, SimpleQuery,
+
+  simple,
+
+  toSQL,
+  toSubQuery
+  ) where
+
+import Database.Relational.Query.Context (Flat)
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+
+import Database.Relational.Query.Monad.Class (MonadQualify(..))
+import Database.Relational.Query.Monad.Trans.Config (askConfig)
+import Database.Relational.Query.Monad.Trans.Join (join')
+import Database.Relational.Query.Monad.Trans.Restricting (restrictings)
+import Database.Relational.Query.Monad.Trans.Ordering
+  (Orderings, orderings, OrderedQuery, extractOrderingTerms)
+import Database.Relational.Query.Monad.Type (ConfigureQuery, QueryCore, extractCore)
+
+import Database.Relational.Query.Component (QueryRestriction, OrderingTerms)
+import Database.Relational.Query.Sub (SubQuery, flatSubQuery, JoinProduct)
+import qualified Database.Relational.Query.Sub as SubQuery
+
+
+-- | Simple query (not-aggregated) monad type.
+type QuerySimple = Orderings Flat QueryCore
+
+-- | Simple query (not-aggregated) query type. 'SimpleQuery' r == 'QuerySimple' ('Projection' r).
+type SimpleQuery r = OrderedQuery Flat QueryCore r
+
+-- | Lift from qualified table forms into 'QuerySimple'.
+simple :: ConfigureQuery a -> QuerySimple a
+simple =  orderings . restrictings . join'
+
+-- | Instance to lift from qualified table forms into 'QuerySimple'.
+instance MonadQualify ConfigureQuery (Orderings Flat QueryCore) where
+  liftQualify = simple
+
+extract :: SimpleQuery r
+        -> ConfigureQuery (((Projection Flat r, OrderingTerms), QueryRestriction Flat), JoinProduct)
+extract =  extractCore . extractOrderingTerms
+
+-- | Run 'SimpleQuery' to get SQL string with 'Qualify' computation.
+toSQL :: SimpleQuery r         -- ^ 'SimpleQuery' to run
+      -> ConfigureQuery String -- ^ Result SQL string with 'Qualify' computation
+toSQL =  fmap SubQuery.toSQL . toSubQuery
+
+-- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation.
+toSubQuery :: SimpleQuery r           -- ^ 'SimpleQuery' to run
+           -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation
+toSubQuery q = do
+   (((pj, ot), rs), pd) <- extract q
+   c <- askConfig
+   return $ flatSubQuery c (Projection.untype pj) pd rs ot

relational-query/src/Database/Relational/Query/Monad/Target.hs

@@ -0,0 +1,40 @@
+-- |
+-- Module      : Database.Relational.Query.Monad.Target
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module contains definitions about restrict context with assignment monad type.
+module Database.Relational.Query.Monad.Target (
+  -- * Monad to restrict target records with assignment.
+  Target, TargetStatement,
+  -- updateStatement,
+  extract
+  ) where
+
+import Database.Relational.Query.Component (QueryRestriction, Assignments)
+import Database.Relational.Query.Context (Flat)
+import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.Projection (Projection)
+import Database.Relational.Query.Monad.Restrict (Restrict)
+import qualified Database.Relational.Query.Monad.Restrict as Restrict
+import Database.Relational.Query.Monad.Trans.Assigning (Assignings, extractAssignments)
+
+-- | Target update monad type used from update statement and merge statement.
+type Target r = Assignings r Restrict
+
+-- | TargetStatement type synonym.
+--   Table and projection record type must be
+--   the same as 'Target' type parameter 'r'.
+type TargetStatement r a = Table r -> Projection Flat r -> Target r a
+
+-- -- | 'return' of 'Update'
+-- updateStatement :: a -> Assignings r (Restrictings Identity) a
+-- updateStatement =  assignings . restrictings . Identity
+
+-- | Run 'Target'.
+extract :: Target r a -> ((a, Assignments), QueryRestriction Flat)
+extract =  Restrict.extract . extractAssignments

relational-query/src/Database/Relational/Query/Monad/Trans/Aggregating.hs

@@ -0,0 +1,175 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.Aggregating
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines monad transformer which lift
+-- from 'MonadQuery' into Aggregated query.
+module Database.Relational.Query.Monad.Trans.Aggregating (
+  -- * Transformer into aggregated query
+  Aggregatings, aggregatings,
+
+  AggregatingSetT, AggregatingSetListT, AggregatingPowerSetT,
+
+  -- * Result
+  extractAggregateTerms,
+
+  -- * Grouping sets support
+  AggregateKey,
+
+  groupBy',
+
+  AggregatingSet, AggregatingPowerSet,  AggregatingSetList,
+  key, key', set,
+  bkey, rollup, cube, groupingSets
+  ) where
+
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Control.Monad.Trans.State (StateT, runStateT, modify)
+import Control.Applicative (Applicative, (<$>))
+import Control.Arrow (second)
+
+import Data.Functor.Identity (Identity (runIdentity))
+
+import Database.Relational.Query.Context (Flat, Aggregated, Set, Power, SetList)
+import Database.Relational.Query.Component
+  (AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet, AggregateBitKey, aggregatePowerKey,
+  aggregateRollup, aggregateCube, aggregateSets)
+import Database.Relational.Query.Monad.Trans.ListState
+  (TermsContext, primeTermsContext, appendTerm, termsList)
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+
+import Database.Relational.Query.Monad.Class
+  (MonadRestrict(..), MonadQuery(..), MonadAggregate(..))
+
+
+-- | 'StateT' type to accumulate aggregating context.
+newtype Aggregatings ac at m a =
+  Aggregatings { aggregatingState :: StateT (TermsContext at) m a }
+  deriving (MonadTrans, Monad, Functor, Applicative)
+
+-- | Run 'Aggregatings' to expand context state.
+runAggregating :: Aggregatings ac at m a -- ^ Context to expand
+               -> TermsContext at        -- ^ Initial context
+               -> m (a, TermsContext at) -- ^ Expanded result
+runAggregating =  runStateT . aggregatingState
+
+-- | Run 'Aggregatings' with primary empty context to expand context state.
+runAggregatingPrime :: Aggregatings ac at m a          -- ^ Context to expand
+                    -> m (a, TermsContext at) -- ^ Expanded result
+runAggregatingPrime =  (`runAggregating` primeTermsContext)
+
+-- | Lift to 'Aggregatings'.
+aggregatings :: Monad m => m a -> Aggregatings ac at m a
+aggregatings =  lift
+
+-- | Context type building one grouping set.
+type AggregatingSetT      = Aggregatings Set     AggregateElem
+
+-- | Context type building grouping sets list.
+type AggregatingSetListT  = Aggregatings SetList AggregateSet
+
+-- | Context type building power group set.
+type AggregatingPowerSetT = Aggregatings Power   AggregateBitKey
+
+-- | Aggregated 'MonadRestrict'.
+instance MonadRestrict c m => MonadRestrict c (AggregatingSetT m) where
+  restrictContext =  aggregatings . restrictContext
+
+-- | Aggregated 'MonadQuery'.
+instance MonadQuery m => MonadQuery (AggregatingSetT m) where
+  restrictJoin  =  aggregatings . restrictJoin
+  unsafeSubQuery na = aggregatings . unsafeSubQuery na
+
+-- | Unsafely update aggregating context.
+updateAggregatingContext :: Monad m => (TermsContext at -> TermsContext at) -> Aggregatings ac at m ()
+updateAggregatingContext =  Aggregatings . modify
+
+unsafeAggregateWithTerm :: Monad m => at -> Aggregatings ac at m ()
+unsafeAggregateWithTerm =  updateAggregatingContext . appendTerm
+
+-- | Aggregated query instance.
+instance MonadQuery m => MonadAggregate (AggregatingSetT m) where
+  unsafeAddAggregateElement = unsafeAggregateWithTerm
+
+-- | Run 'Aggregatings' to get terms list.
+extractAggregateTerms :: (Monad m, Functor m) => Aggregatings ac at m a -> m (a, [at])
+extractAggregateTerms q = second termsList <$> runAggregatingPrime q
+
+
+-- | Typeful aggregate element.
+newtype AggregateKey a = AggregateKey (a, AggregateElem)
+
+-- | Add /GROUP BY/ element into context and get aggregated projection.
+groupBy' :: MonadAggregate m
+         => AggregateKey a
+         -> m a
+groupBy' (AggregateKey (p, c)) = do
+  unsafeAddAggregateElement c
+  return p
+
+extractTermList :: Aggregatings ac at Identity a -> (a, [at])
+extractTermList =  runIdentity . extractAggregateTerms
+
+-- | Context monad type to build single grouping set.
+type AggregatingSet      = AggregatingSetT      Identity
+
+-- | Context monad type to build grouping power set.
+type AggregatingPowerSet = AggregatingPowerSetT Identity
+
+-- | Context monad type to build grouping set list.
+type AggregatingSetList  = AggregatingSetListT  Identity
+
+-- | Specify key of single grouping set from Projection.
+key :: Projection Flat r
+    -> AggregatingSet (Projection Aggregated (Maybe r))
+key p = do
+  mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Projection.columns p]
+  return . Projection.just $ Projection.unsafeToAggregated p
+
+-- | Specify key of single grouping set.
+key' :: AggregateKey a
+     -> AggregatingSet a
+key' (AggregateKey (p, c)) = do
+  unsafeAggregateWithTerm c
+  return p
+
+-- | Finalize and specify single grouping set.
+set :: AggregatingSet a
+    -> AggregatingSetList a
+set s = do
+  let (p, c) = second aggregateGroupingSet . extractTermList $ s
+  unsafeAggregateWithTerm c
+  return p
+
+-- | Specify key of rollup and cube power set.
+bkey :: Projection Flat r
+     -> AggregatingPowerSet (Projection Aggregated (Maybe r))
+bkey p = do
+  unsafeAggregateWithTerm . aggregatePowerKey $ Projection.columns p
+  return . Projection.just $ Projection.unsafeToAggregated p
+
+finalizePower :: ([AggregateBitKey] -> AggregateElem)
+              -> AggregatingPowerSet a -> AggregateKey a
+finalizePower finalize pow = AggregateKey . second finalize . extractTermList $ pow
+
+-- | Finalize grouping power set as rollup power set.
+rollup :: AggregatingPowerSet a -> AggregateKey a
+rollup =  finalizePower aggregateRollup
+
+-- | Finalize grouping power set as cube power set.
+cube   :: AggregatingPowerSet a -> AggregateKey a
+cube   =  finalizePower aggregateCube
+
+-- | Finalize grouping set list.
+groupingSets :: AggregatingSetList a -> AggregateKey a
+groupingSets =  AggregateKey . second aggregateSets . extractTermList

relational-query/src/Database/Relational/Query/Monad/Trans/Assigning.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.Assigning
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines monad transformer which lift
+-- from context into context with assigning.
+module Database.Relational.Query.Monad.Trans.Assigning (
+  -- * Transformer into context with assignments
+  Assignings, assignings,
+
+  -- * API of context with assignments
+  assignTo, (!#), (<-#), AssignTarget,
+
+  -- * Result SQL set clause
+  extractAssignments
+  ) where
+
+import Database.Relational.Query.Context (Flat)
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Control.Monad.Trans.State (StateT, runStateT, modify)
+import Control.Applicative (Applicative, (<$>))
+import Control.Arrow ((>>>), second)
+
+import Database.Relational.Query.Component (Assignments)
+import Database.Relational.Query.Monad.Trans.AssigningState
+  (AssigningContext, primeAssigningContext, updateAssignments, assignments)
+import Database.Relational.Query.Pi (Pi)
+import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+
+import Database.Relational.Query.Monad.Class (MonadRestrict(..))
+
+-- | Type to accumulate assigning context.
+--   Type 'r' is table record type.
+newtype Assignings r m a =
+  Assignings { assigningState :: StateT AssigningContext m a }
+  deriving (MonadTrans, Monad, Functor, Applicative)
+
+-- | Run 'Assignings' to expand context state.
+runAssignings :: Assignings r m a        -- ^ Context to expand
+              -> AssigningContext        -- ^ Initial context
+              -> m (a, AssigningContext) -- ^ Expanded result
+runAssignings =  runStateT . assigningState
+
+-- | Run 'Assignings' with primary empty context to expand context state.
+runAssigningsPrime :: Assignings r m a        -- ^ Context to expand
+                   -> m (a, AssigningContext) -- ^ Expanded result
+runAssigningsPrime q = runAssignings q $ primeAssigningContext
+
+-- | Lift to 'Assignings'
+assignings :: Monad m => m a -> Assignings r m a
+assignings =  lift
+
+-- | Unsafely update assigning context.
+updateAssigningContext :: Monad m => (AssigningContext -> AssigningContext) -> Assignings r m ()
+updateAssigningContext =  Assignings . modify
+
+-- | 'MonadRestrict' with ordering.
+instance MonadRestrict c m => MonadRestrict c (Assignings r m) where
+  restrictContext = assignings . restrictContext
+
+-- | Target of assignment.
+newtype AssignTarget r v = AssignTarget (Table r, Pi r v)
+
+targetProjection :: AssignTarget r v -> Projection Flat v
+targetProjection (AssignTarget (tbl, pi')) =
+  Projection.pi (Projection.unsafeFromTable tbl) pi'
+
+-- | Add an assignment.
+assignTo :: Monad m => Projection Flat v ->  AssignTarget r v -> Assignings r m ()
+assignTo vp target = updateAssigningContext . foldr (>>>) id
+                     $ zipWith updateAssignments lefts rights  where
+  lefts  = Projection.columns $ targetProjection target
+  rights = Projection.columns vp
+
+-- | Specify target of assignment.
+(!#) :: Table r -> Pi r v -> AssignTarget r v
+(!#) =  curry AssignTarget
+
+-- | Add and assginment.
+(<-#) :: Monad m => AssignTarget r v -> Projection Flat v -> Assignings r m ()
+(<-#) =  flip assignTo
+
+infix 8 !#
+infix 4 <-#
+
+-- | Run 'Assignings' to get 'Assignments'
+extractAssignments :: (Monad m, Functor m)
+                   => Assignings r m a
+                   -> m (a, Assignments)
+extractAssignments q = second assignments <$> runAssigningsPrime q

relational-query/src/Database/Relational/Query/Monad/Trans/AssigningState.hs

@@ -0,0 +1,51 @@
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.AssigningState
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module provides context definition for
+-- "Database.Relational.Query.Monad.Trans.Assigning".
+module Database.Relational.Query.Monad.Trans.AssigningState (
+  -- * Assigning context
+  AssigningTerms,
+  AssigningContext,
+
+  AssignColumn, AssignTerm,
+
+  primeAssigningContext,
+
+  updateAssignments,
+
+  assignments
+  ) where
+
+import Data.DList (DList)
+import qualified Data.DList as DList
+import Data.Monoid ((<>))
+import Control.Applicative (pure)
+
+import Database.Relational.Query.Component (AssignColumn, AssignTerm, Assignment, Assignments)
+
+
+-- | Assigning terms.
+type AssigningTerms = DList Assignment
+
+-- | Context type for Assignings.
+newtype AssigningContext = AssigningContext { assigningTerms :: AssigningTerms }
+
+-- | Initial 'AssigningContext'
+primeAssigningContext :: AssigningContext
+primeAssigningContext =  AssigningContext DList.empty
+
+-- | Add order-by term.
+updateAssignments :: AssignColumn -> AssignTerm -> AssigningContext -> AssigningContext
+updateAssignments col term ctx =
+  ctx { assigningTerms = assigningTerms ctx <> pure (col, term)  }
+
+-- | Finalize context to extract accumulated assignment pairs state.
+assignments :: AssigningContext -> Assignments
+assignments =  DList.toList . assigningTerms

relational-query/src/Database/Relational/Query/Monad/Trans/Config.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.Config
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines monad transformer which requires query generate configuration.
+module Database.Relational.Query.Monad.Trans.Config (
+  -- * Transformer into query with configuration
+  QueryConfig, config,
+  runQueryConfig, askConfig
+  ) where
+
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
+import Control.Applicative (Applicative)
+
+import Database.Relational.Query.Component (Config)
+
+
+-- | 'ReaderT' type to require query generate configuration.
+newtype QueryConfig m a =
+  QueryConfig { queryConfig :: ReaderT Config m a }
+  deriving (MonadTrans, Monad, Functor, Applicative)
+
+-- | Run 'QueryConfig' to expand with configuration
+runQueryConfig :: QueryConfig m a -> Config -> m a
+runQueryConfig =  runReaderT . queryConfig
+
+-- | Lift to 'QueryConfig'.
+config :: Monad m => m a -> QueryConfig m a
+config =  lift
+
+-- | Read configuration.
+askConfig :: Monad m => QueryConfig m Config
+askConfig =  QueryConfig $ ask

relational-query/src/Database/Relational/Query/Monad/Trans/Join.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.Join
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines monad transformer which lift to basic 'MonadQuery'.
+module Database.Relational.Query.Monad.Trans.Join (
+  -- * Transformer into join query
+  QueryJoin, join',
+
+  -- * Result
+  extractProduct
+  ) where
+
+import Prelude hiding (product)
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Control.Monad.Trans.State (modify, StateT, runStateT)
+import Control.Applicative (Applicative, (<$>))
+import Control.Arrow (second)
+
+import Database.Relational.Query.Context (Flat)
+import Database.Relational.Query.Monad.Trans.JoinState
+  (JoinContext, primeJoinContext, updateProduct, joinProduct)
+import Database.Relational.Query.Internal.Product (NodeAttr, restrictProduct, growProduct)
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+import Database.Relational.Query.Expr (Expr, fromJust)
+import Database.Relational.Query.Sub (SubQuery, Qualified, JoinProduct)
+
+import Database.Relational.Query.Monad.Class (MonadQuery (..))
+
+
+-- | 'StateT' type to accumulate join product context.
+newtype QueryJoin m a =
+  QueryJoin { queryState :: StateT JoinContext m a }
+  deriving (MonadTrans, Monad, Functor, Applicative)
+
+-- | Run 'QueryJoin' to expand context state.
+runQueryJoin :: QueryJoin m a  -- ^ Context to expand
+             -> JoinContext        -- ^ Initial context
+             -> m (a, JoinContext) -- ^ Expanded result
+runQueryJoin =  runStateT . queryState
+
+-- | Run 'QueryJoin' with primary empty context to expand context state.
+runQueryPrime :: QueryJoin m a  -- ^ Context to expand
+              -> m (a, JoinContext) -- ^ Expanded result
+runQueryPrime q = runQueryJoin q primeJoinContext
+
+-- | Lift to 'QueryJoin'
+join' :: Monad m => m a -> QueryJoin m a
+join' =  lift
+
+-- | Unsafely update join product context.
+updateContext :: Monad m => (JoinContext -> JoinContext) -> QueryJoin m ()
+updateContext =  QueryJoin . modify
+
+-- | Add last join product restriction.
+updateJoinRestriction :: Monad m => Expr Flat (Maybe Bool) -> QueryJoin m ()
+updateJoinRestriction e = updateContext (updateProduct d)  where
+  d  Nothing  = error "on: Product is empty! Restrict target product is not found!"
+  d (Just pt) = restrictProduct pt (fromJust e)
+
+{-
+takeProduct :: QueryJoin (Maybe QueryProductNode)
+takeProduct =  queryCore State.takeProduct
+
+restoreLeft :: QueryProductNode -> NodeAttr -> QueryJoin ()
+restoreLeft pL naR = updateContext $ State.restoreLeft pL naR
+-}
+
+-- | Joinable query instance.
+instance (Monad q, Functor q) => MonadQuery (QueryJoin q) where
+  restrictJoin  =  updateJoinRestriction
+  unsafeSubQuery          = unsafeSubQueryWithAttr
+  -- unsafeMergeAnotherQuery = unsafeQueryMergeWithAttr
+
+-- | Unsafely join subquery with this query.
+unsafeSubQueryWithAttr :: Monad q
+                       => NodeAttr                        -- ^ Attribute maybe or just
+                       -> Qualified SubQuery              -- ^ 'SubQuery' to join
+                       -> QueryJoin q (Projection Flat r) -- ^ Result joined context and 'SubQuery' result projection.
+unsafeSubQueryWithAttr attr qsub = do
+  updateContext (updateProduct (`growProduct` (attr, qsub)))
+  return $ Projection.unsafeFromQualifiedSubQuery qsub
+
+{-
+unsafeMergeAnother :: NodeAttr -> QueryJoin a -> QueryJoin a
+unsafeMergeAnother naR qR = do
+  mayPL <- takeProduct
+  v     <- qR
+  maybe (return ()) (\pL -> restoreLeft pL naR) mayPL
+  return v
+
+unsafeQueryMergeWithAttr :: NodeAttr -> QueryJoin (Projection r) -> QueryJoin (Projection r)
+unsafeQueryMergeWithAttr =  unsafeMergeAnother
+-}
+
+-- | Run 'QueryJoin' to get 'JoinProduct'
+extractProduct :: (Monad m, Functor m) => QueryJoin m a -> m (a, JoinProduct)
+extractProduct q = second joinProduct <$> runQueryPrime q

relational-query/src/Database/Relational/Query/Monad/Trans/JoinState.hs

@@ -0,0 +1,56 @@
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.JoinState
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module provides state definition for
+-- "Database.Relational.Query.Monad.Trans.Join".
+module Database.Relational.Query.Monad.Trans.JoinState (
+  -- * Join context
+  JoinContext,
+
+  primeJoinContext,
+
+  updateProduct, -- takeProduct, restoreLeft,
+
+  joinProduct
+
+  -- composeFrom
+  ) where
+
+import Prelude hiding (product)
+
+import qualified Database.Relational.Query.Internal.Product as Product
+import Database.Relational.Query.Sub (QueryProductNode, JoinProduct)
+
+
+-- | JoinContext type for QueryJoin.
+newtype JoinContext =
+  JoinContext
+  { product :: Maybe QueryProductNode }
+
+-- | Initial 'JoinContext'.
+primeJoinContext :: JoinContext
+primeJoinContext =  JoinContext Nothing
+
+-- | Update product of 'JoinContext'.
+updateProduct' :: (Maybe QueryProductNode -> Maybe QueryProductNode) -> JoinContext -> JoinContext
+updateProduct' uf ctx = ctx { product = uf . product $ ctx }
+
+-- | Update product of 'JoinContext'.
+updateProduct :: (Maybe QueryProductNode -> QueryProductNode) -> JoinContext -> JoinContext
+updateProduct uf = updateProduct' (Just . uf)
+
+-- takeProduct :: JoinContext -> (Maybe QueryProductNode, JoinContext)
+-- takeProduct ctx = (product ctx, updateProduct' (const Nothing) ctx)
+
+-- restoreLeft :: QueryProductNode -> Product.NodeAttr -> JoinContext -> JoinContext
+-- restoreLeft pL naR ctx = updateProduct (Product.growLeft pL naR) ctx
+
+-- |  Finalize context to extract accumulated query product.
+joinProduct :: JoinContext -> JoinProduct
+joinProduct =  fmap Product.nodeTree . product

relational-query/src/Database/Relational/Query/Monad/Trans/ListState.hs

@@ -0,0 +1,32 @@
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.ListState
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module provides polymorphic list state definitions.
+module Database.Relational.Query.Monad.Trans.ListState (
+  TermsContext, primeTermsContext, appendTerm, termsList
+  ) where
+
+import Data.DList (DList, toList)
+import Data.Monoid (mempty, (<>))
+import Control.Applicative (pure)
+
+-- | Type to accumulate terms.
+type TermsContext = DList
+
+-- | Initial state for TermsContext.
+primeTermsContext :: TermsContext a
+primeTermsContext =  mempty
+
+-- | Append a new term.
+appendTerm :: a -> TermsContext a -> TermsContext a
+appendTerm at ctx = ctx <> pure at
+
+-- | Result term list.
+termsList :: TermsContext a -> [a]
+termsList =  toList

relational-query/src/Database/Relational/Query/Monad/Trans/Ordering.hs

@@ -0,0 +1,135 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.Ordering
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines monad transformer which lift
+-- from query into query with ordering.
+module Database.Relational.Query.Monad.Trans.Ordering (
+  -- * Transformer into query with ordering
+  Orderings, orderings, OrderedQuery, OrderingTerms,
+
+  -- * API of query with ordering
+  asc, desc,
+
+  -- * Result
+  extractOrderingTerms
+  ) where
+
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Control.Monad.Trans.State (StateT, runStateT, modify)
+import Control.Applicative (Applicative, (<$>))
+import Control.Arrow (second, (>>>))
+
+import Database.Relational.Query.Component (Order(Asc, Desc), OrderColumn, OrderingTerms)
+import Database.Relational.Query.Monad.Trans.OrderingState
+  (OrderingContext, primeOrderingContext, updateOrderBy, orderingTerms)
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+
+import Database.Relational.Query.Monad.Class
+  (MonadRestrict(..), MonadQuery(..), MonadAggregate(..))
+
+
+-- | 'StateT' type to accumulate ordering context.
+--   Type 'p' is ordering term projection type.
+newtype Orderings p m a =
+  Orderings { orderingState :: StateT OrderingContext m a }
+  deriving (MonadTrans, Monad, Functor, Applicative)
+
+-- | Run 'Orderings' to expand context state.
+runOrderings :: Orderings p m a        -- ^ Context to expand
+             -> OrderingContext        -- ^ Initial context
+             -> m (a, OrderingContext) -- ^ Expanded result
+runOrderings =  runStateT . orderingState
+
+-- | Run 'Orderings' with primary empty context to expand context state.
+runOrderingsPrime :: Orderings p m a        -- ^ Context to expand
+                  -> m (a, OrderingContext) -- ^ Expanded result
+runOrderingsPrime q = runOrderings q $ primeOrderingContext
+
+-- | Lift to 'Orderings'.
+orderings :: Monad m => m a -> Orderings p m a
+orderings =  lift
+
+-- | 'MonadRestrict' with ordering.
+instance MonadRestrict c m => MonadRestrict c (Orderings p m) where
+  restrictContext = orderings . restrictContext
+
+-- | 'MonadQuery' with ordering.
+instance MonadQuery m => MonadQuery (Orderings p m) where
+  restrictJoin  =  orderings . restrictJoin
+  unsafeSubQuery na       = orderings . unsafeSubQuery na
+  -- unsafeMergeAnotherQuery = unsafeMergeAnotherOrderBys
+
+-- | 'MonadAggregate' with ordering.
+instance MonadAggregate m => MonadAggregate (Orderings p m) where
+  unsafeAddAggregateElement = orderings . unsafeAddAggregateElement
+
+-- | OrderedQuery type synonym. Projection must be the same as 'Orderings' type parameter 'p'
+type OrderedQuery p m r = Orderings p m (Projection p r)
+
+-- | Ordering term projection type interface.
+class ProjectableOrdering p where
+  orderTerms :: p t -> [OrderColumn]
+
+-- | 'Projection' is ordering term.
+instance ProjectableOrdering (Projection c) where
+  orderTerms = Projection.columns
+
+-- | Unsafely update ordering context.
+updateOrderingContext :: Monad m => (OrderingContext -> OrderingContext) -> Orderings p m ()
+updateOrderingContext =  Orderings . modify
+
+-- | Add ordering terms.
+updateOrderBys :: (Monad m, ProjectableOrdering (Projection p))
+               => Order            -- ^ Order direction
+               -> Projection p t   -- ^ Ordering terms to add
+               -> Orderings p m () -- ^ Result context with ordering
+updateOrderBys order p = updateOrderingContext . foldr (>>>) id $ updates  where
+  updates = updateOrderBy order `map` orderTerms p
+
+{-
+takeOrderBys :: Monad m => Orderings p m OrderBys
+takeOrderBys =  Orderings $ state Context.takeOrderBys
+
+restoreLowOrderBys :: Monad m => Context.OrderBys -> Orderings p m ()
+restoreLowOrderBys ros = updateOrderingContext $ Context.restoreLowOrderBys ros
+unsafeMergeAnotherOrderBys :: UnsafeMonadQuery m
+                           => NodeAttr
+                           -> Orderings p m (Projection r)
+                           -> Orderings p m (Projection r)
+
+unsafeMergeAnotherOrderBys naR qR = do
+  ros   <- takeOrderBys
+  let qR' = fst <$> runOrderingsPrime qR
+  v     <- lift $ unsafeMergeAnotherQuery naR qR'
+  restoreLowOrderBys ros
+  return v
+-}
+
+
+-- | Add ascendant ordering term.
+asc :: (Monad m, ProjectableOrdering (Projection p))
+    => Projection p t   -- ^ Ordering terms to add
+    -> Orderings p m () -- ^ Result context with ordering
+asc  =  updateOrderBys Asc
+
+-- | Add descendant ordering term.
+desc :: (Monad m, ProjectableOrdering (Projection p))
+     => Projection p t   -- ^ Ordering terms to add
+     -> Orderings p m () -- ^ Result context with ordering
+desc =  updateOrderBys Desc
+
+-- | Run 'Orderings' to get 'OrderingTerms'
+extractOrderingTerms :: (Monad m, Functor m) => Orderings p m a -> m (a, OrderingTerms)
+extractOrderingTerms q = second orderingTerms <$> runOrderingsPrime q

relational-query/src/Database/Relational/Query/Monad/Trans/OrderingState.hs

@@ -0,0 +1,57 @@
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.OrderingState
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module provides context definition for
+-- "Database.Relational.Query.Monad.Trans.Ordering".
+module Database.Relational.Query.Monad.Trans.OrderingState (
+  -- * Ordering context
+  Order, OrderBys,
+  OrderingContext,
+
+  primeOrderingContext,
+
+  updateOrderBy, -- takeOrderBys, restoreLowOrderBys,
+
+  orderingTerms
+  ) where
+
+import Data.DList (DList)
+import qualified Data.DList as DList
+import Data.Monoid ((<>))
+import Control.Applicative (pure)
+
+import Database.Relational.Query.Component (Order, OrderColumn, OrderingTerm, OrderingTerms)
+
+
+-- | Ordering terms.
+type OrderBys = DList OrderingTerm
+
+-- | Context type for Orderings.
+newtype OrderingContext = OrderingContext { orderBys :: OrderBys }
+
+-- | Initial 'OrderingContext'
+primeOrderingContext :: OrderingContext
+primeOrderingContext =  OrderingContext DList.empty
+
+-- | Add order-by term.
+updateOrderBy :: Order -> OrderColumn -> OrderingContext -> OrderingContext
+updateOrderBy order' term ctx =
+  ctx { orderBys = orderBys ctx <> pure (order', term)  }
+
+{-
+takeOrderBys :: OrderingContext -> (OrderBys, OrderingContext)
+takeOrderBys ctx = (orderBys ctx , ctx { orderBys = DList.empty })
+
+restoreLowOrderBys :: OrderBys -> OrderingContext -> OrderingContext
+restoreLowOrderBys ros ctx = ctx { orderBys = orderBys ctx <> ros }
+-}
+
+-- | Finalize context to extract accumulated ordering state.
+orderingTerms :: OrderingContext -> OrderingTerms
+orderingTerms =  DList.toList . orderBys

relational-query/src/Database/Relational/Query/Monad/Trans/Restricting.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.Restricting
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines monad transformer which lift to basic 'MonadQuery'.
+module Database.Relational.Query.Monad.Trans.Restricting (
+  -- * Transformer into restricted context
+  Restrictings, restrictings,
+
+  -- * Result
+  extractRestrict
+  ) where
+
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Control.Monad.Trans.State (modify, StateT, runStateT)
+import Control.Applicative (Applicative, (<$>))
+import Control.Arrow (second)
+
+import Database.Relational.Query.Monad.Trans.RestrictingState
+  (RestrictContext, primeRestrictContext, addRestriction, restriction)
+import Database.Relational.Query.Expr (Expr)
+import Database.Relational.Query.Component (QueryRestriction)
+
+import Database.Relational.Query.Monad.Class (MonadRestrict(..), MonadQuery (..), MonadAggregate(..))
+
+
+-- | 'StateT' type to accumulate join product context.
+newtype Restrictings c m a =
+  Restrictings { queryState :: StateT (RestrictContext c) m a }
+  deriving (MonadTrans, Monad, Functor, Applicative)
+
+-- | Run 'Restrictings' to expand context state.
+runRestrictings :: Restrictings c m a       -- ^ RestrictContext to expand
+                -> RestrictContext c        -- ^ Initial context
+                -> m (a, RestrictContext c) -- ^ Expanded result
+runRestrictings =  runStateT . queryState
+
+-- | Run 'Restrictings' with primary empty context to expand context state.
+runRestrictingsPrime :: Restrictings c m a       -- ^ RestrictContext to expand
+                     -> m (a, RestrictContext c) -- ^ Expanded result
+runRestrictingsPrime q = runRestrictings q primeRestrictContext
+
+-- | Lift to 'Restrictings'
+restrictings :: Monad m => m a -> Restrictings c m a
+restrictings =  lift
+
+-- | Unsafely update join product context.
+updateRestrictContext :: Monad m => (RestrictContext c -> RestrictContext c) -> Restrictings c m ()
+updateRestrictContext =  Restrictings . modify
+
+-- | Add whole query restriction.
+updateRestriction :: Monad m => Expr c (Maybe Bool) -> Restrictings c m ()
+updateRestriction e = updateRestrictContext (addRestriction e)
+
+-- | 'MonadRestrict' instance.
+instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where
+  restrictContext = updateRestriction
+
+-- | Restricted 'MonadQuery' instance.
+instance MonadQuery q => MonadQuery (Restrictings c q) where
+  restrictJoin     = restrictings . restrictJoin
+  unsafeSubQuery a = restrictings . unsafeSubQuery a
+
+-- | Resticted 'MonadAggregate' instance.
+instance MonadAggregate m => MonadAggregate (Restrictings c m) where
+  unsafeAddAggregateElement = restrictings . unsafeAddAggregateElement
+
+-- | Run 'Restrictings' to get 'QueryRestriction'
+extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, QueryRestriction c)
+extractRestrict q = second restriction <$> runRestrictingsPrime q

relational-query/src/Database/Relational/Query/Monad/Trans/RestrictingState.hs

@@ -0,0 +1,44 @@
+-- |
+-- Module      : Database.Relational.Query.Monad.Trans.RestrictingState
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module provides context definition for
+-- "Database.Relational.Query.Monad.Trans.Restricting".
+module Database.Relational.Query.Monad.Trans.RestrictingState (
+  -- * Context of restriction
+  RestrictContext,
+
+  primeRestrictContext,
+
+  addRestriction,
+
+  restriction
+  ) where
+
+import Database.Relational.Query.Expr (Expr, fromJust, exprAnd)
+import Database.Relational.Query.Component (QueryRestriction)
+
+
+-- | Context type for Restrict.
+newtype RestrictContext c = RestrictContext
+                            { restriction' :: QueryRestriction c }
+
+-- | Initial 'RestrictContext'.
+primeRestrictContext :: RestrictContext c
+primeRestrictContext =  RestrictContext Nothing
+
+-- | Add restriction of 'RestrictContext'.
+addRestriction :: Expr c (Maybe Bool) -> RestrictContext c -> RestrictContext c
+addRestriction e1 ctx =
+  ctx { restriction' = Just . uf . restriction' $ ctx }
+  where uf  Nothing  = fromJust e1
+        uf (Just e0) = e0 `exprAnd` fromJust e1
+
+-- | Finalize context to extract accumulated restriction state.
+restriction :: RestrictContext c -> QueryRestriction c
+restriction =  restriction'

relational-query/src/Database/Relational/Query/Monad/Type.hs

@@ -0,0 +1,42 @@
+-- |
+-- Module      : Database.Relational.Query.Monad.Type
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines core query type.
+module Database.Relational.Query.Monad.Type (
+  -- * Core query monad
+  ConfigureQuery, configureQuery, qualifyQuery, QueryCore, extractCore
+  ) where
+
+import Database.Relational.Query.Component (Config, QueryRestriction)
+import Database.Relational.Query.Sub (Qualified, JoinProduct)
+import Database.Relational.Query.Context (Flat)
+import qualified Database.Relational.Query.Monad.Qualify as Qualify
+import Database.Relational.Query.Monad.Qualify (Qualify, evalQualifyPrime)
+import Database.Relational.Query.Monad.Trans.Config (QueryConfig, runQueryConfig, config)
+import Database.Relational.Query.Monad.Trans.Join (QueryJoin, extractProduct)
+import Database.Relational.Query.Monad.Trans.Restricting (Restrictings, extractRestrict)
+
+
+-- | Thin monad type for untyped structure.
+type ConfigureQuery = QueryConfig Qualify
+
+-- | Run 'ConfigureQuery' monad with initial state to get only result.
+configureQuery :: ConfigureQuery c -> Config -> c
+configureQuery c = evalQualifyPrime . runQueryConfig c
+
+-- | Get qualifyed table form query.
+qualifyQuery :: a -> ConfigureQuery (Qualified a)
+qualifyQuery =  config . Qualify.qualifyQuery
+
+-- | Core query monad type used from flat(not-aggregated) query and aggregated query.
+type QueryCore = Restrictings Flat (QueryJoin ConfigureQuery)
+
+-- | Extract 'QueryCore' computation.
+extractCore :: QueryCore a -> ConfigureQuery ((a, QueryRestriction Flat), JoinProduct)
+extractCore =  extractProduct . extractRestrict

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

@@ -0,0 +1,40 @@
+-- |
+-- Module      : Database.Relational.Query.Pi
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines typed projection path objects.
+-- Contains normal interfaces.
+module Database.Relational.Query.Pi (
+  -- * Projection path
+  Pi, piZip, (<.>), (<?.>), (<??.>),
+
+  id', fst', snd'
+  ) where
+
+import Database.Record
+  (PersistableWidth, persistableWidth, PersistableRecordWidth)
+import Database.Record.Persistable
+  (runPersistableRecordWidth)
+
+import Database.Relational.Query.Pi.Unsafe
+  (Pi, piZip, (<.>), (<?.>), (<??.>), definePi)
+
+-- | Identity projection path.
+id' :: PersistableWidth a => Pi a a
+id' =  definePi 0
+
+-- | Projection path for fst of tuple.
+fst' :: PersistableWidth a => Pi (a, b) a -- ^ Projection path of fst.
+fst' =  definePi 0
+
+snd'' :: PersistableWidth b => PersistableRecordWidth a -> Pi (a, b) b
+snd'' wa = definePi (runPersistableRecordWidth wa)
+
+-- | Projection path for snd of tuple.
+snd' :: (PersistableWidth a, PersistableWidth b) =>  Pi (a, b) b -- ^ Projection path of snd.
+snd' =  snd'' persistableWidth

relational-query/src/Database/Relational/Query/Pi/Unsafe.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+-- |
+-- Module      : Database.Relational.Query.Pi.Unsafe
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines typed projection path objects.
+-- Contains internal structure and unsafe interfaces.
+module Database.Relational.Query.Pi.Unsafe (
+  -- * Projection path
+  Pi,
+
+  piZip,
+
+  width',
+
+  (<.>), (<?.>), (<??.>),
+
+  pi,
+
+  definePi, defineDirectPi', defineDirectPi,
+
+  unsafeExpandIndexes
+  ) where
+
+import Prelude hiding (pi)
+import Data.Array (listArray, (!))
+
+import Database.Record.Persistable
+  (PersistableRecordWidth, runPersistableRecordWidth, (<&>),
+   PersistableWidth (persistableWidth), maybeWidth)
+
+-- | Projection path primary structure type.
+data Pi' r0 r1 = Leftest Int
+               | Map [Int]
+
+unsafePiAppend' :: Pi' a b' -> Pi' b c' -> Pi' a c
+unsafePiAppend' = d  where
+  d (Leftest i) (Leftest j) = Leftest $ i + j
+  d (Leftest i) (Map js)    = Map $ map (i +) js
+  d (Map is)    (Leftest j) = Map $ drop j is
+  d (Map is)    (Map js)    = Map   [ is' ! j | j <- js ]  where
+    is' = listArray (0, length is) is
+
+-- | Projection path from type 'r0' into type 'r1'.
+--   This type also indicate key object which type is 'r1' for record type 'r0'.
+data Pi r0 r1 = Pi (Pi' r0 r1) (PersistableRecordWidth r1)
+
+unsafePiAppend :: (PersistableRecordWidth c' -> PersistableRecordWidth c)
+                  -> Pi a b' -> Pi b c' -> Pi a c
+unsafePiAppend f (Pi p0 _) (Pi p1 w) =
+  Pi (p0 `unsafePiAppend'` p1) (f w)
+
+-- | Unsafely untype key to expand indexes.
+unsafeExpandIndexes :: Pi a b -> [Int]
+unsafeExpandIndexes = d  where
+  d (Pi (Map is) _)    = is
+  d (Pi (Leftest i) w) = [ i .. i + width - 1 ]  where
+    width = runPersistableRecordWidth w
+
+-- | Zipping two projection path.
+piZip :: Pi a b -> Pi a c -> Pi a (b, c)
+piZip b@(Pi _ wb) c@(Pi _ wc) =
+   Pi
+   (Map $ unsafeExpandIndexes b ++ unsafeExpandIndexes c)
+   (wb <&> wc)
+
+-- | Get record width proof object.
+width' :: Pi r ct -> PersistableRecordWidth ct
+width' (Pi _ w) = w
+
+-- | Compose projection path.
+(<.>) :: Pi a b -> Pi b c -> Pi a c
+(<.>) = unsafePiAppend id
+
+-- | Compose projection path.
+(<?.>) :: Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c)
+(<?.>) = unsafePiAppend maybeWidth
+
+-- | Compose projection path.
+(<??.>) :: Pi a (Maybe b) -> Pi b (Maybe c) -> Pi a (Maybe c)
+(<??.>) = unsafePiAppend id
+
+infixl 8 <.>, <?.>, <??.>
+
+-- | Unsafely project untyped value list.
+pi :: [a] -> Pi r0 r1 -> [a]
+pi cs (Pi p' w) = d p'  where
+  d (Leftest i) = take (runPersistableRecordWidth w) . drop i $ cs
+  d (Map is)    = [cs' ! i | i <- is]
+  cs' = listArray (0, length cs) cs
+
+-- | Unsafely define projection path from type 'r0' into type 'r1'.
+definePi' :: PersistableRecordWidth r1
+          -> Int      -- ^ Index of flat SQL value list
+          -> Pi r0 r1 -- ^ Result projection path
+definePi' pw i = Pi (Leftest i) pw
+
+-- | Unsafely define projection path from type 'r0' into type 'r1'.
+--   Use infered 'PersistableRecordWidth'.
+definePi :: PersistableWidth r1
+         => Int      -- ^ Index of flat SQL value list
+         -> Pi r0 r1 -- ^ Result projection path
+definePi = definePi' persistableWidth
+
+-- | Unsafely define projection path from type 'r0' into type 'r1'.
+defineDirectPi' :: PersistableRecordWidth r1
+                -> [Int]    -- ^ Indexes of flat SQL value list
+                -> Pi r0 r1 -- ^ Result projection path
+defineDirectPi' pw is = Pi (Map is) pw
+
+-- | Unsafely define projection path from type 'r0' into type 'r1'.
+--   Use infered 'PersistableRecordWidth'.
+defineDirectPi :: PersistableWidth r1
+               => [Int]    -- ^ Indexes of flat SQL value list
+               -> Pi r0 r1 -- ^ Result projection path
+defineDirectPi = defineDirectPi' persistableWidth

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

@@ -0,0 +1,478 @@
+{-# LANGUAGE FlexibleInstances #-}
+-- |
+-- Module      : Database.Relational.Query.Projectable
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines operators on various polymorphic projections.
+module Database.Relational.Query.Projectable (
+  -- * Conversion between individual Projections
+  expr,
+
+  -- * Projectable from SQL strings
+  SqlProjectable (unsafeProjectSqlTerms), unsafeProjectSql,
+
+  -- * Projections of values
+  value,
+  valueTrue, valueFalse,
+  values,
+  unsafeValueNull,
+
+  -- * Placeholders
+  PlaceHolders, addPlaceHolders, unsafePlaceHolders,
+  placeholder', placeholder,
+
+  -- * Projectable into SQL strings
+  unsafeShowSqlExpr,
+  unsafeShowSqlProjection,
+  ProjectableShowSql (unsafeShowSql),
+
+  -- * Binary Operators
+  SqlBinOp,
+  unsafeBinOp,
+
+  (.=.), (.<.), (.<=.), (.>.), (.>=.), (.<>.),
+
+  casesOrElse, casesOrElse',
+  caseSearch, caseSearchMaybe, case', caseMaybe,
+  in', and', or',
+
+  isNull, isNotNull, not', exists,
+
+  (.||.), (?||?),
+  (.+.), (.-.), (./.), (.*.), negate',
+  (?+?), (?-?), (?/?), (?*?), negateMaybe,
+
+  -- * Zipping projections
+  ProjectableZip (projectZip), (><),
+  ProjectableIdZip (..),
+
+  -- * 'Maybe' type projecitoins
+  ProjectableMaybe (just, flattenMaybe)
+  ) where
+
+import Prelude hiding (pi)
+
+import Data.String (IsString)
+import Control.Applicative ((<$>))
+
+import qualified Language.SQL.Keyword as SQL
+import qualified Language.SQL.Keyword.ConcatString as SQLs
+
+import Database.Record (PersistableWidth, PersistableRecordWidth, derivedWidth)
+
+import Database.Relational.Query.Internal.String (paren, sqlRowString)
+import Database.Relational.Query.Context (Flat, Aggregated, Exists)
+import Database.Relational.Query.Component (columnSQL, stringFromColumnSQL)
+import Database.Relational.Query.Expr (Expr, ShowConstantSQL (showConstantSQL))
+import qualified Database.Relational.Query.Expr as Expr
+import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr
+
+import Database.Relational.Query.Pi (Pi, piZip)
+
+import Database.Relational.Query.Projection
+  (Projection, unsafeFromColumns, columns,
+   ListProjection, unsafeShowSqlListProjection)
+import qualified Database.Relational.Query.Projection as Projection
+
+
+-- | Unsafely get SQL term from 'Proejction'.
+unsafeShowSqlProjection :: Projection c r -> String
+unsafeShowSqlProjection =  sqlRowString . map stringFromColumnSQL . columns
+
+-- | 'Expr' from 'Projection'
+exprOfProjection :: Projection c r -> Expr c r
+exprOfProjection =  UnsafeExpr.Expr . unsafeShowSqlProjection
+
+-- | Project from Projection type into expression type.
+expr :: Projection p a -> Expr p a
+expr =  exprOfProjection
+
+
+-- | Unsafely generate 'Projection' from SQL expression strings.
+unsafeSqlTermsProjection :: [String] -> Projection c t
+unsafeSqlTermsProjection =  unsafeFromColumns . map columnSQL
+
+-- | Interface to project SQL terms unsafely.
+class SqlProjectable p where
+  -- | Unsafely project from SQL expression strings.
+  unsafeProjectSqlTerms :: [String] -- ^ SQL expression strings
+                        -> p t      -- ^ Result projection object
+
+-- | Unsafely make 'Projection' from SQL terms.
+instance SqlProjectable (Projection Flat) where
+  unsafeProjectSqlTerms = unsafeSqlTermsProjection
+
+-- | Unsafely make 'Projection' from SQL terms.
+instance SqlProjectable (Projection Aggregated) where
+  unsafeProjectSqlTerms = unsafeSqlTermsProjection
+
+-- | Unsafely make 'Expr' from SQL terms.
+instance SqlProjectable (Expr p) where
+  unsafeProjectSqlTerms = UnsafeExpr.Expr . sqlRowString
+
+-- | Unsafely Project single SQL term.
+unsafeProjectSql :: SqlProjectable p => String -> p t
+unsafeProjectSql =  unsafeProjectSqlTerms . (:[])
+
+-- | Polymorphic projection of SQL null value.
+unsafeValueNull :: SqlProjectable p => p (Maybe a)
+unsafeValueNull =  unsafeProjectSql "NULL"
+
+-- | Generate polymorphic projection of SQL constant values from Haskell value.
+value :: (ShowConstantSQL t, SqlProjectable p) => t -> p t
+value =  unsafeProjectSql . showConstantSQL
+
+-- | Polymorphic proejction of SQL true value.
+valueTrue  :: (SqlProjectable p, ProjectableMaybe p) => p (Maybe Bool)
+valueTrue  =  just $ value True
+
+-- | Polymorphic proejction of SQL false value.
+valueFalse :: (SqlProjectable p, ProjectableMaybe p) => p (Maybe Bool)
+valueFalse =  just $ value False
+
+-- | Polymorphic proejction of SQL set value from Haskell list.
+values :: (SqlProjectable p, ShowConstantSQL t) => [t] -> ListProjection p t
+values =  Projection.list . map value
+
+
+-- | Interface to get SQL term from projections.
+class ProjectableShowSql p where
+  -- | Unsafely generate SQL expression string from projection object.
+  unsafeShowSql :: p a    -- ^ Source projection object
+                -> String -- ^ Result SQL expression string.
+
+-- | Unsafely get SQL term from 'Expr'.
+unsafeShowSqlExpr :: Expr p t -> String
+unsafeShowSqlExpr =  UnsafeExpr.showExpr
+
+-- | Unsafely get SQL term from 'Expr'.
+instance ProjectableShowSql (Expr p) where
+  unsafeShowSql = unsafeShowSqlExpr
+
+-- | Unsafely get SQL term from 'Proejction'.
+instance ProjectableShowSql (Projection c) where
+  unsafeShowSql = unsafeShowSqlProjection
+
+
+-- | Binary operator type for SQL String.
+type SqlBinOp = String -> String -> String
+
+-- | Binary operator from SQL operator string.
+sqlBinOp :: String -> SqlBinOp
+sqlBinOp =  SQLs.defineBinOp . SQL.word
+
+-- | Unsafely make projection unary operator from SQL keyword.
+unsafeUniOp :: (SqlProjectable p, ProjectableShowSql p)
+            => SQL.Keyword -> p a -> p b
+unsafeUniOp kw = unsafeProjectSql . paren . SQLs.defineUniOp kw . unsafeShowSql
+
+-- | Unsafely make projection binary operator from string binary operator.
+unsafeBinOp :: (SqlProjectable p, ProjectableShowSql p)
+            => SqlBinOp
+            -> p a -> p b -> p c
+unsafeBinOp op a b = unsafeProjectSql . paren
+                     $ op (unsafeShowSql a) (unsafeShowSql b)
+
+-- | Unsafely make compare projection binary operator from string binary operator.
+compareBinOp :: (SqlProjectable p, ProjectableShowSql p)
+             => SqlBinOp
+             -> p a -> p a -> p (Maybe Bool)
+compareBinOp =  unsafeBinOp
+
+-- | Unsafely make number projection binary operator from string binary operator.
+monoBinOp :: (SqlProjectable p, ProjectableShowSql p)
+         => SqlBinOp
+         -> p a -> p a -> p a
+monoBinOp =  unsafeBinOp
+
+
+-- | Compare operator corresponding SQL /=/ .
+(.=.)  :: (SqlProjectable p, ProjectableShowSql p)
+  => p ft -> p ft -> p (Maybe Bool)
+(.=.)  =  compareBinOp (SQLs..=.)
+
+-- | Compare operator corresponding SQL /</ .
+(.<.)  :: (SqlProjectable p, ProjectableShowSql p)
+  => p ft -> p ft -> p (Maybe Bool)
+(.<.)  =  compareBinOp (SQLs..<.)
+
+-- | Compare operator corresponding SQL /<=/ .
+(.<=.)  :: (SqlProjectable p, ProjectableShowSql p)
+  => p ft -> p ft -> p (Maybe Bool)
+(.<=.)  =  compareBinOp (SQLs..<=.)
+
+-- | Compare operator corresponding SQL />/ .
+(.>.)  :: (SqlProjectable p, ProjectableShowSql p)
+  => p ft -> p ft -> p (Maybe Bool)
+(.>.)  =  compareBinOp (SQLs..>.)
+
+-- | Compare operator corresponding SQL />=/ .
+(.>=.)  :: (SqlProjectable p, ProjectableShowSql p)
+  => p ft -> p ft -> p (Maybe Bool)
+(.>=.)  =  compareBinOp (SQLs..>=.)
+
+-- | Compare operator corresponding SQL /<>/ .
+(.<>.) :: (SqlProjectable p, ProjectableShowSql p)
+  => p ft -> p ft -> p (Maybe Bool)
+(.<>.) =  compareBinOp (SQLs..<>.)
+
+-- | Logical operator corresponding SQL /AND/ .
+and' :: (SqlProjectable p, ProjectableShowSql p)
+     => p ft -> p ft -> p (Maybe Bool)
+and' =  compareBinOp SQLs.and
+
+-- | Logical operator corresponding SQL /OR/ .
+or' :: (SqlProjectable p, ProjectableShowSql p)
+    => p ft -> p ft -> p (Maybe Bool)
+or'  =  compareBinOp SQLs.or
+
+-- | Logical operator corresponding SQL /NOT/ .
+not' :: (SqlProjectable p, ProjectableShowSql p)
+    => p (Maybe Bool) -> p (Maybe Bool)
+not' =  unsafeUniOp SQL.NOT
+
+-- | Logical operator corresponding SQL /EXISTS/ .
+exists :: (SqlProjectable p, ProjectableShowSql p)
+       => ListProjection (Projection Exists) r -> p (Maybe Bool)
+exists =  unsafeProjectSql . paren . SQLs.defineUniOp SQL.EXISTS
+          . unsafeShowSqlListProjection unsafeShowSql
+
+-- | Concatinate operator corresponding SQL /||/ .
+(.||.) :: (SqlProjectable p, ProjectableShowSql p, IsString a)
+       => p a -> p a -> p a
+(.||.) =  unsafeBinOp (SQLs..||.)
+
+-- | Concatinate operator corresponding SQL /||/ . Maybe type version.
+(?||?) :: (SqlProjectable p, ProjectableShowSql p, IsString a)
+       => p (Maybe a) -> p (Maybe a) -> p (Maybe a)
+(?||?) =  unsafeBinOp (SQLs..||.)
+
+-- | Unsafely make number projection binary operator from SQL operator string.
+monoBinOp' :: (SqlProjectable p, ProjectableShowSql p)
+          => String -> p a -> p a -> p a
+monoBinOp' = monoBinOp . sqlBinOp
+
+-- | Number operator corresponding SQL /+/ .
+(.+.) :: (SqlProjectable p, ProjectableShowSql p, Num a)
+  => p a -> p a -> p a
+(.+.) =  monoBinOp' "+"
+
+-- | Number operator corresponding SQL /-/ .
+(.-.) :: (SqlProjectable p, ProjectableShowSql p, Num a)
+  => p a -> p a -> p a
+(.-.) =  monoBinOp' "-"
+
+-- | Number operator corresponding SQL /// .
+(./.) :: (SqlProjectable p, ProjectableShowSql p, Num a)
+  => p a -> p a -> p a
+(./.) =  monoBinOp' "/"
+
+-- | Number operator corresponding SQL /*/ .
+(.*.) :: (SqlProjectable p, ProjectableShowSql p, Num a)
+  => p a -> p a -> p a
+(.*.) =  monoBinOp' "*"
+
+-- | Number negate uni-operator corresponding SQL /-/.
+negate' :: (SqlProjectable p, ProjectableShowSql p, Num a)
+        => p a -> p a
+negate' =  unsafeUniOp $ SQL.word "-"
+
+-- | Number operator corresponding SQL /+/ .
+(?+?) :: (SqlProjectable p, ProjectableShowSql p, Num a)
+  => p (Maybe a) -> p (Maybe a) -> p (Maybe a)
+(?+?) =  monoBinOp' "+"
+
+-- | Number operator corresponding SQL /-/ .
+(?-?) :: (SqlProjectable p, ProjectableShowSql p, Num a)
+  => p (Maybe a) -> p (Maybe a) -> p (Maybe a)
+(?-?) =  monoBinOp' "-"
+
+-- | Number operator corresponding SQL /// .
+(?/?) :: (SqlProjectable p, ProjectableShowSql p, Num a)
+  => p (Maybe a) -> p (Maybe a) -> p (Maybe a)
+(?/?) =  monoBinOp' "/"
+
+-- | Number operator corresponding SQL /*/ .
+(?*?) :: (SqlProjectable p, ProjectableShowSql p, Num a)
+  => p (Maybe a) -> p (Maybe a) -> p (Maybe a)
+(?*?) =  monoBinOp' "*"
+
+-- | Number negate uni-operator corresponding SQL /-/.
+negateMaybe :: (SqlProjectable p, ProjectableShowSql p, Num a)
+            => p (Maybe a) -> p (Maybe a)
+negateMaybe =  unsafeUniOp $ SQL.word "-"
+
+unsafeSqlWord :: ProjectableShowSql p => p a -> SQL.Keyword
+unsafeSqlWord =  SQL.word . unsafeShowSql
+
+-- | Search case operator correnponding SQL search /CASE/.
+--   Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/
+caseSearch :: (SqlProjectable p, ProjectableShowSql p)
+           => [(p (Maybe Bool), p a)] -- ^ Each when clauses
+           -> p a                     -- ^ Else result projection
+           -> p a                     -- ^ Result projection
+caseSearch cs0 e = d cs0 where
+  d []       = error "caseSearch: Empty when clauses!"
+  d cs@(_:_) = unsafeProjectSql . SQL.unwordsSQL . concat
+               $ [SQL.CASE] : map (uncurry when') cs ++ [else', [SQL.END]]
+  when' p r = [SQL.WHEN, unsafeSqlWord p, SQL.THEN, unsafeSqlWord r]
+  else'     = [SQL.ELSE, unsafeSqlWord e]
+
+-- | Same as 'caseSearch', but you can write like <when list> `casesOrElse` <else clause>.
+casesOrElse :: (SqlProjectable p, ProjectableShowSql p)
+            => [(p (Maybe Bool), p a)] -- ^ Each when clauses
+            -> p a                     -- ^ Else result projection
+            -> p a                     -- ^ Result projection
+casesOrElse = caseSearch
+
+-- | Null default version of 'caseSearch'.
+caseSearchMaybe :: (ProjectableShowSql p, SqlProjectable p)
+                => [(p (Maybe Bool), p (Maybe a))] -- ^ Each when clauses
+                -> p (Maybe a)                     -- ^ Result projection
+caseSearchMaybe cs = caseSearch cs unsafeValueNull
+
+-- | Simple case operator correnponding SQL simple /CASE/.
+--   Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/
+case' :: (SqlProjectable p, ProjectableShowSql p)
+      => p a          -- ^ Projection value to match
+      -> [(p a, p b)] -- ^ Each when clauses
+      -> p b          -- ^ Else result projection
+      -> p b          -- ^ Result projection
+case' v cs0 e = d cs0 where
+  d []       = error "case': Empty when clauses!"
+  d cs@(_:_) = unsafeProjectSql . SQL.unwordsSQL . concat
+               $ [[SQL.CASE, unsafeSqlWord v]] ++ map (uncurry when') cs ++ [else', [SQL.END]]
+  when' p r = [SQL.WHEN, unsafeSqlWord p, SQL.THEN, unsafeSqlWord r]
+  else'     = [SQL.ELSE, unsafeSqlWord e]
+
+-- | Uncurry version of 'case'', and you can write like ... `casesOrElse'` <else clause>.
+casesOrElse' :: (SqlProjectable p, ProjectableShowSql p)
+             => (p a, [(p a, p b)]) -- ^ Projection value to match and each when clauses list
+             -> p b                 -- ^ Else result projection
+             -> p b                 -- ^ Result projection
+casesOrElse' =  uncurry case'
+
+-- | Null default version of 'case''.
+caseMaybe :: (SqlProjectable p, ProjectableShowSql p, ProjectableMaybe p)
+          => p a                  -- ^ Projection value to match
+          -> [(p a, p (Maybe b))] -- ^ Each when clauses
+          -> p (Maybe b)          -- ^ Result projection
+caseMaybe v cs = case' v cs unsafeValueNull
+
+-- | Binary operator corresponding SQL /IN/ .
+in' :: (SqlProjectable p, ProjectableShowSql p)
+    => p t -> ListProjection p t -> p (Maybe Bool)
+in' a lp = unsafeProjectSql . paren
+           $ SQLs.in' (unsafeShowSql a) (unsafeShowSqlListProjection unsafeShowSql lp)
+
+-- | Operator corresponding SQL /IS NULL/ .
+isNull :: (SqlProjectable p, ProjectableShowSql p)
+       => p (Maybe t) -> p (Maybe Bool)
+isNull x = compareBinOp (SQLs.defineBinOp SQL.IS) x unsafeValueNull
+
+-- | Operator corresponding SQL /NOT (... IS NULL)/ .
+isNotNull :: (SqlProjectable p, ProjectableShowSql p)
+          => p (Maybe t) -> p (Maybe Bool)
+isNotNull =  not' . isNull
+
+-- | Placeholder parameter type which has real parameter type arguemnt 'p'.
+data PlaceHolders p = PlaceHolders
+
+-- | Unsafely add placeholder parameter to queries.
+addPlaceHolders :: Functor f => f a -> f (PlaceHolders p, a)
+addPlaceHolders =  fmap ((,) PlaceHolders)
+
+-- | Unsafely get placeholder parameter
+unsafePlaceHolders :: PlaceHolders p
+unsafePlaceHolders =  PlaceHolders
+
+-- | Unsafely cast placeholder parameter type.
+unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b
+unsafeCastPlaceHolders PlaceHolders = PlaceHolders
+
+unsafeProjectPlaceHolder' :: (PersistableWidth r, SqlProjectable p)
+                               => (PersistableRecordWidth r, p r)
+unsafeProjectPlaceHolder' =  unsafeProjectSqlTerms . (`replicate` "?") <$> derivedWidth
+
+unsafeProjectPlaceHolder :: (PersistableWidth r, SqlProjectable p)
+                               => p r
+unsafeProjectPlaceHolder =  snd unsafeProjectPlaceHolder'
+
+-- | Provide scoped placeholder and return its parameter object.
+placeholder' :: (PersistableWidth t, SqlProjectable p) => (p t -> a) ->  (PlaceHolders t, a)
+placeholder' f = (PlaceHolders, f $ unsafeProjectPlaceHolder)
+
+-- | Provide scoped placeholder and return its parameter object. Monadic version.
+placeholder :: (PersistableWidth t, SqlProjectable p, Monad m) => (p t -> m a) -> m (PlaceHolders t, a)
+placeholder f = do
+  let (ph, ma) = placeholder' f
+  a <- ma
+  return (ph, a)
+
+
+-- | Interface to zip projections.
+class ProjectableZip p where
+  -- | Zip projections.
+  projectZip :: p a -> p b -> p (a, b)
+
+-- | Zip placeholder parameters.
+instance ProjectableZip PlaceHolders where
+  projectZip PlaceHolders PlaceHolders = PlaceHolders
+
+-- | Zip 'Projection'.
+instance ProjectableZip (Projection c) where
+  projectZip = Projection.compose
+
+-- | Zip 'Pi'
+instance ProjectableZip (Pi a) where
+  projectZip = piZip
+
+-- | Binary operator the same as 'projectZip'.
+(><) ::ProjectableZip p => p a -> p b -> p (a, b)
+(><) = projectZip
+
+-- | Interface to control 'Maybe' of phantom type in projections.
+class ProjectableMaybe p where
+  -- | Cast projection phantom type into 'Maybe'.
+  just :: p a -> p (Maybe a)
+  -- | Compose nested 'Maybe' phantom type on projection.
+  flattenMaybe :: p (Maybe (Maybe a)) -> p (Maybe a)
+
+-- | Control phantom 'Maybe' type in placeholder parameters.
+instance ProjectableMaybe PlaceHolders where
+  just         = unsafeCastPlaceHolders
+  flattenMaybe = unsafeCastPlaceHolders
+
+-- | Control phantom 'Maybe' type in projection type 'Projection'.
+instance ProjectableMaybe (Projection c) where
+  just         = Projection.just
+  flattenMaybe = Projection.flattenMaybe
+
+-- | Control phantom 'Maybe' type in SQL expression type 'Expr'.
+instance ProjectableMaybe (Expr p) where
+  just         = Expr.just
+  flattenMaybe = Expr.fromJust
+
+-- | Zipping except for identity element laws.
+class ProjectableZip p => ProjectableIdZip p where
+  leftId  :: p ((), a) -> p a
+  rightId :: p (a, ()) -> p a
+
+-- | Zipping except for identity element laws against placeholder parameter type.
+instance ProjectableIdZip PlaceHolders where
+  leftId  = unsafeCastPlaceHolders
+  rightId = unsafeCastPlaceHolders
+
+
+infixl 7 .*., ./., ?*?, ?/?
+infixl 6 .+., .-., ?+?, ?-?
+infixl 5 .||., ?||?
+infix  4 .=., .<>., .>., .>=., .<., .<=., `in'`
+infixr 3 `and'`
+infixr 2 `or'`
+infixl 1  ><

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

@@ -0,0 +1,247 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-- |
+-- Module      : Database.Relational.Query.ProjectableExtended
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines operators on various polymorphic projections
+-- which needs extended GHC features.
+module Database.Relational.Query.ProjectableExtended (
+  -- * Projection for nested 'Maybe's
+  ProjectableFlattenMaybe (flatten),
+
+  flattenPiMaybe,
+
+  -- * Get narrower projections
+  (!), (?!), (?!?), (!??),
+
+  (.!), (.?),
+
+  -- -- * Get weaken projection type
+  -- Projectable (project),
+
+  -- * Aggregate functions
+  unsafeAggregateOp,
+  count,
+  sum', sumMaybe, avg, avgMaybe,
+  max', maxMaybe, min', minMaybe,
+  every, any', some',
+
+  -- * Zipping projection type trick
+  ProjectableIdZip (leftId, rightId),
+  ProjectableRunIdsZip (runIds), flattenPh
+  -- generalizedZip', (>?<)
+  )  where
+
+import Prelude hiding (pi)
+import Data.Int (Int32)
+
+import qualified Language.SQL.Keyword as SQL
+
+import Database.Relational.Query.Internal.String (paren)
+import Database.Relational.Query.Context (Flat, Aggregated)
+import Database.Relational.Query.Expr (Expr, fromJust)
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+import Database.Relational.Query.Projectable
+  (expr, PlaceHolders,
+   ProjectableMaybe (flattenMaybe), ProjectableIdZip (leftId, rightId),
+   SqlProjectable, unsafeProjectSql, ProjectableShowSql (unsafeShowSql))
+import Database.Relational.Query.Pi (Pi)
+
+
+-- | Projection interface.
+class Projectable p0 p1 where
+  -- ｜ Project from projection type 'p0' into weaken projection types 'p1'.
+  project :: p0 c a -> p1 c a
+
+-- | Uni-operator type for SQL String
+type SqlUniOp = String -> String
+
+-- | Uni-operator from SQL keyword.
+sqlUniOp :: SQL.Keyword -> SqlUniOp
+sqlUniOp kw = (SQL.wordShow kw ++) . (' ' :) . paren
+
+-- | Unsafely make aggregation uni-operator from SQL keyword.
+unsafeAggregateOp :: SqlProjectable (p Aggregated)
+                  => SQL.Keyword -> Projection Flat a -> p Aggregated b
+unsafeAggregateOp op = unsafeProjectSql . sqlUniOp op . unsafeShowSql
+
+-- | Aggregation function COUNT.
+count :: SqlProjectable (p Aggregated) => Projection Flat a -> p Aggregated Int32
+count =  unsafeAggregateOp SQL.COUNT
+
+-- | Aggregation function SUM.
+sumMaybe  :: (Num a, SqlProjectable (p Aggregated)) => Projection Flat (Maybe a) -> p Aggregated (Maybe a)
+sumMaybe  =  unsafeAggregateOp SQL.SUM
+
+-- | Aggregation function SUM.
+sum'  :: (Num a, SqlProjectable (p Aggregated)) => Projection Flat a -> p Aggregated (Maybe a)
+sum'  =  sumMaybe . Projection.just
+
+-- | Aggregation function AVG.
+avgMaybe   :: (Num a, Fractional b, SqlProjectable (p Aggregated))=> Projection Flat (Maybe a) -> p Aggregated (Maybe b)
+avgMaybe   =  unsafeAggregateOp SQL.AVG
+
+-- | Aggregation function AVG.
+avg   :: (Num a, Fractional b, SqlProjectable (p Aggregated))=> Projection Flat a -> p Aggregated (Maybe b)
+avg   =  avgMaybe . Projection.just
+
+-- | Aggregation function MAX.
+maxMaybe  :: (Ord a, SqlProjectable (p Aggregated)) => Projection Flat (Maybe a) -> p Aggregated (Maybe a)
+maxMaybe  =  unsafeAggregateOp SQL.MAX
+
+-- | Aggregation function MAX.
+max'  :: (Ord a, SqlProjectable (p Aggregated)) => Projection Flat a -> p Aggregated (Maybe a)
+max'  =  maxMaybe . Projection.just
+
+-- | Aggregation function MIN.
+minMaybe  :: (Ord a, SqlProjectable (p Aggregated)) => Projection Flat (Maybe a) -> p Aggregated (Maybe a)
+minMaybe  =  unsafeAggregateOp SQL.MIN
+
+-- | Aggregation function MIN.
+min'  :: (Ord a, SqlProjectable (p Aggregated)) => Projection Flat a -> p Aggregated (Maybe a)
+min'  =  minMaybe . Projection.just
+
+-- | Aggregation function EVERY.
+every :: (SqlProjectable (p Aggregated)) => Projection Flat (Maybe Bool) -> p Aggregated (Maybe Bool)
+every =  unsafeAggregateOp SQL.EVERY
+
+-- | Aggregation function ANY.
+any'  :: (SqlProjectable (p Aggregated)) => Projection Flat (Maybe Bool) -> p Aggregated (Maybe Bool)
+any'  =  unsafeAggregateOp SQL.ANY
+
+-- | Aggregation function SOME.
+some' :: (SqlProjectable (p Aggregated)) => Projection Flat (Maybe Bool) -> p Aggregated (Maybe Bool)
+some' =  unsafeAggregateOp SQL.SOME
+
+-- | Project from 'Projection' into 'Projection'.
+instance Projectable Projection Projection where
+  project = id
+
+-- | Project from 'Projection' into 'Expr' 'Projection'.
+instance Projectable Projection Expr where
+  project = expr
+
+projectPi :: Projectable Projection p1 => Projection c a -> Pi a b -> p1 c b
+projectPi p = project . Projection.pi p
+
+projectPiMaybe :: Projectable Projection p1 => Projection c (Maybe a) -> Pi a b -> p1 c (Maybe b)
+projectPiMaybe p = project . Projection.piMaybe p
+
+projectPiMaybe' :: Projectable Projection p1 => Projection c (Maybe a) -> Pi a (Maybe b) -> p1 c (Maybe b)
+projectPiMaybe' p = project . Projection.piMaybe' p
+
+-- | Get narrower projection along with projection path
+--   and project into result projection type.
+(!) :: Projectable Projection p
+    => Projection c a   -- ^ Source projection
+    -> Pi a b -- ^ Projection path
+    -> p c b   -- ^ Narrower projected object
+(!) =  projectPi
+
+-- | Get narrower projection along with projection path
+--   and project into result projection type.
+--   'Maybe' phantom type is propagated.
+(?!) :: Projectable Projection p
+     => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type
+     -> Pi a b       -- ^ Projection path
+     -> p c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result
+(?!) =  projectPiMaybe
+
+-- | Get narrower projection along with projection path
+--   and project into result projection type.
+--   'Maybe' phantom type is propagated. Projection path leaf is 'Maybe' case.
+(?!?) :: Projectable Projection p
+      => Projection c (Maybe a)   -- ^ Source 'Projection'. 'Maybe' phantom type
+      -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf
+      -> p c (Maybe b)   -- ^ Narrower projected object. 'Maybe' phantom type result
+(?!?) =  projectPiMaybe'
+
+-- | Get narrower projected expression along with projectino path
+--   and strip 'Maybe' phantom type off.
+(.!) :: Projection c (Maybe a) -- ^ Source projection type 'p'. 'Maybe' phantom type
+     -> Pi a b      -- ^ Projection path
+     -> Expr c b    -- ^ Narrower projected expression. 'Maybe' phantom type is stripped off
+(.!) p = fromJust . projectPiMaybe p
+
+-- | Get narrower projected expression along with projectino path
+--   and strip 'Maybe' phantom type off.
+--   Projection path leaf is 'Maybe' case.
+(.?) :: Projection c (Maybe a)    -- ^ Source projection type 'p'. 'Maybe' phantom type
+     -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf
+     -> Expr c b       -- ^ Narrower projected expression. 'Maybe' phantom type is stripped off
+(.?) p = fromJust . projectPiMaybe' p
+
+
+-- | Interface to compose phantom 'Maybe' nested type.
+class ProjectableFlattenMaybe a b where
+  flatten :: ProjectableMaybe p => p a -> p b
+
+-- | Compose 'Maybe' type in projection phantom type.
+instance ProjectableFlattenMaybe (Maybe a) b
+         => ProjectableFlattenMaybe (Maybe (Maybe a)) b where
+  flatten = flatten . flattenMaybe
+
+-- | Not 'Maybe' type is not processed.
+instance ProjectableFlattenMaybe (Maybe a) (Maybe a) where
+  flatten = id
+
+-- | Get narrower projection with flatten leaf phantom Maybe types along with projection path.
+flattenPiMaybe :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c)
+               => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
+               -> Pi a b               -- ^ Projection path
+               -> Projection cont c         -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type
+flattenPiMaybe p = flatten . Projection.piMaybe p
+
+projectFlattenPiMaybe :: (ProjectableMaybe (Projection cont),
+                          Projectable Projection p1, ProjectableFlattenMaybe (Maybe b) c)
+                      => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
+                      -> Pi a b                    -- ^ Projection path
+                      -> p1 cont c                 -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type
+projectFlattenPiMaybe p = project . flattenPiMaybe p
+
+-- | Get narrower projection with flatten leaf phantom Maybe types along with projection path
+--   and project into result projection type.
+(!??) :: (ProjectableFlattenMaybe (Maybe b) c,
+          Projectable Projection p, ProjectableMaybe (p cont))
+      => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type
+      -> Pi a b                    -- ^ Projection path
+      -> p cont c                  -- ^ Narrower flatten and projected object.
+(!??) =  projectFlattenPiMaybe
+
+
+-- | Interface to run recursively identity element laws.
+class ProjectableRunIdsZip a b where
+  runIds :: ProjectableIdZip p => p a -> p b
+
+-- | Run left identity element law.
+instance ProjectableRunIdsZip a b => ProjectableRunIdsZip ((), a) b where
+  runIds = runIds . leftId
+
+-- | Run right identity element law.
+instance ProjectableRunIdsZip a b => ProjectableRunIdsZip (a, ()) b where
+  runIds = runIds . rightId
+
+-- | Base case definition to run recursively identity element laws.
+instance ProjectableRunIdsZip a a where
+  runIds = id
+
+-- | Specialize 'runIds' for 'PlaceHolders' type.
+flattenPh :: ProjectableRunIdsZip a b => PlaceHolders a -> PlaceHolders b
+flattenPh =  runIds
+
+-- -- | Binary operator the same as 'generalizedZip'.
+-- (>?<) :: (ProjectableIdZip p, ProjectableRunIdsZip (a, b) c)
+--       => p a -> p b -> p c
+-- (>?<) =  generalizedZip'
+
+infixl 8 !, ?!, ?!?, !??, .!, .?
+-- infixl 1 >?<

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

@@ -0,0 +1,164 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-- |
+-- Module      : Database.Relational.Query.Projection
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines query projection type structure and interfaces.
+module Database.Relational.Query.Projection (
+  -- * Projection data structure and interface
+  Projection,
+
+  width,
+  columns,
+  untype,
+
+  unsafeFromColumns,
+  unsafeFromQualifiedSubQuery,
+  unsafeFromTable,
+
+  -- * Projections
+  compose,
+
+  pi, piMaybe, piMaybe',
+
+  flattenMaybe, just,
+
+  unsafeToAggregated, unsafeToFlat,
+
+  -- * List Projection
+  ListProjection, list, unsafeListProjectionFromSubQuery,
+  unsafeShowSqlListProjection
+  ) where
+
+import Prelude hiding (pi)
+
+import Database.Relational.Query.Internal.String (paren, sqlRowListString)
+import Database.Relational.Query.Context (Aggregated, Flat)
+import Database.Relational.Query.Component (ColumnSQL)
+import Database.Relational.Query.Table (Table)
+import qualified Database.Relational.Query.Table as Table
+import Database.Relational.Query.Pi (Pi)
+import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi
+import Database.Relational.Query.Sub
+  (SubQuery, Qualified, ProjectionUnit,
+   UntypedProjection, widthOfUntypedProjection, columnsOfUntypedProjection,
+   untypedProjectionFromColumns, untypedProjectionFromSubQuery)
+import qualified Database.Relational.Query.Sub as SubQuery
+
+
+-- | Phantom typed projection. Projected into Haskell record type 't'.
+newtype Projection c t = Projection { untypeProjection :: UntypedProjection }
+
+typedProjection :: UntypedProjection -> Projection c t
+typedProjection =  Projection
+
+units :: Projection c t -> [ProjectionUnit]
+units =  untypeProjection
+
+fromUnits :: [ProjectionUnit] -> Projection c t
+fromUnits =  typedProjection
+
+-- | Width of 'Projection'.
+width :: Projection c r -> Int
+width =  widthOfUntypedProjection . untypeProjection
+
+-- | Get column SQL string list of projection.
+columns :: Projection c r -- ^ Source 'Projection'
+        -> [ColumnSQL]    -- ^ Result SQL string list
+columns =  columnsOfUntypedProjection . untypeProjection
+
+-- | Unsafely get untyped projection.
+untype :: Projection c r -> UntypedProjection
+untype =  untypeProjection
+
+
+-- | Unsafely generate 'Projection' from SQL string list.
+unsafeFromColumns :: [ColumnSQL]    -- ^ SQL string list specifies columns
+                  -> Projection c r -- ^ Result 'Projection'
+unsafeFromColumns =  typedProjection . untypedProjectionFromColumns
+
+-- | Unsafely generate  'Projection' from qualified subquery.
+unsafeFromQualifiedSubQuery :: Qualified SubQuery -> Projection c t
+unsafeFromQualifiedSubQuery =  typedProjection . untypedProjectionFromSubQuery
+
+-- | Unsafely generate unqualified 'Projection' from 'Table'.
+unsafeFromTable :: Table r
+                -> Projection c r
+unsafeFromTable =  unsafeFromColumns . Table.columns
+
+-- | Concatenate 'Projection'.
+compose :: Projection c a -> Projection c b -> Projection c (pair a b)
+compose a b = fromUnits $ units a ++ units b
+
+
+-- | Unsafely trace projection path.
+unsafeProject :: Projection c a' -> Pi a b -> Projection c b'
+unsafeProject p pi' =
+  unsafeFromColumns
+  . (`UnsafePi.pi` pi')
+  . columns $ p
+
+-- | Trace projection path to get narrower 'Projection'.
+pi :: Projection c a -- ^ Source 'Projection'
+   -> Pi a b         -- ^ Projection path
+   -> Projection c b -- ^ Narrower 'Projection'
+pi =  unsafeProject
+
+-- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type.
+piMaybe :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type
+        -> Pi a b                 -- ^ Projection path
+        -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result
+piMaybe =  unsafeProject
+
+-- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type.
+--   Leaf type of projection path is 'Maybe'.
+piMaybe' :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type
+         -> Pi a (Maybe b)         -- ^ Projection path. 'Maybe' type leaf
+         -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result
+piMaybe' =  unsafeProject
+
+unsafeCast :: Projection c r -> Projection c r'
+unsafeCast =  typedProjection . untypeProjection
+
+-- | Composite nested 'Maybe' on projection phantom type.
+flattenMaybe :: Projection c (Maybe (Maybe a)) -> Projection c (Maybe a)
+flattenMaybe =  unsafeCast
+
+-- | Cast into 'Maybe' on projection phantom type.
+just :: Projection c r -> Projection c (Maybe r)
+just =  unsafeCast
+
+unsafeChangeContext :: Projection c r -> Projection c' r
+unsafeChangeContext =  typedProjection . untypeProjection
+
+-- | Unsafely lift to aggregated context.
+unsafeToAggregated :: Projection Flat r -> Projection Aggregated r
+unsafeToAggregated =  unsafeChangeContext
+
+-- | Unsafely down to flat context.
+unsafeToFlat :: Projection Aggregated r -> Projection Flat r
+unsafeToFlat =  unsafeChangeContext
+
+
+-- | Projection type for row list.
+data ListProjection p t = List [p t]
+                        | Sub SubQuery
+
+-- | Make row list projection from 'Projection' list.
+list :: [p t] -> ListProjection p t
+list =  List
+
+-- | Make row list projection from 'SubQuery'.
+unsafeListProjectionFromSubQuery :: SubQuery -> ListProjection p t
+unsafeListProjectionFromSubQuery =  Sub
+
+-- | Map projection show operatoions and concatinate to single SQL expression.
+unsafeShowSqlListProjection :: (p t -> String) -> ListProjection p t -> String
+unsafeShowSqlListProjection sf = d  where
+  d (List ps) = sqlRowListString $ map sf ps
+  d (Sub sub) = paren $ SubQuery.toSQL sub

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

@@ -0,0 +1,329 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+-- |
+-- Module      : Database.Relational.Query.Relation
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines re-usable Relation type
+-- to compose complex query.
+module Database.Relational.Query.Relation (
+  -- * Relation type
+  Relation,
+
+  table,
+  relation, relation',
+  aggregateRelation, aggregateRelation',
+
+  dump,
+
+  sqlFromRelationWith, sqlFromRelation,
+
+  -- * Query using relation
+  query, query', queryMaybe, queryMaybe', queryList, queryList',
+
+  -- * Direct style join
+  JoinRestriction,
+  rightPh, leftPh,
+  inner', left', right', full',
+  inner, left, right, full,
+  on',
+
+  -- * Relation append
+  union, except, intersect,
+  union', except', intersect'
+  ) where
+
+import Database.Relational.Query.Context (Flat, Aggregated)
+import Database.Relational.Query.Monad.Type (ConfigureQuery, configureQuery, qualifyQuery)
+import Database.Relational.Query.Monad.Class
+  (MonadQualify (liftQualify), MonadQuery (unsafeSubQuery), on)
+import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery)
+import qualified Database.Relational.Query.Monad.Simple as Simple
+import Database.Relational.Query.Monad.Aggregate (QueryAggregate, AggregatedQuery)
+import qualified Database.Relational.Query.Monad.Aggregate as Aggregate
+
+import Database.Relational.Query.Component (Config, defaultConfig)
+import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.Internal.Product (NodeAttr(Just', Maybe))
+import Database.Relational.Query.Sub (SubQuery)
+import qualified Database.Relational.Query.Sub as SubQuery
+
+import Database.Relational.Query.Projection
+  (Projection, ListProjection, unsafeListProjectionFromSubQuery)
+import qualified Database.Relational.Query.Projection as Projection
+import Database.Relational.Query.Projectable
+  (PlaceHolders, addPlaceHolders, unsafePlaceHolders, projectZip)
+
+
+-- | Relation type with place-holder parameter 'p' and query result type 'r'.
+newtype Relation p r = SubQuery (ConfigureQuery SubQuery)
+
+
+-- | Simple 'Relation' from 'Table'.
+table :: Table r -> Relation () r
+table =  SubQuery . return . SubQuery.fromTable
+
+placeHoldersFromRelation :: Relation p r -> PlaceHolders p
+placeHoldersFromRelation =  const unsafePlaceHolders
+
+-- | Sub-query Qualify monad from relation.
+subQueryQualifyFromRelation :: Relation p r -> ConfigureQuery SubQuery
+subQueryQualifyFromRelation =  d  where
+  d (SubQuery qsub)   = qsub
+
+-- -- | Sub-query from relation.
+-- subQueryFromRelation :: Relation p r -> SubQuery
+-- subQueryFromRelation =  configureQuery . subQueryQualifyFromRelation
+
+-- | Basic monadic join operation using 'MonadQuery'.
+queryWithAttr :: MonadQualify ConfigureQuery m
+              => NodeAttr -> Relation p r -> m (PlaceHolders p, Projection Flat r)
+queryWithAttr attr = addPlaceHolders . run where
+  run rel = do
+    q <- liftQualify $ do
+      sq <- subQueryQualifyFromRelation rel
+      qualifyQuery sq
+    unsafeSubQuery attr q
+  -- d (Relation q) = unsafeMergeAnotherQuery attr q
+
+-- | Join subquery with place-holder parameter 'p'. query result is not 'Maybe'.
+query' :: MonadQualify ConfigureQuery m => Relation p r -> m (PlaceHolders p, Projection Flat r)
+query' =  queryWithAttr Just'
+
+-- | Join subquery. Query result is not 'Maybe'.
+query :: MonadQualify ConfigureQuery m => Relation () r -> m (Projection Flat r)
+query =  fmap snd . query'
+
+-- | Join subquery with place-holder parameter 'p'. Query result is 'Maybe'.
+queryMaybe' :: MonadQualify ConfigureQuery m => Relation p r -> m (PlaceHolders p, Projection Flat (Maybe r))
+queryMaybe' pr =  do
+  (ph, pj) <- queryWithAttr Maybe pr
+  return (ph, Projection.just pj)
+
+-- | Join subquery. Query result is 'Maybe'.
+queryMaybe :: MonadQualify ConfigureQuery m => Relation () r -> m (Projection Flat (Maybe r))
+queryMaybe =  fmap snd . queryMaybe'
+
+queryList0 :: MonadQualify ConfigureQuery m => Relation p r -> m (ListProjection (Projection c) r)
+queryList0 =  liftQualify
+              . fmap unsafeListProjectionFromSubQuery
+              . subQueryQualifyFromRelation
+
+-- | List subQuery, for /IN/ and /EXIST/ with place-holder parameter 'p'.
+queryList' :: MonadQualify ConfigureQuery m
+           => Relation p r
+           -> m (PlaceHolders p, ListProjection (Projection c) r)
+queryList' rel = do
+  ql <- queryList0 rel
+  return (placeHoldersFromRelation rel, ql)
+
+-- | List subQuery, for /IN/ and /EXIST/.
+queryList :: MonadQualify ConfigureQuery m
+          => Relation () r
+          -> m (ListProjection (Projection c) r)
+queryList =  queryList0
+
+unsafeRelation :: SimpleQuery rp -> Relation p r
+unsafeRelation =  SubQuery . Simple.toSubQuery
+
+-- | Finalize 'QuerySimple' monad and generate 'Relation'.
+relation :: QuerySimple (Projection Flat r) -> Relation () r
+relation =  unsafeRelation
+
+-- | Finalize 'QuerySimple' monad and generate 'Relation' with place-holder parameter 'p'.
+relation' :: QuerySimple (PlaceHolders p, Projection Flat r) -> Relation p r
+relation' =  unsafeRelation . fmap snd
+
+unsafeAggregateRelation :: AggregatedQuery rp -> Relation p r
+unsafeAggregateRelation =  SubQuery . Aggregate.toSubQuery
+
+-- | Finalize 'QueryAggregate' monad and geneate 'Relation'.
+aggregateRelation :: QueryAggregate (Projection Aggregated r) -> Relation () r
+aggregateRelation =  unsafeAggregateRelation
+
+-- | Finalize 'QueryAggregate' monad and geneate 'Relation' with place-holder parameter 'p'.
+aggregateRelation' :: QueryAggregate (PlaceHolders p, Projection Aggregated r) -> Relation p r
+aggregateRelation' =  unsafeAggregateRelation . fmap snd
+
+
+-- | Restriction function type for direct style join operator.
+type JoinRestriction a b = Projection Flat a -> Projection Flat b -> Projection Flat (Maybe Bool)
+
+unsafeCastPlaceHolder :: Relation a r -> Relation b r
+unsafeCastPlaceHolder =  d  where
+  d (SubQuery q)      = SubQuery q
+
+-- | Simplify placeholder type applying left identity element.
+rightPh :: Relation ((), p) r -> Relation p r
+rightPh =  unsafeCastPlaceHolder
+
+-- | Simplify placeholder type applying right identity element.
+leftPh :: Relation (p, ()) r -> Relation p r
+leftPh =  unsafeCastPlaceHolder
+
+-- | Basic direct join operation with place-holder parameters.
+join' :: (qa -> QuerySimple (PlaceHolders pa, Projection Flat a))
+      -> (qb -> QuerySimple (PlaceHolders pb, Projection Flat b))
+      -> qa
+      -> qb
+      -> [JoinRestriction a b]
+      -> Relation (pa, pb) (a, b)
+join' qL qR r0 r1 ons = relation' $ do
+  (ph0, pj0) <- qL r0
+  (ph1, pj1) <- qR r1
+  sequence_ $ zipWith3 (\f a b -> on $ f a b) ons (repeat pj0) (repeat pj1)
+  return $ (ph0 `projectZip` ph1, pj0 `projectZip` pj1)
+
+-- | Direct inner join with place-holder parameters.
+inner' :: Relation pa a            -- ^ Left query to join
+       -> Relation pb b            -- ^ Right query to join
+       -> [JoinRestriction a b]    -- ^ Join restrictions
+       -> Relation (pa, pb) (a, b) -- ^ Result joined relation
+inner' =  join' query' query'
+
+-- | Direct left outer join with place-holder parameters.
+left' :: Relation pa a                  -- ^ Left query to join
+      -> Relation pb b                  -- ^ Right query to join
+      -> [JoinRestriction a (Maybe b)]  -- ^ Join restrictions
+      -> Relation (pa, pb) (a, Maybe b) -- ^ Result joined relation
+left'  =  join' query' queryMaybe'
+
+-- | Direct right outer join with place-holder parameters.
+right' :: Relation pa a                 -- ^ Left query to join
+       -> Relation pb b                 -- ^ Right query to join
+       -> [JoinRestriction (Maybe a) b] -- ^ Join restrictions
+       -> Relation (pa, pb)(Maybe a, b) -- ^ Result joined relation
+right' =  join' queryMaybe' query'
+
+-- | Direct full outer join with place-holder parameters.
+full' :: Relation pa a                         -- ^ Left query to join
+      -> Relation pb b                         -- ^ Right query to join
+      -> [JoinRestriction (Maybe a) (Maybe b)] -- ^ Join restrictions
+      -> Relation (pa, pb) (Maybe a, Maybe b)  -- ^ Result joined relation
+full'  =  join' queryMaybe' queryMaybe'
+
+-- | Basic direct join operation.
+join :: (qa -> QuerySimple (Projection Flat a))
+     -> (qb -> QuerySimple (Projection Flat b))
+     -> qa
+     -> qb
+     -> [JoinRestriction a b]
+     -> Relation () (a, b)
+join qL qR r0 r1 ons = relation $ do
+  pj0 <- qL r0
+  pj1 <- qR r1
+  sequence_ $ zipWith3 (\f a b -> on $ f a b) ons (repeat pj0) (repeat pj1)
+  return $ pj0 `projectZip` pj1
+
+-- | Direct inner join.
+inner :: Relation () a         -- ^ Left query to join
+      -> Relation () b         -- ^ Right query to join
+      -> [JoinRestriction a b] -- ^ Join restrictions
+      -> Relation () (a, b)    -- ^ Result joined relation
+inner =  join query query
+
+-- | Direct left outer join.
+left :: Relation () a                 -- ^ Left query to join
+     -> Relation () b                 -- ^ Right query to join
+     -> [JoinRestriction a (Maybe b)] -- ^ Join restrictions
+     -> Relation () (a, Maybe b)      -- ^ Result joined relation
+left  =  join query queryMaybe
+
+-- | Direct right outer join.
+right :: Relation () a                 -- ^ Left query to join
+      -> Relation () b                 -- ^ Right query to join
+      -> [JoinRestriction (Maybe a) b] -- ^ Join restrictions
+      -> Relation () (Maybe a, b)      -- ^ Result joined relation
+right =  join queryMaybe query
+
+-- | Direct full outer join.
+full :: Relation () a                         -- ^ Left query to join
+     -> Relation () b                         -- ^ Right query to join
+     -> [JoinRestriction (Maybe a) (Maybe b)] -- ^ Join restrictions
+     -> Relation () (Maybe a, Maybe b)        -- ^ Result joined relation
+full  =  join queryMaybe queryMaybe
+
+-- | Apply restriction for direct join style.
+on' :: ([JoinRestriction a b] -> Relation pc (a, b))
+    -> [JoinRestriction a b]
+    -> Relation pc (a, b)
+on' =  ($)
+
+infixl 8 `inner'`, `left'`, `right'`, `full'`, `inner`, `left`, `right`, `full`, `on'`
+
+unsafeLiftAppend :: (SubQuery -> SubQuery -> SubQuery)
+           -> Relation p a
+           -> Relation q a
+           -> Relation r a
+unsafeLiftAppend op a0 a1 = SubQuery $ do
+  s0 <- subQueryQualifyFromRelation a0
+  s1 <- subQueryQualifyFromRelation a1
+  return $ s0 `op` s1
+
+liftAppend :: (SubQuery -> SubQuery -> SubQuery)
+           -> Relation () a
+           -> Relation () a
+           -> Relation () a
+liftAppend = unsafeLiftAppend
+
+-- | Union of two relations.
+union     :: Relation () a -> Relation () a -> Relation () a
+union     =  liftAppend SubQuery.union
+
+-- | Subtraction of two relations.
+except    :: Relation () a -> Relation () a -> Relation () a
+except    =  liftAppend SubQuery.except
+
+-- | Intersection of two relations.
+intersect :: Relation () a -> Relation () a -> Relation () a
+intersect =  liftAppend SubQuery.intersect
+
+liftAppend' :: (SubQuery -> SubQuery -> SubQuery)
+            -> Relation p a
+            -> Relation q a
+            -> Relation (p, q) a
+liftAppend' = unsafeLiftAppend
+
+-- | Union of two relations with place-holder parameters.
+union'     :: Relation p a -> Relation q a -> Relation (p, q) a
+union'     =  liftAppend' SubQuery.union
+
+-- | Subtraction of two relations with place-holder parameters.
+except'    :: Relation p a -> Relation q a -> Relation (p, q) a
+except'    =  liftAppend' SubQuery.except
+
+-- | Intersection of two relations with place-holder parameters.
+intersect' :: Relation p a -> Relation q a -> Relation (p, q) a
+intersect' =  liftAppend' SubQuery.intersect
+
+infixl 7 `union`, `except`, `intersect`, `union'`, `except'`, `intersect'`
+
+-- | Generate SQL string from 'Relation' with configuration.
+sqlFromRelationWith :: Relation p r -> Config -> ShowS
+sqlFromRelationWith (SubQuery qsub) =  configureQuery $ fmap SubQuery.showSQL qsub
+
+-- | SQL string from 'Relation'.
+sqlFromRelation :: Relation p r -> ShowS
+sqlFromRelation =  (`sqlFromRelationWith` defaultConfig)
+
+-- | Dump internal structure tree.
+dump :: Relation p r -> String
+dump =  show . (`configureQuery` defaultConfig) . subQueryQualifyFromRelation
+
+instance Show (Relation p r) where
+  show = ($ "") . sqlFromRelation
+
+{-
+-- | Get projection width from 'Relation'.
+width :: Relation p r -> Int
+width =  SubQuery.width . subQueryFromRelation
+
+-- | Finalize internal Query monad.
+nested :: Relation p r -> Relation p r
+nested =  SubQuery . subQueryFromRelation
+-}

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

@@ -0,0 +1,127 @@
+-- |
+-- Module      : Database.Relational.Query.Relation
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines simple restriction
+-- for update and delete statement.
+module Database.Relational.Query.Restriction (
+  -- * Object to express simple restriction.
+  Restriction, RestrictionContext, restriction, restriction',
+
+  -- * Object to express update target columns and restriction.
+  UpdateTarget, UpdateTargetContext, updateTarget, updateTarget',
+  liftTargetAllColumn, liftTargetAllColumn',
+  updateTargetAllColumn, updateTargetAllColumn',
+
+  -- * Generate SQL from restriction.
+  sqlWhereFromRestriction,
+  sqlFromUpdateTarget
+  ) where
+
+import Database.Record (PersistableWidth)
+
+import Database.Relational.Query.Context (Flat)
+import Database.Relational.Query.Pi (id')
+import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.Component (composeWhere, composeSets)
+import Database.Relational.Query.Projection (Projection)
+import qualified Database.Relational.Query.Projection as Projection
+import Database.Relational.Query.Projectable
+  (PlaceHolders, placeholder, addPlaceHolders, (><), rightId)
+
+import Database.Relational.Query.Monad.Trans.Assigning (assignings, (!#), (<-#))
+import Database.Relational.Query.Monad.Restrict (Restrict, RestrictedStatement)
+import qualified Database.Relational.Query.Monad.Restrict as Restrict
+import Database.Relational.Query.Monad.Target (Target, TargetStatement)
+import qualified Database.Relational.Query.Monad.Target as Target
+
+
+-- | Restriction type with place-holder parameter 'p' and projection record type 'r'.
+newtype Restriction p r = Restriction (Projection Flat r -> Restrict ())
+
+-- | Not finalized 'Restrict' monad type.
+type RestrictionContext p r = RestrictedStatement r (PlaceHolders p)
+
+-- | Finalize 'Restrict' monad and generate 'Restriction'.
+restriction :: (Projection Flat r -> Restrict ()) -> Restriction () r
+restriction =  Restriction
+
+-- | Finalize 'Restrict' monad and generate 'Restriction' with place-holder parameter 'p'
+restriction' :: RestrictionContext p r -> Restriction p r
+restriction' =  Restriction . (fmap (const ()) .)
+
+runRestriction :: Restriction p r
+               -> RestrictionContext p r
+runRestriction (Restriction qf) =
+  fmap fst . addPlaceHolders . qf
+
+-- | SQL WHERE clause 'ShowS' string from 'Restriction'.
+sqlWhereFromRestriction :: Table r -> Restriction p r -> ShowS
+sqlWhereFromRestriction tbl (Restriction q) = composeWhere rs
+  where (_ph, rs) = Restrict.extract (q $ Projection.unsafeFromTable tbl)
+
+
+-- | UpdateTarget type with place-holder parameter 'p' and projection record type 'r'.
+newtype UpdateTarget p r =
+  UpdateTarget (Table r -> Projection Flat r -> Target r ())
+
+-- | Not finalized 'Target' monad type.
+type UpdateTargetContext p r = TargetStatement r (PlaceHolders p)
+
+-- | Finalize 'Target' monad and generate 'UpdateTarget'.
+updateTarget :: (Table r -> Projection Flat r -> Target r ())
+             -> UpdateTarget () r
+updateTarget =  UpdateTarget
+
+-- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'.
+updateTarget' :: UpdateTargetContext p r
+              -> UpdateTarget p r
+updateTarget' qf = UpdateTarget $ \t -> fmap (const ()) . qf t
+
+_runUpdateTarget :: UpdateTarget p r
+                 -> UpdateTargetContext p r
+_runUpdateTarget (UpdateTarget qf) tbl =
+  fmap fst . addPlaceHolders . qf tbl
+
+updateAllColumn :: PersistableWidth r
+                => Restriction p r
+                -> UpdateTargetContext (r, p) r
+updateAllColumn rs tbl proj = do
+  (ph0, ()) <- placeholder (\ph -> tbl !# id' <-# ph)
+  ph1       <- assignings $ runRestriction rs proj
+  return $ ph0 >< ph1
+
+-- | Lift 'Restriction' to 'UpdateTarget'. Update target columns are all.
+liftTargetAllColumn :: PersistableWidth r
+                     => Restriction () r
+                     -> UpdateTarget r r
+liftTargetAllColumn rs = updateTarget' $ \tbl proj -> fmap rightId $ updateAllColumn rs tbl proj
+
+-- | Lift 'Restriction' to 'UpdateTarget'. Update target columns are all. With placefolder type 'p'.
+liftTargetAllColumn' :: PersistableWidth r
+                     => Restriction p r
+                     -> UpdateTarget (r, p) r
+liftTargetAllColumn' rs = updateTarget' $ updateAllColumn rs
+
+-- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all.
+updateTargetAllColumn :: PersistableWidth r
+                      => (Projection Flat r -> Restrict ())
+                      -> UpdateTarget r r
+updateTargetAllColumn = liftTargetAllColumn . restriction
+
+-- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all. With placefolder type 'p'.
+updateTargetAllColumn' :: PersistableWidth r
+                       => (Projection Flat r -> Restrict (PlaceHolders p))
+                       -> UpdateTarget (r, p) r
+updateTargetAllColumn' = liftTargetAllColumn' . restriction'
+
+
+-- | SQL SET clause and WHERE clause 'ShowS' string from 'UpdateTarget'
+sqlFromUpdateTarget :: Table r -> UpdateTarget p r -> ShowS
+sqlFromUpdateTarget tbl (UpdateTarget q) = composeSets as . composeWhere rs
+  where ((_ph, as), rs) = Target.extract (q tbl (Projection.unsafeFromTable tbl))

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

@@ -0,0 +1,114 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module      : Database.Relational.Query.SQL
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines functions to generate simple SQL strings.
+module Database.Relational.Query.SQL (
+  -- * Query suffix
+  QuerySuffix, showsQuerySuffix,
+
+  -- * Update SQL
+  updatePrefixSQL,
+  updateSQL',
+  updateOtherThanKeySQL', updateOtherThanKeySQL,
+
+  -- * Insert SQL
+  insertSQL', insertSQL,
+
+  -- * Delete SQL
+  deleteSQL', deleteSQL
+  ) where
+
+import Data.Array (listArray, (!))
+
+import Language.SQL.Keyword (Keyword(..), (.=.))
+import qualified Language.SQL.Keyword as SQL
+import Database.Record.ToSql (untypedUpdateValuesIndex)
+import Database.Relational.Query.Internal.String (showUnwordsSQL, showSpace)
+import Database.Relational.Query.Pi.Unsafe (Pi, unsafeExpandIndexes)
+import Database.Relational.Query.Component (ColumnSQL, sqlWordFromColumn)
+import Database.Relational.Query.Table (Table, name, columns)
+
+
+-- | Type for query suffix words
+type QuerySuffix = [Keyword]
+
+-- | Expand query suffix words
+showsQuerySuffix :: QuerySuffix -> ShowS
+showsQuerySuffix =  d  where
+  d []       = ("" ++)
+  d qs@(_:_) = showSpace . showUnwordsSQL qs
+
+-- | Generate update SQL. Seed SQL string append to this.
+updatePrefixSQL :: Table r -> ShowS
+updatePrefixSQL table = showUnwordsSQL [UPDATE, SQL.word $ name table]
+
+-- | Generate update SQL by specified key and table.
+--   Columns name list of table are also required.
+updateSQL' :: String      -- ^ Table name
+           -> [ColumnSQL] -- ^ Column name list to update
+           -> [ColumnSQL] -- ^ Key column name list
+           -> String      -- ^ Result SQL
+updateSQL' table cols key =
+  SQL.unwordsSQL
+  $ [UPDATE, SQL.word table, SET, updAssigns `SQL.sepBy` ", ",
+     WHERE, keyAssigns `SQL.sepBy` " AND " ]
+  where
+    assigns cs = [ sqlWordFromColumn c .=. "?" | c <- cs ]
+    updAssigns = assigns cols
+    keyAssigns = assigns key
+
+-- | Generate update SQL by specified key and table.
+--   Columns name list of table are also required.
+updateOtherThanKeySQL' :: String      -- ^ Table name
+                       -> [ColumnSQL] -- ^ Column name list
+                       -> [Int]       -- ^ Key column indexes
+                       -> String      -- ^ Result SQL
+updateOtherThanKeySQL' table cols ixs =
+  updateSQL' table updColumns keyColumns
+  where
+    width = length cols
+    cols' = listArray (0, width -1) cols
+    otherThanKey = untypedUpdateValuesIndex ixs width
+    columns' is = [ cols' ! i | i <- is ]
+    updColumns = columns' otherThanKey
+    keyColumns = columns' ixs
+
+-- | Generate update SQL specified by single key.
+updateOtherThanKeySQL :: Table r -- ^ Table metadata
+          -> Pi r p  -- ^ Key columns
+          -> String  -- ^ Result SQL
+updateOtherThanKeySQL tbl key =
+  updateOtherThanKeySQL' (name tbl) (columns tbl) (unsafeExpandIndexes key)
+
+-- | Generate insert SQL.
+insertSQL' :: String      -- ^ Table name
+           -> [ColumnSQL] -- ^ Column name list
+           -> String      -- ^ Result SQL
+insertSQL' table cols =
+  SQL.unwordsSQL
+  $ [INSERT, INTO, SQL.word table, cols' `SQL.parenSepBy` ", ",
+     VALUES, pfs `SQL.parenSepBy` ", "]
+  where cols' = map sqlWordFromColumn cols
+        pfs   = replicate (length cols) "?"
+
+-- | Generate insert SQL.
+insertSQL :: Table r -- ^ Table metadata
+          -> String  -- ^ Result SQL
+insertSQL tbl = insertSQL' (name tbl) (columns tbl)
+
+-- | Generate all column delete SQL by specified table. Untyped table version.
+deleteSQL' :: String -> ShowS
+deleteSQL' table = (SQL.unwordsSQL [DELETE, FROM, SQL.word table] ++)
+
+-- | Generate all column delete SQL by specified table.
+deleteSQL :: Table r -- ^ Table metadata
+          -> ShowS   -- ^ Result SQL
+deleteSQL = deleteSQL' . name

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

@@ -0,0 +1,367 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Module      : Database.Relational.Query.Sub
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines sub-query structure used in query products.
+module Database.Relational.Query.Sub (
+  -- * Sub-query
+  SubQuery, fromTable, flatSubQuery, aggregatedSubQuery,
+  union, except, intersect,
+  showSQL, toSQL, unitSQL, width,
+
+  -- * Qualified Sub-query
+  Qualifier (Qualifier),
+  Qualified, qualifier, unQualify, qualify,
+  queryWidth,
+
+  -- * Sub-query columns
+  column,
+
+  -- * Untyped projection
+  ProjectionUnit, UntypedProjection,
+
+  untypedProjectionFromColumns, untypedProjectionFromSubQuery,
+  widthOfUntypedProjection, columnsOfUntypedProjection,
+
+
+  -- * Product of sub-queries
+  QueryProduct, QueryProductNode, JoinProduct,
+  ) where
+
+import Data.Maybe (fromMaybe)
+import Data.Array (Array, listArray)
+import qualified Data.Array as Array
+
+import qualified Database.Relational.Query.Context as Context
+import Database.Relational.Query.Expr (valueExpr)
+import Database.Relational.Query.Expr.Unsafe (showExpr)
+import Database.Relational.Query.Internal.Product
+  (NodeAttr(Just', Maybe), ProductTree (Leaf, Join),
+   Node, nodeAttr, nodeTree)
+import Database.Relational.Query.Component
+  (ColumnSQL, columnSQL, sqlWordFromColumn, stringFromColumnSQL,
+   Config, UnitProductSupport (UPSupported, UPNotSupported),
+   QueryRestriction, composeWhere, composeHaving,
+   AggregateElem, composeGroupBy,
+   Order (Asc, Desc), OrderingTerms)
+import Database.Relational.Query.Table (Table, (!))
+import qualified Database.Relational.Query.Table as Table
+
+import Database.Relational.Query.Internal.String
+  (showUnwordsSQL, showWordSQL, showWordSQL', showUnwords, showSpace, showParen')
+import Language.SQL.Keyword (Keyword(..))
+import qualified Language.SQL.Keyword as SQL
+
+
+data BinOp = Union | Except | Intersect  deriving Show
+
+keywordBinOp :: BinOp -> Keyword
+keywordBinOp = d  where
+  d Union     = UNION
+  d Except    = EXCEPT
+  d Intersect = INTERSECT
+
+-- | Sub-query type
+data SubQuery = Table Table.Untyped
+              | Flat Config
+                UntypedProjection JoinProduct (QueryRestriction Context.Flat)
+                OrderingTerms
+              | Aggregated Config
+                UntypedProjection JoinProduct (QueryRestriction Context.Flat)
+                [AggregateElem] (QueryRestriction Context.Aggregated) OrderingTerms
+              | Bin BinOp SubQuery SubQuery
+              deriving Show
+
+-- | 'SubQuery' from 'Table'.
+fromTable :: Table r  -- ^ Typed 'Table' metadata
+          -> SubQuery -- ^ Result 'SubQuery'
+fromTable =  Table . Table.unType
+
+-- | Unsafely generate flat 'SubQuery' from untyped components.
+flatSubQuery :: Config
+             -> UntypedProjection
+             -> JoinProduct
+             -> QueryRestriction Context.Flat
+             -> OrderingTerms
+             -> SubQuery
+flatSubQuery = Flat
+
+-- | Unsafely generate aggregated 'SubQuery' from untyped components.
+aggregatedSubQuery :: Config
+                   -> UntypedProjection
+                   -> JoinProduct
+                   -> QueryRestriction Context.Flat
+                   -> [AggregateElem]
+                   -> QueryRestriction Context.Aggregated
+                   -> OrderingTerms
+                   -> SubQuery
+aggregatedSubQuery = Aggregated
+
+-- | Union binary operator on 'SubQuery'
+union     :: SubQuery -> SubQuery -> SubQuery
+union     =  Bin Union
+
+-- | Except binary operator on 'SubQuery'
+except    :: SubQuery -> SubQuery -> SubQuery
+except    =  Bin Except
+
+-- | Intersect binary operator on 'SubQuery'
+intersect :: SubQuery -> SubQuery -> SubQuery
+intersect =  Bin Intersect
+
+-- | Width of 'SubQuery'.
+width :: SubQuery -> Int
+width =  d  where
+  d (Table u)                 = Table.width' u
+  d (Bin _ l _)                 = width l
+  d (Flat _ up _ _ _)           = widthOfUntypedProjection up
+  d (Aggregated _ up _ _ _ _ _) = widthOfUntypedProjection up
+
+-- | SQL to query table.
+fromTableToSQL :: Table.Untyped -> ShowS
+fromTableToSQL t =
+  showUnwordsSQL
+  $ [SELECT, map sqlWordFromColumn (Table.columns' t) `SQL.sepBy` ", ",
+     FROM, SQL.word $ Table.name' t]
+
+-- | Generate normalized column SQL from table.
+fromTableToNormalizedSQL :: Table.Untyped -> ShowS
+fromTableToNormalizedSQL t =
+  showUnwordsSQL
+  $ [SELECT, columns' `SQL.sepBy` ", ", FROM, SQL.word . Table.name' $ t]  where
+  columns' = zipWith
+             (\f n -> sqlWordFromColumn f `asColumnN` n)
+             (Table.columns' t)
+             [(0 :: Int)..]
+
+-- | Normalized column SQL
+normalizedSQL :: SubQuery -> ShowS
+normalizedSQL =  d  where
+  d (Table t)                      = fromTableToNormalizedSQL t
+  d sub@(Bin _ _ _)                = showUnitSQL sub
+  d sub@(Flat _ _ _ _ _)           = showUnitSQL sub
+  d sub@(Aggregated _ _ _ _ _ _ _) = showUnitSQL sub
+
+-- | Generate select SQL. Seed SQL string append to this.
+selectPrefixSQL :: UntypedProjection -> ShowS
+selectPrefixSQL up =
+  showUnwordsSQL [SELECT, columns' `SQL.sepBy` ", "]
+  where columns' = zipWith
+                   (\f n -> sqlWordFromColumn f `asColumnN` n)
+                   (columnsOfUntypedProjection up)
+                   [(0 :: Int)..]
+
+-- | SQL string for nested-query and toplevel-SQL.
+toSQLs :: SubQuery
+       -> (ShowS, ShowS) -- ^ subquery SQL and top-level SQL
+toSQLs =  d  where
+  d (Table u)               = (showString $ Table.name' u, fromTableToSQL u)
+  d (Bin op l r)            = (showParen' q, q)  where
+    q = showUnwords [normalizedSQL l, showWordSQL $ keywordBinOp op, normalizedSQL r]
+  d (Flat cf up pd rs od)   = (showParen' q, q)  where
+    q = selectPrefixSQL up . showsJoinProduct cf pd . composeWhere rs
+        . composeOrderBy od
+  d (Aggregated cf up pd rs ag grs od) = (showParen' q, q)  where
+    q = selectPrefixSQL up . showsJoinProduct cf pd . composeWhere rs
+        . composeGroupBy ag . composeHaving grs . composeOrderBy od
+
+showUnitSQL :: SubQuery -> ShowS
+showUnitSQL =  fst . toSQLs
+
+-- | SQL string for nested-qeury.
+unitSQL :: SubQuery -> String
+unitSQL =  ($ "") . showUnitSQL
+
+-- | SQL ShowS for toplevel-SQL.
+showSQL :: SubQuery -> ShowS
+showSQL = snd . toSQLs
+
+-- | SQL string for toplevel-SQL.
+toSQL :: SubQuery -> String
+toSQL =  ($ "") . showSQL
+
+-- | Qualifier type.
+newtype Qualifier = Qualifier Int  deriving Show
+
+-- | Qualified query.
+data Qualified a = Qualified a Qualifier  deriving Show
+
+-- | 'Functor' instance of 'Qualified'
+instance Functor Qualified where
+  fmap f (Qualified a i) = Qualified (f a) i
+
+-- | Get qualifier
+qualifier :: Qualified a -> Qualifier
+qualifier (Qualified _ i) = i
+
+-- | Unqualify.
+unQualify :: Qualified a -> a
+unQualify (Qualified a _) = a
+
+-- | Add qualifier
+qualify :: a -> Qualifier -> Qualified a
+qualify =  Qualified
+
+-- | Column name of projection index.
+columnN :: Int -> ColumnSQL
+columnN i = columnSQL $ 'f' : show i
+
+-- | Renamed column in SQL expression.
+asColumnN :: SQL.Keyword -> Int -> SQL.Keyword
+f `asColumnN` n = f `SQL.as` sqlWordFromColumn (columnN  n)
+
+-- | Alias string from qualifier
+showQualifier :: Qualifier -> String
+showQualifier (Qualifier i) = 'T' : show i
+
+-- | Binary operator to qualify.
+(<.>) :: Qualifier -> ColumnSQL -> ColumnSQL
+i <.> n = columnSQL $ showQualifier i ++ '.' : stringFromColumnSQL n
+
+-- | Qualified expression from qualifier and projection index.
+columnFromId :: Qualifier -> Int -> ColumnSQL
+columnFromId qi i = qi <.> columnN i
+
+-- | From 'Qualified' SQL string into 'String'.
+qualifiedSQLas :: Qualified ShowS -> ShowS
+qualifiedSQLas q =
+  showUnwords
+  [unQualify q, (showQualifier (qualifier q) ++)]
+
+-- | Width of 'Qualified' 'SubQUery'.
+queryWidth :: Qualified SubQuery -> Int
+queryWidth =  width . unQualify
+
+-- | Get column SQL string of 'SubQuery'.
+column :: Qualified SubQuery -> Int -> ColumnSQL
+column qs =  d (unQualify qs)  where
+  q = qualifier qs
+  d (Table u)         i           = q <.> (u ! i)
+  d (Bin _ _ _)       i           = q `columnFromId` i
+  d (Flat _ up _ _ _) i           = columnOfUntypedProjection up i
+  d (Aggregated _ up _ _ _ _ _) i = columnOfUntypedProjection up i
+
+-- | Get qualified SQL string, like (SELECT ...) AS T0
+qualifiedForm :: Qualified SubQuery -> ShowS
+qualifiedForm =  qualifiedSQLas . fmap showUnitSQL
+
+
+-- | Projection structure unit
+data ProjectionUnit = Columns (Array Int ColumnSQL)
+                    | Normalized (Qualified Int)
+                    deriving Show
+
+projectionUnitFromColumns :: [ColumnSQL] -> ProjectionUnit
+projectionUnitFromColumns cs = Columns $ listArray (0, length cs - 1) cs
+
+-- | Untyped projection. Forgot record type.
+type UntypedProjection = [ProjectionUnit]
+
+unitUntypedProjection :: ProjectionUnit -> UntypedProjection
+unitUntypedProjection =  (:[])
+
+-- | Make untyped projection from columns.
+untypedProjectionFromColumns :: [ColumnSQL] -> UntypedProjection
+untypedProjectionFromColumns =  unitUntypedProjection . projectionUnitFromColumns
+
+-- | Make untyped projection from sub query.
+untypedProjectionFromSubQuery :: Qualified SubQuery -> UntypedProjection
+untypedProjectionFromSubQuery qs = d $ unQualify qs  where  --  unitUntypedProjection . Sub
+  normalized = unitUntypedProjection . Normalized $ fmap width qs
+  d (Table _)                  = untypedProjectionFromColumns . map (column qs)
+                                 $ take (queryWidth qs) [0..]
+  d (Bin _ _ _)                = normalized
+  d (Flat _ _ _ _ _)           = normalized
+  d (Aggregated _ _ _ _ _ _ _) = normalized
+
+-- | ProjectionUnit width.
+widthOfProjectionUnit :: ProjectionUnit -> Int
+widthOfProjectionUnit =  d  where
+  d (Columns a)     = mx - mn + 1 where (mn, mx) = Array.bounds a
+  d (Normalized qw) = unQualify qw
+
+-- | Get column of ProjectionUnit.
+columnOfProjectionUnit :: ProjectionUnit -> Int -> ColumnSQL
+columnOfProjectionUnit =  d  where
+  d (Columns a) i | mn <= i && i <= mx = a Array.! i
+                  | otherwise          = error $ "index out of bounds (unit): " ++ show i
+    where (mn, mx) = Array.bounds a
+  d (Normalized qw) i | i < w          = qualifier qw `columnFromId` i
+                      | otherwise      = error $ "index out of bounds (normalized unit): " ++ show i
+    where w = unQualify qw
+
+-- | Width of 'UntypedProjection'.
+widthOfUntypedProjection :: UntypedProjection -> Int
+widthOfUntypedProjection =  sum . map widthOfProjectionUnit
+
+-- | Get column SQL string of 'UntypedProjection'.
+columnOfUntypedProjection :: UntypedProjection -- ^ Source 'Projection'
+                          -> Int               -- ^ Column index
+                          -> ColumnSQL         -- ^ Result SQL string
+columnOfUntypedProjection up i' = rec up i' where
+  rec []       _        = error $ "index out of bounds: " ++ show i'
+  rec (u : us) i
+    | i < widthOfProjectionUnit u = columnOfProjectionUnit u i
+    | i < 0             = error $ "index out of bounds: " ++ show i
+    | otherwise         = rec us (i - widthOfProjectionUnit u)
+
+-- | Get column SQL string list of projection.
+columnsOfUntypedProjection :: UntypedProjection -- ^ Source 'Projection'
+                           -> [ColumnSQL]       -- ^ Result SQL string list
+columnsOfUntypedProjection p = map (\n -> columnOfUntypedProjection p n) . take w $ [0 .. ]
+  where w = widthOfUntypedProjection p
+
+
+-- | Product tree specialized by 'SubQuery'.
+type QueryProduct = ProductTree (Qualified SubQuery)
+-- | Product node specialized by 'SubQuery'.
+type QueryProductNode = Node (Qualified SubQuery)
+
+-- | Show product tree of query into SQL. ShowS result.
+showsQueryProduct :: QueryProduct -> ShowS
+showsQueryProduct =  rec  where
+  joinType Just' Just' = INNER
+  joinType Just' Maybe = LEFT
+  joinType Maybe Just' = RIGHT
+  joinType Maybe Maybe = FULL
+  urec n = case nodeTree n of
+    p@(Leaf _)     -> rec p
+    p@(Join _ _ _) -> showParen True (rec p)
+  rec (Leaf q)               = qualifiedForm q
+  rec (Join left' right' rs) =
+    showUnwords
+    [urec left',
+     showUnwordsSQL [joinType (nodeAttr left') (nodeAttr right'), JOIN],
+     urec right',
+     showWordSQL ON,
+     showString . showExpr
+     . fromMaybe (valueExpr True) {- or error on compile -}  $ rs]
+
+-- | Type for join product of query.
+type JoinProduct = Maybe QueryProduct
+
+-- | Shows join product of query.
+showsJoinProduct :: UnitProductSupport -> JoinProduct -> ShowS
+showsJoinProduct ups =  maybe (up ups) from  where
+  from qp = showSpace . showWordSQL' FROM . showsQueryProduct qp
+  up UPSupported    = id
+  up UPNotSupported = error "relation: Unit product support mode is disabled!"
+
+
+-- | Get SQL keyword from order attribute.
+order :: Order -> Keyword
+order Asc  = ASC
+order Desc = DESC
+
+composeOrderBy :: OrderingTerms -> ShowS
+composeOrderBy ots = orders  where
+  orderList = foldr (\ (o, e) r -> [sqlWordFromColumn e, order o] `SQL.sepBy` " "  : r) [] ots
+  orders | null orderList = id
+         | otherwise      = showSpace . showUnwordsSQL [ORDER, BY, orderList `SQL.sepBy` ", "]

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

@@ -0,0 +1,380 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Database.Relational.Query.TH
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines templates for Haskell record type and type class instances
+-- to define column projection on SQL query like Haskell records.
+-- Templates are generated by also using functions of "Database.Record.TH" module,
+-- so mapping between list of untyped SQL type and Haskell record type will be done too.
+module Database.Relational.Query.TH (
+  -- * All templates about table
+  defineTableDefault,
+
+  -- * Inlining typed 'Query'
+  inlineQuery,
+
+  -- * Column projections and basic 'Relation' for Haskell record
+  defineTableTypesAndRecordDefault,
+
+  -- * Constraint key templates
+  defineHasPrimaryKeyInstance,
+  defineHasPrimaryKeyInstanceDefault,
+  defineHasNotNullKeyInstance,
+  defineHasNotNullKeyInstanceDefault,
+
+  -- * Column projections
+  defineColumn, defineColumnDefault,
+
+  -- * Table metadata type and basic 'Relation'
+  defineTableTypes, defineTableTypesDefault,
+
+  -- * Basic SQL templates generate rules
+  definePrimaryQuery,
+  definePrimaryUpdate,
+
+  -- * Var expression templates
+  derivationExpDefault,
+  tableVarExpDefault,
+  relationVarExpDefault,
+
+  -- * Derived SQL templates from table definitions
+  defineSqlsWithPrimaryKey,
+  defineSqlsWithPrimaryKeyDefault,
+  ) where
+
+import Data.Char (toUpper, toLower)
+import Data.List (foldl1')
+
+import Language.Haskell.TH
+  (Q, reify, Info (VarI), TypeQ, Type (AppT, ConT), ExpQ,
+   tupleT, appT, Dec, stringE, listE)
+import Language.Haskell.TH.Name.CamelCase
+  (VarName, varName, ConName, varNameWithPrefix, varCamelcaseName, toVarExp)
+import Language.Haskell.TH.Lib.Extra
+  (compileError, simpleValD, maybeD, integralE)
+
+import Database.Record.TH
+  (recordTypeDefault,
+   defineRecordTypeDefault,
+   defineHasColumnConstraintInstance)
+import qualified Database.Record.TH as Record
+import Database.Record.Instances ()
+
+import Database.Relational.Query
+  (Table, Pi, Relation, Config,
+   sqlFromRelationWith, Query, relationalQuery, KeyUpdate, Insert,
+   HasConstraintKey(constraintKey), projectionKey, Primary, NotNull)
+
+import Database.Relational.Query.Constraint (Key, unsafeDefineConstraintKey)
+import qualified Database.Relational.Query.Table as Table
+import Database.Relational.Query.Type (unsafeTypedQuery)
+import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi
+import Database.Relational.Query.Derives
+  (primary, primaryUpdate, TableDerivable (..), TableDerivation,
+   specifyTableDerivation, derivedTable, derivedRelation, derivedInsert)
+
+
+-- | Rule template to infer constraint key.
+defineHasConstraintKeyInstance :: TypeQ   -- ^ Constraint type
+                               -> TypeQ   -- ^ Record type
+                               -> TypeQ   -- ^ Key type
+                               -> [Int]   -- ^ Indexes specifies key
+                               -> Q [Dec] -- ^ Result 'HasConstraintKey' declaration
+defineHasConstraintKeyInstance constraint recType colType indexes = do
+  -- kc <- defineHasColumnConstraintInstance constraint recType index
+  ck <- [d| instance HasConstraintKey $constraint $recType $colType  where
+              constraintKey = unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes])
+          |]
+  return ck
+
+-- | Rule template to infer primary key.
+defineHasPrimaryKeyInstance :: TypeQ   -- ^ Record type
+                            -> TypeQ   -- ^ Key type
+                            -> [Int]   -- ^ Indexes specifies key
+                            -> Q [Dec] -- ^ Result constraint key declarations
+defineHasPrimaryKeyInstance recType colType indexes = do
+  kc <- Record.defineHasPrimaryKeyInstance recType indexes
+  ck <- defineHasConstraintKeyInstance [t| Primary |] recType colType indexes
+  return $ kc ++ ck
+
+-- | Rule template to infer primary key.
+defineHasPrimaryKeyInstanceDefault :: String  -- ^ Table name
+                                   -> TypeQ   -- ^ Column type
+                                   -> [Int]   -- ^ Primary key index
+                                   -> Q [Dec] -- ^ Declarations of primary constraint key
+defineHasPrimaryKeyInstanceDefault =
+  defineHasPrimaryKeyInstance . recordTypeDefault
+
+-- | Rule template to infer not-null key.
+defineHasNotNullKeyInstance :: TypeQ   -- ^ Record type
+                            -> Int     -- ^ Column index
+                            -> Q [Dec] -- ^ Result 'ColumnConstraint' declaration
+defineHasNotNullKeyInstance =
+  defineHasColumnConstraintInstance [t| NotNull |]
+
+-- | Rule template to infer not-null key.
+defineHasNotNullKeyInstanceDefault :: String  -- ^ Table name
+                                   -> Int     -- ^ NotNull key index
+                                   -> Q [Dec] -- ^ Declaration of not-null constraint key
+defineHasNotNullKeyInstanceDefault =
+  defineHasNotNullKeyInstance . recordTypeDefault
+
+
+-- | Column projection path 'Pi' template.
+defineColumn' :: TypeQ   -- ^ Record type
+              -> VarName -- ^ Column declaration variable name
+              -> Int     -- ^ Column index in record (begin with 0)
+              -> TypeQ   -- ^ Column type
+              -> Q [Dec] -- ^ Column projection path declaration
+defineColumn' recType var' i colType = do
+  let var = varName var'
+  simpleValD var [t| Pi $recType $colType |]
+    [| UnsafePi.definePi $(integralE i) |]
+
+-- | Column projection path 'Pi' and constraint key template.
+defineColumn :: Maybe (TypeQ, VarName) -- ^ May Constraint type and constraint object name
+             -> TypeQ                  -- ^ Record type
+             -> VarName                -- ^ Column declaration variable name
+             -> Int                    -- ^ Column index in record (begin with 0)
+             -> TypeQ                  -- ^ Column type
+             -> Q [Dec]                -- ^ Column projection path declaration
+defineColumn mayConstraint recType var' i colType = do
+  maybe
+    (defineColumn' recType var' i colType)
+    ( \(constraint, cname') -> do
+         let cname = varName cname'
+         ck  <- simpleValD cname [t| Key $constraint $recType $colType |]
+                [| unsafeDefineConstraintKey $(integralE i) |]
+
+         col <- simpleValD (varName var') [t| Pi $recType $colType |]
+                [| projectionKey $(toVarExp cname') |]
+         return $ ck ++ col)
+    mayConstraint
+
+-- | Make column projection path and constraint key template using default naming rule.
+defineColumnDefault :: Maybe TypeQ -- ^ May Constraint type
+                    -> TypeQ       -- ^ Record type
+                    -> String      -- ^ Column name
+                    -> Int         -- ^ Column index in record (begin with 0)
+                    -> TypeQ       -- ^ Column type
+                    -> Q [Dec]     -- ^ Column declaration
+defineColumnDefault mayConstraint recType name =
+  defineColumn (fmap withCName mayConstraint) recType varN
+  where varN        = varCamelcaseName (name ++ "'")
+        withCName t = (t, varCamelcaseName (name ++ "_constraint"))
+
+-- | Rule template to infer table derivations.
+defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec]
+defineTableDerivableInstance recordType table columns =
+  [d| instance TableDerivable $recordType where
+        tableDerivation = specifyTableDerivation
+                          (Table.table $(stringE table) $(listE $ map stringE columns))
+    |]
+
+-- | Template to define infered entries from table type.
+defineTableDerivations :: VarName -- ^ TableDerivation declaration variable name
+                       -> VarName -- ^ Table declaration variable name
+                       -> VarName -- ^ Relation declaration variable name
+                       -> VarName -- ^ Insert statement declaration variable name
+                       -> TypeQ   -- ^ Record type
+                       -> Q [Dec] -- ^ Table and Relation declaration
+defineTableDerivations derivationVar' tableVar' relVar' insVar' recordType = do
+  let derivationVar = varName derivationVar'
+  derivationDs <- simpleValD derivationVar [t| TableDerivation $recordType |]
+                  [| tableDerivation |]
+  let tableVar = varName tableVar'
+  tableDs <- simpleValD tableVar [t| Table $recordType |]
+             [| derivedTable |]
+  let relVar   = varName relVar'
+  relDs   <- simpleValD relVar   [t| Relation () $recordType |]
+             [| derivedRelation |]
+  let insVar = varName insVar'
+  insDs   <- simpleValD insVar   [t| Insert $recordType |]
+             [| derivedInsert |]
+  return $ concat [derivationDs, tableDs, relDs, insDs]
+
+-- | 'Table' and 'Relation' templates.
+defineTableTypes :: VarName  -- ^ TableDerivation declaration variable name
+                 -> VarName  -- ^ Table declaration variable name
+                 -> VarName  -- ^ Relation declaration variable name
+                 -> VarName  -- ^ Insert statement declaration variable name
+                 -> TypeQ    -- ^ Record type
+                 -> String   -- ^ Table name in SQL ex. FOO_SCHEMA.table0
+                 -> [String] -- ^ Column names
+                 -> Q [Dec]  -- ^ Table and Relation declaration
+defineTableTypes derivationVar' tableVar' relVar' insVar' recordType table columns = do
+  iDs <- defineTableDerivableInstance recordType table columns
+  dDs <- defineTableDerivations derivationVar' tableVar' relVar' insVar' recordType
+  return $ iDs ++ dDs
+
+tableSQL :: String -> String -> String
+tableSQL schema table = map toUpper schema ++ '.' : map toLower table
+
+derivationVarNameDefault :: String -> VarName
+derivationVarNameDefault =  (`varNameWithPrefix` "derivationFrom")
+
+-- | Make 'TableDerivation' variable expression template from table name using default naming rule.
+derivationExpDefault :: String -- ^ Table name string
+                     -> ExpQ   -- ^ Result var Exp
+derivationExpDefault =  toVarExp . derivationVarNameDefault
+
+tableVarNameDefault :: String -> VarName
+tableVarNameDefault =  (`varNameWithPrefix` "tableOf")
+
+-- | Make 'Table' variable expression template from table name using default naming rule.
+tableVarExpDefault :: String -- ^ Table name string
+                   -> ExpQ   -- ^ Result var Exp
+tableVarExpDefault =  toVarExp . tableVarNameDefault
+
+relationVarNameDefault :: String -> VarName
+relationVarNameDefault =  varCamelcaseName
+
+-- | Make 'Relation' variable expression template from table name using default naming rule.
+relationVarExpDefault :: String -- ^ Table name string
+                      -> ExpQ -- ^ Result var Exp
+relationVarExpDefault =  toVarExp . relationVarNameDefault
+
+-- | Make templates about table and column metadatas using default naming rule.
+defineTableTypesDefault :: String                           -- ^ Schema name
+                        -> String                           -- ^ Table name
+                        -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type
+                        -> Q [Dec]                          -- ^ Result declarations
+defineTableTypesDefault schema table columns = do
+  let recordType = recordTypeDefault table
+  tableDs <- defineTableTypes
+             (derivationVarNameDefault table)
+             (tableVarNameDefault table)
+             (relationVarNameDefault table)
+             (table `varNameWithPrefix` "insert")
+             recordType
+             (tableSQL schema table)
+             (map (fst . fst) columns)
+  let defCol i ((name, typ), constraint) = defineColumnDefault constraint recordType name i typ
+  colsDs  <- fmap concat . sequence . zipWith defCol [0..] $ columns
+  return $ tableDs ++ colsDs
+
+-- | Make templates about table, column and haskell record using default naming rule.
+defineTableTypesAndRecordDefault :: String            -- ^ Schema name
+                                 -> String            -- ^ Table name
+                                 -> [(String, TypeQ)] -- ^ Column names and types
+                                 -> [ConName]         -- ^ Record derivings
+                                 -> Q [Dec]           -- ^ Result declarations
+defineTableTypesAndRecordDefault schema table columns drives = do
+  recD    <- defineRecordTypeDefault table columns drives
+  tableDs <- defineTableTypesDefault schema table [(c, Nothing) | c <- columns ]
+  return $ recD ++ tableDs
+
+-- | Template of derived primary 'Query'.
+definePrimaryQuery :: VarName -- ^ Variable name of result declaration
+                   -> TypeQ   -- ^ Parameter type of 'Query'
+                   -> TypeQ   -- ^ Record type of 'Query'
+                   -> ExpQ    -- ^ 'Relation' expression
+                   -> Q [Dec] -- ^ Result 'Query' declaration
+definePrimaryQuery toDef' paramType recType relE = do
+  let toDef = varName toDef'
+  simpleValD toDef
+    [t| Query $paramType $recType |]
+    [|  relationalQuery (primary $relE) |]
+
+-- | Template of derived primary 'Update'.
+definePrimaryUpdate :: VarName -- ^ Variable name of result declaration
+                    -> TypeQ   -- ^ Parameter type of 'Update'
+                    -> TypeQ   -- ^ Record type of 'Update'
+                    -> ExpQ    -- ^ 'Table' expression
+                    -> Q [Dec] -- ^ Result 'Update' declaration
+definePrimaryUpdate toDef' paramType recType tableE = do
+  let toDef = varName toDef'
+  simpleValD toDef
+    [t| KeyUpdate $paramType $recType |]
+    [|  primaryUpdate $tableE |]
+
+
+-- | SQL templates derived from primary key.
+defineSqlsWithPrimaryKey :: VarName -- ^ Variable name of select query definition from primary key
+                         -> VarName -- ^ Variable name of update statement definition from primary key
+                         -> TypeQ   -- ^ Primary key type
+                         -> TypeQ   -- ^ Record type
+                         -> ExpQ    -- ^ Relation expression
+                         -> ExpQ    -- ^ Table expression
+                         -> Q [Dec] -- ^ Result declarations
+defineSqlsWithPrimaryKey sel upd paramType recType relE tableE = do
+  selD <- definePrimaryQuery  sel paramType recType relE
+  updD <- definePrimaryUpdate upd paramType recType tableE
+  return $ selD ++ updD
+
+-- | SQL templates derived from primary key using default naming rule.
+defineSqlsWithPrimaryKeyDefault :: String  -- ^ Table name of Database
+                                -> TypeQ   -- ^ Primary key type
+                                -> TypeQ   -- ^ Record type
+                                -> ExpQ    -- ^ Relation expression
+                                -> ExpQ    -- ^ Table expression
+                                -> Q [Dec] -- ^ Result declarations
+defineSqlsWithPrimaryKeyDefault table  =
+  defineSqlsWithPrimaryKey sel upd
+  where
+    sel = table `varNameWithPrefix` "select"
+    upd = table `varNameWithPrefix` "update"
+
+-- | All templates about primary key.
+defineWithPrimaryKeyDefault :: String  -- ^ Table name string
+                            -> TypeQ   -- ^ Type of primary key
+                            -> [Int]   -- ^ Indexes specifies primary key
+                            -> Q [Dec] -- ^ Result declarations
+defineWithPrimaryKeyDefault table keyType ixs = do
+  instD <- defineHasPrimaryKeyInstanceDefault table keyType ixs
+  let recType  = recordTypeDefault table
+      tableE   = tableVarExpDefault table
+      relE     = relationVarExpDefault table
+  sqlsD <- defineSqlsWithPrimaryKeyDefault table keyType recType relE tableE
+  return $ instD ++ sqlsD
+
+-- | All templates about not-null key.
+defineWithNotNullKeyDefault :: String -> Int -> Q [Dec]
+defineWithNotNullKeyDefault =  defineHasNotNullKeyInstanceDefault
+
+-- | Generate all templtes about table using default naming rule.
+defineTableDefault :: String            -- ^ Schema name string of Database
+                   -> String            -- ^ Table name string of Database
+                   -> [(String, TypeQ)] -- ^ Column names and types
+                   -> [ConName]         -- ^ derivings for Record type
+                   -> [Int]             -- ^ Primary key index
+                   -> Maybe Int         -- ^ Not null key index
+                   -> Q [Dec]           -- ^ Result declarations
+defineTableDefault schema table columns derives primaryIxs mayNotNullIdx = do
+  tblD  <- defineTableTypesAndRecordDefault schema table columns derives
+  let pairT x y = appT (appT (tupleT 2) x) y
+      keyType   = foldl1' pairT . map (snd . (columns !!)) $ primaryIxs
+  primD <- case primaryIxs of
+    []  -> return []
+    ixs -> defineWithPrimaryKeyDefault table keyType ixs
+  nnD   <- maybeD (\i -> defineWithNotNullKeyDefault table i) mayNotNullIdx
+  return $ tblD ++ primD ++ nnD
+
+
+-- | Inlining composed 'Query' in compile type.
+inlineQuery :: VarName      -- ^ Top-level variable name which has 'Relation' type
+            -> Relation p r -- ^ Object which has 'Relation' type
+            -> Config       -- ^ Configuration to generate SQL
+            -> VarName      -- ^ Variable name for inlined query
+            -> Q [Dec]      -- ^ Result declarations
+inlineQuery relVar' rel config qVar' =  do
+  let relVar = varName relVar'
+      qVar   = varName qVar'
+  relInfo <- reify relVar
+  case relInfo of
+    VarI _ (AppT (AppT (ConT prn) p) r) _ _
+      | prn == ''Relation    -> do
+        simpleValD qVar
+          [t| Query $(return p) $(return r) |]
+          [|  unsafeTypedQuery $(stringE . sqlFromRelationWith rel config $ "") |]
+    _                             ->
+      compileError $ "expandRelation: Variable must have Relation type: " ++ show relVar

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

@@ -0,0 +1,88 @@
+-- |
+-- Module      : Database.Relational.Query.Table
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines table type which has table metadatas.
+module Database.Relational.Query.Table (
+  -- * Untyped table type
+  Untyped, name', width', columns', (!),
+
+  -- * Phantom typed table type
+  Table, unType, name, shortName, width, columns, index, table, toMaybe,
+  ) where
+
+import Data.Array (Array, listArray, elems)
+import qualified Data.Array as Array
+
+import Database.Relational.Query.Component (ColumnSQL, columnSQL)
+
+
+-- | Untyped typed table type
+data Untyped = Untyped String Int (Array Int ColumnSQL)  deriving Show
+
+-- | Name string of table in SQL
+name' :: Untyped -> String
+name'       (Untyped n _ _) = n
+
+-- | Width of table
+width' :: Untyped -> Int
+width'      (Untyped _ w _) = w
+
+-- | Column name strings in SQL
+columnArray :: Untyped -> Array Int ColumnSQL
+columnArray (Untyped _ _ c) = c
+
+-- | Column name strings in SQL
+columns' :: Untyped -> [ColumnSQL]
+columns' =  elems . columnArray
+
+-- | Column name string in SQL specified by index
+(!) :: Untyped
+    -> Int       -- ^ Column index
+    -> ColumnSQL -- ^ Column name String in SQL
+t ! i = columnArray t Array.! i
+
+
+-- | Phantom typed table type
+newtype Table r = Table Untyped
+
+-- | Untype table.
+unType :: Table t -> Untyped
+unType (Table u) = u
+
+-- | Name string of table in SQL
+name :: Table r -> String
+name   = name'   . unType
+
+-- | Not qualified name string of table in SQL
+shortName :: Table r -> String
+shortName =  tail . dropWhile (/= '.') . name
+
+-- | Width of table
+width :: Table r -> Int
+width  = width'  . unType
+
+-- | Column name strings in SQL
+columns :: Table r -> [ColumnSQL]
+columns =  columns' . unType
+
+-- | Column name string in SQL specified by index
+index :: Table r
+      -> Int    -- ^ Column index
+      -> ColumnSQL -- ^ Column name String in SQL
+index =  (!) . unType
+
+-- | Cast phantom type into 'Maybe' type.
+toMaybe :: Table r -> Table (Maybe r)
+toMaybe (Table t) = (Table t)
+
+-- | Unsafely generate phantom typed table type.
+table :: String -> [String] -> Table r
+table n f = Table $ Untyped n w fa  where
+  w  = length f
+  fa = listArray (0, w - 1) $ map columnSQL f

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

@@ -0,0 +1,159 @@
+-- |
+-- Module      : Database.Relational.Query.Type
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module defines typed SQL.
+module Database.Relational.Query.Type (
+  -- * Typed query statement
+  Query (..), unsafeTypedQuery,
+
+  relationalQuery', relationalQuery,
+
+  -- * Typed update statement
+  KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate,
+  Update (..), unsafeTypedUpdate, typedUpdate, targetUpdate,
+  typedUpdateAllColumn, restricredUpdateAllColumn,
+
+  -- * Typed insert statement
+  Insert (..), unsafeTypedInsert, typedInsert,
+
+  -- * Typed delete statement
+  Delete (..), unsafeTypedDelete, typedDelete, restrictedDelete
+  ) where
+
+import Database.Record (PersistableWidth)
+
+import Database.Relational.Query.Relation (Relation, sqlFromRelation)
+import Database.Relational.Query.Restriction
+  (Restriction, RestrictionContext, restriction',
+   UpdateTarget, UpdateTargetContext, updateTarget', liftTargetAllColumn',
+   sqlWhereFromRestriction, sqlFromUpdateTarget)
+import Database.Relational.Query.Pi (Pi)
+import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.SQL
+  (QuerySuffix, showsQuerySuffix,
+   updateOtherThanKeySQL, insertSQL, updatePrefixSQL, deleteSQL)
+
+
+-- | Query type with place-holder parameter 'p' and query result type 'a'.
+newtype Query p a = Query { untypeQuery :: String }
+
+-- | Unsafely make typed 'Query' from SQL string.
+unsafeTypedQuery :: String    -- ^ Query SQL to type
+                 -> Query p a -- ^ Typed result
+unsafeTypedQuery =  Query
+
+-- | Show query SQL string
+instance Show (Query p a) where
+  show = untypeQuery
+
+-- | From 'Relation' into typed 'Query' with suffix SQL words.
+relationalQuery' :: Relation p r -> QuerySuffix -> Query p r
+relationalQuery' rel qsuf = unsafeTypedQuery . sqlFromRelation rel . showsQuerySuffix qsuf $ ""
+
+-- | From 'Relation' into typed 'Query'.
+relationalQuery :: Relation p r -> Query p r
+relationalQuery =  (`relationalQuery'` [])
+
+
+-- | Update type with key type 'p' and update record type 'a'.
+--   Columns to update are record columns other than key columns,
+--   So all place-holder correspond to record type 'a' columns.
+data KeyUpdate p a = KeyUpdate { updateKey :: Pi a p
+                               , untypeKeyUpdate :: String
+                               }
+
+-- | Unsafely make typed 'KeyUpdate' from SQL string.
+unsafeTypedKeyUpdate :: Pi a p -> String -> KeyUpdate p a
+unsafeTypedKeyUpdate =  KeyUpdate
+
+-- | Make typed 'KeyUpdate' from 'Table' and key indexes.
+typedKeyUpdate :: Table a -> Pi a p -> KeyUpdate p a
+typedKeyUpdate tbl key = unsafeTypedKeyUpdate key $ updateOtherThanKeySQL tbl key
+
+-- | Show update SQL string
+instance Show (KeyUpdate p a) where
+  show = untypeKeyUpdate
+
+
+-- | Update type with place-holder parameter 'p'.
+newtype Update p = Update { untypeUpdate :: String }
+
+-- | Unsafely make typed 'Update' from SQL string.
+unsafeTypedUpdate :: String -> Update p
+unsafeTypedUpdate =  Update
+
+-- | Make typed 'Update' from 'Table' and 'Restriction'.
+typedUpdate :: Table r -> UpdateTarget p r -> Update p
+typedUpdate tbl ut = unsafeTypedUpdate . updatePrefixSQL tbl
+                     . sqlFromUpdateTarget tbl ut $ ""
+
+-- | Directly make typed 'Update' from 'Table' and 'Target' monad context.
+targetUpdate :: Table r
+             -> UpdateTargetContext p r -- ^ 'Target' monad context
+             -> Update p
+targetUpdate tbl = typedUpdate tbl . updateTarget'
+
+-- | Make typed 'Update' from 'Table' and 'Restriction'.
+--   Update target is all column.
+typedUpdateAllColumn :: PersistableWidth r
+                     => Table r
+                     -> Restriction p r
+                     -> Update (r, p)
+typedUpdateAllColumn tbl r = typedUpdate tbl $ liftTargetAllColumn' r
+
+-- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context.
+--   Update target is all column.
+restricredUpdateAllColumn :: PersistableWidth r
+                           => Table r
+                           -> RestrictionContext p r
+                           -> Update (r, p)
+restricredUpdateAllColumn tbl = typedUpdateAllColumn tbl . restriction'
+
+-- | Show update SQL string
+instance Show (Update p) where
+  show = untypeUpdate
+
+
+-- | Insert type to insert record type 'a'.
+newtype Insert a   = Insert { untypeInsert :: String }
+
+-- | Unsafely make typed 'Insert' from SQL string.
+unsafeTypedInsert :: String -> Insert a
+unsafeTypedInsert =  Insert
+
+-- | Make typed 'Insert' from 'Table'
+typedInsert :: Table r -> Insert r
+typedInsert =  unsafeTypedInsert . insertSQL
+
+-- | Show insert SQL string
+instance Show (Insert a) where
+  show = untypeInsert
+
+
+-- | Delete type with place-holder parameter 'p'.
+newtype Delete p = Delete { untypeDelete :: String }
+
+-- | Unsafely make typed 'Delete' from SQL string.
+unsafeTypedDelete :: String -> Delete p
+unsafeTypedDelete =  Delete
+
+-- | Make typed 'Delete' from 'Table' and 'Restriction'.
+typedDelete :: Table r -> Restriction p r -> Delete p
+typedDelete tbl r = unsafeTypedDelete . deleteSQL tbl
+                    . sqlWhereFromRestriction tbl r $ ""
+
+-- | Directly make typed 'Delete' from 'Table' and 'Restrict' monad context.
+restrictedDelete :: Table r
+                 -> RestrictionContext p r -- ^ 'Restrict' monad context.
+                 -> Delete p
+restrictedDelete tbl = typedDelete tbl . restriction'
+
+-- | Show delete SQL string
+instance Show (Delete p) where
+  show = untypeDelete

relational-query/src/Database/Relational/Schema/DB2Syscat/Columns.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Database.Relational.Schema.DB2Syscat.Columns
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Generate template of SYSCAT.columns system catalog table.
+module Database.Relational.Schema.DB2Syscat.Columns where
+
+import Data.Int (Int16, Int32, Int64)
+
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+  "SYSCAT" "columns"
+  [
+    -- column                         schema    type               length         NULL
+    -- ------------------------------ --------- ------------------ -------- ----- ------
+    -- TABSCHEMA                      SYSIBM    VARCHAR                 128     0 No
+    ("tabschema", [t|String|]),
+    -- TABNAME                        SYSIBM    VARCHAR                 128     0 No
+    ("tabname", [t|String|]),
+    -- COLNAME                        SYSIBM    VARCHAR                 128     0 No
+    ("colname", [t|String|]),
+    -- COLNO                          SYSIBM    SMALLINT                  2     0 No
+    ("colno", [t|Int16|]),
+    -- TYPESCHEMA                     SYSIBM    VARCHAR                 128     0 No
+    ("typeschema", [t|String|]),
+    -- TYPENAME                       SYSIBM    VARCHAR                  18     0 No
+    ("typename", [t|String|]),
+    -- LENGTH                         SYSIBM    INTEGER                   4     0 No
+    ("length", [t|Int32|]),
+    -- SCALE                          SYSIBM    SMALLINT                  2     0 No
+    ("scale", [t|Int16|]),
+    -- DEFAULT                        SYSIBM    VARCHAR                 254     0 Yes
+    ("default", [t|Maybe String|]),
+    -- NULLS                          SYSIBM    CHARACTER                 1     0 No
+    ("nulls", [t|String|]),
+    -- CODEPAGE                       SYSIBM    SMALLINT                  2     0 No
+    ("codepage", [t|Int16|]),
+    -- LOGGED                         SYSIBM    CHARACTER                 1     0 No
+    ("logged", [t|String|]),
+    -- COMPACT                        SYSIBM    CHARACTER                 1     0 No
+    ("compact", [t|String|]),
+    -- COLCARD                        SYSIBM    BIGINT                    8     0 No
+    ("colcard", [t|Int64|]),
+    -- HIGH2KEY                       SYSIBM    VARCHAR                 254     0 Yes
+    ("high2key", [t|Maybe String|]),
+    -- LOW2KEY                        SYSIBM    VARCHAR                 254     0 Yes
+    ("low2key", [t|Maybe String|]),
+    -- AVGCOLLEN                      SYSIBM    INTEGER                   4     0 No
+    ("avgcollen", [t|Int32|]),
+    -- KEYSEQ                         SYSIBM    SMALLINT                  2     0 Yes
+    ("keyseq", [t|Maybe Int16|]),
+    -- PARTKEYSEQ                     SYSIBM    SMALLINT                  2     0 Yes
+    ("partkeyseq", [t|Maybe Int16|]),
+    -- NQUANTILES                     SYSIBM    SMALLINT                  2     0 No
+    ("nquantiles", [t|Int16|]),
+    -- NMOSTFREQ                      SYSIBM    SMALLINT                  2     0 No
+    ("nmostfreq", [t|Int16|]),
+    -- NUMNULLS                       SYSIBM    BIGINT                    8     0 No
+    ("numnulls", [t|Int64|]),
+    -- TARGET_TYPESCHEMA              SYSIBM    VARCHAR                 128     0 Yes
+    ("target_typeschema", [t|Maybe String|]),
+    -- TARGET_TYPENAME                SYSIBM    VARCHAR                  18     0 Yes
+    ("target_typename", [t|Maybe String|]),
+    -- SCOPE_TABSCHEMA                SYSIBM    VARCHAR                 128     0 Yes
+    ("scope_tabschema", [t|Maybe String|]),
+    -- SCOPE_TABNAME                  SYSIBM    VARCHAR                 128     0 Yes
+    ("scope_tabname", [t|Maybe String|]),
+    -- SOURCE_TABSCHEMA               SYSIBM    VARCHAR                 128     0 Yes
+    ("source_tabschema", [t|Maybe String|]),
+    -- SOURCE_TABNAME                 SYSIBM    VARCHAR                 128     0 Yes
+    ("source_tabname", [t|Maybe String|]),
+    -- DL_FEATURES                    SYSIBM    CHARACTER                10     0 Yes
+    ("dl_features", [t|Maybe String|]),
+    -- SPECIAL_PROPS                  SYSIBM    CHARACTER                 8     0 Yes
+    ("special_props", [t|Maybe String|]),
+    -- HIDDEN                         SYSIBM    CHARACTER                 1     0 No
+    ("hidden", [t|String|]),
+    -- INLINE_LENGTH                  SYSIBM    INTEGER                   4     0 No
+    ("inline_length", [t|Int32|]),
+    -- IDENTITY                       SYSIBM    CHARACTER                 1     0 No
+    ("identity", [t|String|]),
+    -- GENERATED                      SYSIBM    CHARACTER                 1     0 No
+    ("generated", [t|String|]),
+    -- TEXT                           SYSIBM    CLOB                  65538     0 Yes
+    ("text", [t|Maybe String|]),
+    -- REMARKS                        SYSIBM    VARCHAR                 254     0 Yes
+    ("remarks", [t|Maybe String|])
+
+  ]
+  [derivingShow])

relational-query/src/Database/Relational/Schema/DB2Syscat/Keycoluse.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Database.Relational.Schema.DB2Syscat.Keycoluse
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Generate template of SYSCAT.keycoluse system catalog table.
+-- Not all columns are mapped to Haskell record.
+-- Minimum implementation required to generate table constraints.
+module Database.Relational.Schema.DB2Syscat.Keycoluse where
+
+import Data.Int (Int16)
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+
+-- Not all column is mapped. Minimum implementation.
+$(defineTableTypesAndRecordDefault
+  "SYSCAT" "keycoluse"
+  [("constname", [t| String |]),
+   ("colname"  , [t| String |]),
+   ("colseq"   , [t| Int16 |])]
+  [derivingShow])

relational-query/src/Database/Relational/Schema/DB2Syscat/Tabconst.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Database.Relational.Schema.DB2Syscat.Tabconst
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Generate template of SYSCAT.tabconst system catalog table.
+-- Not all columns are mapped to Haskell record.
+-- Minimum implementation required to generate table constraints.
+module Database.Relational.Schema.DB2Syscat.Tabconst where
+
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+
+-- Not all column is mapped. Minimum implementation.
+$(defineTableTypesAndRecordDefault
+  "SYSCAT" "tabconst"
+  [("constname", [t| String |]),
+   ("tabschema", [t| String |]),
+   ("tabname"  , [t| String |]),
+   --
+   ("type"     , [t| String |]),
+   ("enforced" , [t| String |])]
+  [derivingShow])

relational-query/src/Database/Relational/Schema/IBMDB2.hs

@@ -0,0 +1,119 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Database.Relational.Schema.IBMDB2
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module implements queries to get
+-- table schema and table constraint informations
+-- from system catalog of IBM DB2.
+module Database.Relational.Schema.IBMDB2 (
+  normalizeColumn, notNull, getType,
+
+  columnsQuerySQL, primaryKeyQuerySQL
+  ) where
+
+
+import Data.Int (Int16, Int32, Int64)
+import Data.Char (toLower)
+import Data.Map (Map, fromList)
+import qualified Data.Map as Map
+import Data.Time (LocalTime, Day)
+import Language.Haskell.TH (TypeQ)
+
+import Database.Relational.Query.Type (relationalQuery)
+import Database.Relational.Query
+  (Query, Relation, query, relation',
+   wheres, (.=.), (!), (><), placeholder, asc, value)
+
+import Control.Applicative ((<|>))
+
+import Database.Relational.Schema.DB2Syscat.Columns (Columns, columns)
+import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns
+import Database.Relational.Schema.DB2Syscat.Tabconst (tabconst)
+import qualified Database.Relational.Schema.DB2Syscat.Tabconst as Tabconst
+import Database.Relational.Schema.DB2Syscat.Keycoluse (keycoluse)
+import qualified Database.Relational.Schema.DB2Syscat.Keycoluse as Keycoluse
+
+
+-- | Mapping between type in DB2 and Haskell type.
+mapFromSqlDefault :: Map String TypeQ
+mapFromSqlDefault =
+  fromList [("VARCHAR",   [t|String|]),
+            ("CHAR",      [t|String|]),
+            ("CHARACTER", [t|String|]),
+            ("TIMESTAMP", [t|LocalTime|]),
+            ("DATE",      [t|Day|]),
+            ("SMALLINT",  [t|Int16|]),
+            ("INTEGER",   [t|Int32|]),
+            ("BIGINT",    [t|Int64|]),
+            ("BLOB",      [t|String|]),
+            ("CLOB",      [t|String|])]
+
+-- | Normalize column name string to query DB2 system catalog
+normalizeColumn :: String -> String
+normalizeColumn =  map toLower
+
+-- | Not-null attribute information of column.
+notNull :: Columns -> Bool
+notNull =  (== "N") . Columns.nulls
+
+-- | Get column normalized name and column Haskell type.
+getType :: Map String TypeQ      -- ^ Type mapping specified by user
+        -> Columns               -- ^ Column info in system catalog
+        -> Maybe (String, TypeQ) -- ^ Result normalized name and mapped Haskell type
+getType mapFromSql rec = do
+  typ <- (Map.lookup key mapFromSql
+          <|>
+          Map.lookup key mapFromSqlDefault)
+  return (normalizeColumn $ Columns.colname rec, mayNull typ)
+  where key = Columns.typename rec
+        mayNull typ = if notNull rec
+                      then typ
+                      else [t| Maybe $(typ) |]
+
+-- | 'Relation' to query 'Columns' from schema name and table name.
+columnsRelationFromTable :: Relation (String, String) Columns
+columnsRelationFromTable =  relation' $ do
+  c <- query columns
+  (schemaP, ()) <- placeholder (\ph -> wheres $ c ! Columns.tabschema' .=. ph)
+  (nameP  , ()) <- placeholder (\ph -> wheres $ c ! Columns.tabname'   .=. ph)
+  asc $ c ! Columns.colno'
+  return (schemaP >< nameP, c)
+
+-- | Phantom typed 'Query' to get 'Columns' from schema name and table name.
+columnsQuerySQL :: Query (String, String) Columns
+columnsQuerySQL =  relationalQuery columnsRelationFromTable
+
+
+-- | 'Relation' to query primary key name from schema name and table name.
+primaryKeyRelation :: Relation (String, String) String
+primaryKeyRelation =  relation' $ do
+  cons  <- query tabconst
+  key   <- query keycoluse
+  col   <- query columns
+
+  wheres $ cons ! Tabconst.tabschema' .=. col ! Columns.tabschema'
+  wheres $ cons ! Tabconst.tabname'   .=. col ! Columns.tabname'
+  wheres $ key  ! Keycoluse.colname'  .=. col ! Columns.colname'
+  wheres $ cons ! Tabconst.constname' .=. key ! Keycoluse.constname'
+
+  wheres $ col  ! Columns.nulls'     .=. value "N"
+  wheres $ cons ! Tabconst.type'     .=. value "P"
+  wheres $ cons ! Tabconst.enforced' .=. value "Y"
+
+  (schemaP, ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tabschema' .=. ph)
+  (nameP  , ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tabname'   .=. ph)
+
+  asc  $ key ! Keycoluse.colseq'
+
+  return   (schemaP >< nameP, key ! Keycoluse.colname')
+
+-- | Phantom typed 'Query' to get primary key name from schema name and table name.
+primaryKeyQuerySQL :: Query (String, String) String
+primaryKeyQuerySQL =  relationalQuery primaryKeyRelation

relational-query/src/Database/Relational/Schema/PgCatalog/PgAttribute.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Database.HDBC.Schema.PgCatalog.PgAttribute
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+module Database.Relational.Schema.PgCatalog.PgAttribute where
+
+import Data.Int (Int16, Int32)
+
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+  "PG_CATALOG" "pg_attribute"
+
+  [
+-- Table "pg_catalog.pg_attribute"
+--     Column     |   Type    | Modifiers
+-- ---------------+-----------+-----------
+--  attrelid      | oid       | not null
+    ("attrelid"     , [t|Int32|]),
+--  attname       | name      | not null
+    ("attname"      , [t|String|]),
+--  atttypid      | oid       | not null
+    ("atttypid"     , [t|Int32|]),
+--  attstattarget | integer   | not null
+    ("attstattarget", [t|Int32|]),
+--  attlen        | smallint  | not null
+    ("attlen"       , [t|Int16|]),
+--  attnum        | smallint  | not null
+    ("attnum"      , [t|Int16|]),
+--  attndims      | integer   | not null
+    ("attndims"    , [t|Int32|]),
+--  attcacheoff   | integer   | not null
+    ("attcacheoff" , [t|Int32|]),
+--  atttypmod     | integer   | not null
+    ("atttypmod"   , [t|Int32|]),
+--  attbyval      | boolean   | not null
+    ("attbyval"    , [t|Bool|]),
+--  attstorage    | "char"    | not null
+    ("attstorage"  , [t|Char|]),
+--  attalign      | "char"    | not null
+    ("attalign"    , [t|Char|]),
+--  attnotnull    | boolean   | not null
+    ("attnotnull"  , [t|Bool|]),
+--  atthasdef     | boolean   | not null
+    ("atthasdef"   , [t|Bool|]),
+--  attisdropped  | boolean   | not null
+    ("attisdropped", [t|Bool|]),
+--  attislocal    | boolean   | not null
+    ("attislocal"  , [t|Bool|]),
+--  attinhcount   | integer   | not null
+    ("attinhcount" , [t|Int32|]),
+--  attcollation  | oid       | not null
+    ("attcollation", [t|Int32|])
+--  attacl        | aclitem[] |
+    -- ("attacl"      , [t|String|]),
+--  attoptions    | text[]    |
+    -- ("attoptions"  , [t|String|])
+  ]
+  [derivingShow])

relational-query/src/Database/Relational/Schema/PgCatalog/PgClass.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Database.Relational.Schema.PgCatalog.PgClass
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+module Database.Relational.Schema.PgCatalog.PgClass where
+
+import Data.Int (Int32)
+
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+
+$(defineTableTypesAndRecordDefault
+  "PG_CATALOG" "pg_class"
+  [("oid"         , [t| Int32 |]),
+ -- relname        | name      | not null
+   ("relname"     , [t| String |]),
+ -- relnamespace   | oid       | not null
+   ("relnamespace", [t| Int32 |])
+ -- reltype        | oid       | not null
+ -- reloftype      | oid       | not null
+ -- relowner       | oid       | not null
+ -- relam          | oid       | not null
+ -- relfilenode    | oid       | not null
+ -- reltablespace  | oid       | not null
+ -- relpages       | integer   | not null
+ -- reltuples      | real      | not null
+ -- reltoastrelid  | oid       | not null
+ -- reltoastidxid  | oid       | not null
+ -- relhasindex    | boolean   | not null
+ -- relisshared    | boolean   | not null
+ -- relpersistence | "char"    | not null
+ -- relkind        | "char"    | not null
+ -- relnatts       | smallint  | not null
+ -- relchecks      | smallint  | not null
+ -- relhasoids     | boolean   | not null
+ -- relhaspkey     | boolean   | not null
+ -- relhasrules    | boolean   | not null
+ -- relhastriggers | boolean   | not null
+ -- relhassubclass | boolean   | not null
+ -- relfrozenxid   | xid       | not null
+ -- relacl         | aclitem[] |
+ -- reloptions     | text[]    |
+  ]
+  [derivingShow])

relational-query/src/Database/Relational/Schema/PgCatalog/PgConstraint.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Database.Relational.Schema.PgCatalog.PgConstraint
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+module Database.Relational.Schema.PgCatalog.PgConstraint where
+
+import Data.Int (Int32)
+
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+
+$(defineTableTypesAndRecordDefault
+  "PG_CATALOG" "pg_constraint"
+  [ -- ("oid"    , [t| Int32 |]),
+ -- conname       | name         | not null
+ -- connamespace  | oid          | not null
+ -- contype       | "char"       | not null
+    ("contype",   [t| Char |]),
+ -- condeferrable | boolean      | not null
+ -- condeferred   | boolean      | not null
+ -- convalidated  | boolean      | not null
+ -- conrelid      | oid          | not null
+    ("conrelid",  [t| Int32 |])
+ -- contypid      | oid          | not null
+ -- conindid      | oid          | not null
+ -- confrelid     | oid          | not null
+ -- confupdtype   | "char"       | not null
+ -- confdeltype   | "char"       | not null
+ -- confmatchtype | "char"       | not null
+ -- conislocal    | boolean      | not null
+ -- coninhcount   | integer      | not null
+ -- conkey        | smallint[]   |
+    -- ("conkey",  ???),
+ -- confkey       | smallint[]   |
+ -- conpfeqop     | oid[]        |
+ -- conppeqop     | oid[]        |
+ -- conffeqop     | oid[]        |
+ -- conexclop     | oid[]        |
+ -- conbin        | pg_node_tree |
+ -- consrc        | text         |
+  ]
+  [derivingShow])
+
+

relational-query/src/Database/Relational/Schema/PgCatalog/PgNamespace.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Database.Relational.Schema.PgCatalog.PgNamespace
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+module Database.Relational.Schema.PgCatalog.PgNamespace where
+
+import Data.Int (Int32)
+
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+
+$(defineTableTypesAndRecordDefault
+  "PG_CATALOG" "pg_namespace"
+  [("oid"    , [t| Int32 |]),
+ -- nspname  | name      | not null
+   ("nspname", [t| String |])
+ -- nspowner | oid       | not null
+ -- nspacl   | aclitem[] |
+  ]
+  [derivingShow])

relational-query/src/Database/Relational/Schema/PgCatalog/PgType.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Database.Relational.Schema.PgCatalog.PgType
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+module Database.Relational.Schema.PgCatalog.PgType where
+
+import Data.Int (Int16, Int32)
+
+import Database.Record.TH (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+  "PG_CATALOG" "pg_type"
+
+  [
+    ("oid", [t|Int32|]),
+-- Table "pg_catalog.pg_type"
+--      Column     |     Type     | Modifiers
+-- ----------------+--------------+-----------
+--  typname        | name         | not null
+    ("typname", [t|String|]),
+--  typnamespace   | oid          | not null
+    ("typnamespace", [t|Int32|]),
+--  typowner       | oid          | not null
+    ("typowner", [t|Int32|]),
+--  typlen         | smallint     | not null
+    ("typlen", [t|Int16|]),
+--  typbyval       | boolean      | not null
+    ("typbyval", [t|Bool|]),
+--  typtype        | "char"       | not null
+    ("typtype", [t|Char|]),
+--  typcategory    | "char"       | not null
+    ("typcategory", [t|Char|]),
+--  typispreferred | boolean      | not null
+    ("typispreferred", [t|Bool|]),
+--  typisdefined   | boolean      | not null
+    ("typisdefined", [t|Bool|]),
+--  typdelim       | "char"       | not null
+    ("typdelim", [t|Char|]),
+--  typrelid       | oid          | not null
+    ("typrelid", [t|Int32|]),
+--  typelem        | oid          | not null
+    ("typelem", [t|Int32|]),
+--  typarray       | oid          | not null
+    ("typarray", [t|Int32|]),
+--  typinput       | regproc      | not null
+    -- ("typinput", [t||]),
+--  typoutput      | regproc      | not null
+    -- ("typoutput", [t||]),
+--  typreceive     | regproc      | not null
+    -- ("typreceive", [t||]),
+--  typsend        | regproc      | not null
+    -- ("typsend", [t||]),
+--  typmodin       | regproc      | not null
+    -- ("typmodin", [t||]),
+--  typmodout      | regproc      | not null
+    -- ("typmodout", [t||]),
+--  typanalyze     | regproc      | not null
+    -- ("typanalyze", [t||]),
+--  typalign       | "char"       | not null
+    ("typalign", [t|Char|]),
+--  typstorage     | "char"       | not null
+    ("typstorage", [t|Char|]),
+--  typnotnull     | boolean      | not null
+    ("typnotnull", [t|Bool|]),
+--  typbasetype    | oid          | not null
+    ("typbasetype", [t|Int32|]),
+--  typtypmod      | integer      | not null
+    ("typtypmod", [t|Int32|]),
+--  typndims       | integer      | not null
+    ("typndims", [t|Int32|]),
+--  typcollation   | oid          | not null
+    ("typcollation", [t|Int32|]),
+--  typdefaultbin  | pg_node_tree |
+    -- ("typdefaultbin", [t||]),
+--  typdefault     | text         |
+    ("typdefault", [t|Maybe String|])
+  ]
+  [derivingShow])

relational-query/src/Database/Relational/Schema/PostgreSQL.hs

@@ -0,0 +1,212 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Database.Relational.Schema.PostgreSQL
+-- Copyright   : 2013 Kei Hibino
+-- License     : BSD3
+--
+-- Maintainer  : ex8k.hibino@gmail.com
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- This module implements queries to get
+-- table schema and table constraint informations
+-- from system catalog of PostgreSQL.
+module Database.Relational.Schema.PostgreSQL (
+  Column,
+
+  normalizeColumn, notNull, getType,
+
+  columnQuerySQL,
+  primaryKeyLengthQuerySQL, primaryKeyQuerySQL
+  ) where
+
+import Prelude hiding (or)
+
+import Language.Haskell.TH (TypeQ)
+
+import Data.Int (Int16, Int32, Int64)
+import Data.Char (toLower)
+import Data.List (foldl1')
+import Data.Map (Map, fromList)
+import qualified Data.Map as Map
+import Data.Time
+  (DiffTime, NominalDiffTime,
+   LocalTime, ZonedTime, Day, TimeOfDay)
+
+import Database.Relational.Query.Type (relationalQuery)
+import Database.Relational.Query
+  (Query, Relation, query, query', relation', relation, union,
+   wheres, (.=.), (.>.), in', values, (!), fst', snd',
+   placeholder, asc, value, unsafeProjectSql, (><))
+
+import Database.Relational.Schema.PgCatalog.PgNamespace (pgNamespace)
+import qualified Database.Relational.Schema.PgCatalog.PgNamespace as Namespace
+import Database.Relational.Schema.PgCatalog.PgClass (pgClass)
+import qualified Database.Relational.Schema.PgCatalog.PgClass as Class
+import Database.Relational.Schema.PgCatalog.PgConstraint (PgConstraint, pgConstraint)
+import qualified Database.Relational.Schema.PgCatalog.PgConstraint as Constraint
+
+import Database.Relational.Schema.PgCatalog.PgAttribute (PgAttribute, pgAttribute)
+import qualified Database.Relational.Schema.PgCatalog.PgAttribute as Attr
+import Database.Relational.Schema.PgCatalog.PgType (PgType(..), pgType)
+import qualified Database.Relational.Schema.PgCatalog.PgType as Type
+
+import Control.Applicative ((<|>))
+
+
+-- | Mapping between type in PostgreSQL and Haskell type.
+mapFromSqlDefault :: Map String TypeQ
+mapFromSqlDefault =
+  fromList [("bool",         [t| Bool |]),
+            ("char",         [t| Char |]),
+            ("name",         [t| String |]),
+            ("int8",         [t| Int64 |]),
+            ("int2",         [t| Int16 |]),
+            ("int4",         [t| Int32 |]),
+            -- ("regproc",      [t| Int32 |]),
+            ("text",         [t| String |]),
+            ("oid",          [t| Int32 |]),
+            -- ("pg_node_tree", [t| String |]),
+            ("float4",       [t| Float |]),
+            ("float8",       [t| Double |]),
+            ("abstime",      [t| LocalTime |]),
+            ("reltime",      [t| NominalDiffTime |]),
+            ("tinterval",    [t| DiffTime |]),
+            -- ("money",        [t| Decimal |]),
+            ("bpchar",       [t| String |]),
+            ("varchar",      [t| String |]),
+            ("date",         [t| Day |]),
+            ("time",         [t| TimeOfDay |]),
+            ("timestamp",    [t| LocalTime |]),
+            ("timestamptz",  [t| ZonedTime |]),
+            ("interval",     [t| DiffTime |]),
+            ("timetz",       [t| ZonedTime |])
+
+            -- ("bit", [t|  |]),
+            -- ("varbit", [t|  |]),
+            -- ("numeric", [t| Decimal |])
+           ]
+
+-- | Normalize column name string to query PostgreSQL system catalog.
+normalizeColumn :: String -> String
+normalizeColumn =  map toLower
+
+-- | Type to represent Column information.
+type Column = (PgAttribute, PgType)
+
+-- | Not-null attribute information of column.
+notNull :: Column -> Bool
+notNull =  Attr.attnotnull . fst
+
+-- | Get column normalized name and column Haskell type.
+getType :: Map String TypeQ      -- ^ Type mapping specified by user
+        -> Column                -- ^ Column info in system catalog
+        -> Maybe (String, TypeQ) -- ^ Result normalized name and mapped Haskell type
+getType mapFromSql column@(pgAttr, pgTyp) = do
+  typ <- (Map.lookup key mapFromSql
+          <|>
+          Map.lookup key mapFromSqlDefault)
+  return (normalizeColumn $ Attr.attname pgAttr,
+          mayNull typ)
+  where key = Type.typname pgTyp
+        mayNull typ = if notNull column
+                      then typ
+                      else [t| Maybe $typ |]
+
+-- | 'Relation' to query PostgreSQL relation oid from schema name and table name.
+relOidRelation :: Relation (String, String) Int32
+relOidRelation = relation' $ do
+  nsp <- query pgNamespace
+  cls <- query pgClass
+
+  wheres $ cls ! Class.relnamespace' .=. nsp ! Namespace.oid'
+  (nspP, ()) <- placeholder (\ph -> wheres $ nsp ! Namespace.nspname'  .=. ph)
+  (relP, ()) <- placeholder (\ph -> wheres $ cls ! Class.relname'      .=. ph)
+
+  return   (nspP >< relP, cls ! Class.oid')
+
+-- | 'Relation' to query column attribute from schema name and table name.
+attributeRelation :: Relation (String, String) PgAttribute
+attributeRelation =  relation' $ do
+  (ph, reloid) <- query' relOidRelation
+  att          <- query  pgAttribute
+
+  wheres $ att ! Attr.attrelid' .=. reloid
+  wheres $ att ! Attr.attnum'   .>. value 0
+
+  return   (ph, att)
+
+-- | 'Relation' to query 'Column' from schema name and table name.
+columnRelation :: Relation (String, String) Column
+columnRelation = relation' $ do
+  (ph, att) <- query' attributeRelation
+  typ       <- query  pgType
+
+  wheres $ att ! Attr.atttypid'    .=. typ ! Type.oid'
+  wheres $ typ ! Type.typtype'     .=. value 'b'  -- 'b': base type only
+
+  wheres $ typ ! Type.typcategory' `in'` values [ 'B' -- Boolean types
+                                                , 'D' -- Date/time types
+                                                , 'N' -- Numeric types
+                                                , 'S' -- String types
+                                                , 'T' -- typespan types
+                                                ]
+ 
+  asc $ att ! Attr.attnum'
+
+  return (ph, att >< typ)
+
+-- | Phantom typed 'Query' to get 'Column' from schema name and table name.
+columnQuerySQL :: Query (String, String) Column
+columnQuerySQL =  relationalQuery columnRelation
+
+-- | 'Relation' to query primary key length from schema name and table name.
+primaryKeyLengthRelation :: Relation (String, String) Int32
+primaryKeyLengthRelation =  relation' $ do
+  (ph, reloid) <- query' relOidRelation
+  con       <- query  pgConstraint
+
+  wheres $ con ! Constraint.conrelid' .=. reloid
+  wheres $ con ! Constraint.contype'  .=. value 'p'  -- 'p': primary key constraint type
+
+  return (ph, unsafeProjectSql "array_length (conkey, 1)")
+
+-- | Phantom typed 'Query' to get primary key length from schema name and table name.
+primaryKeyLengthQuerySQL :: Query (String, String) Int32
+primaryKeyLengthQuerySQL =  relationalQuery primaryKeyLengthRelation
+
+-- | One column which is nth column of composite primary key.
+constraintColRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
+constraintColRelation i = relation $ do
+  con <- query pgConstraint
+
+  return $ con >< (unsafeProjectSql ("conkey[" ++ show i ++ "]") >< value i)
+
+-- | Make composite primary key relation from primary key length.
+constraintColExpandRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
+constraintColExpandRelation n =
+  foldl1' union [constraintColRelation i | i <- [1..n] ]
+
+-- | 'Relation' to query primary key name from schema name and table name.
+primaryKeyRelation :: Int32 -> Relation (String, String) String
+primaryKeyRelation n = relation' $ do
+  (ph, att) <- query' attributeRelation
+  conEx     <- query  (constraintColExpandRelation n)
+
+  let con = conEx ! fst'
+      col' = conEx ! snd'
+      keyIx = col' ! fst'
+      keyN  = col' ! snd'
+
+  wheres $ con ! Constraint.conrelid' .=. att ! Attr.attrelid'
+  wheres $ keyIx .=. att ! Attr.attnum'
+  wheres $ con ! Constraint.contype'  .=. value 'p'  -- 'p': primary key constraint type
+
+  asc  $ keyN
+
+  return (ph, att ! Attr.attname')
+
+-- | Phantom typed 'Query' to get primary key name from schema name and table name.
+primaryKeyQuerySQL :: Int32 -> Query (String, String) String
+primaryKeyQuerySQL =  relationalQuery . primaryKeyRelation